File: [local] / OpenXM_contrib / PHC / Ada / System / machines.adb (download)
Revision 1.1.1.1 (vendor branch), Sun Oct 29 17:45:34 2000 UTC (23 years, 10 months ago) by maekawa
Branch: PHC, MAIN
CVS Tags: v2, maekawa-ipv6, RELEASE_1_2_3, RELEASE_1_2_2_KNOPPIX_b, RELEASE_1_2_2_KNOPPIX, RELEASE_1_2_2, RELEASE_1_2_1, HEAD Changes since 1.1: +0 -0
lines
Import the second public release of PHCpack.
OKed by Jan Verschelde.
|
with System_Call;
with text_io,integer_io; use text_io,integer_io;
package body Machines is
function getpid return integer;
pragma interface(C, getpid);
function Process_ID return integer is
begin
return getpid;
end Process_ID;
function Integer_to_String ( i : integer ) return string is
answer : string(1..20);
nb : natural := 0;
tmp : integer := i;
function Number_to_Character ( n : integer ) return character is
begin
case n is
when 0 => return '0';
when 1 => return '1';
when 2 => return '2';
when 3 => return '3';
when 4 => return '4';
when 5 => return '5';
when 6 => return '6';
when 7 => return '7';
when 8 => return '8';
when 9 => return '9';
when others => return ' ';
end case;
end Number_to_Character;
begin
if tmp = 0
then nb := nb + 1;
answer(nb) := Number_to_Character(0);
end if;
while tmp /= 0 loop
nb := nb + 1;
answer(nb) := Number_to_Character(tmp mod 10);
tmp := tmp / 10;
end loop;
declare
res : string(1..nb);
begin
for j in res'range loop
res(j) := answer(nb-j+1);
end loop;
return res;
end;
end Integer_to_String;
function Process_ID return string is
begin
return Integer_to_String(getpid);
end Process_ID;
function User_Name ( pid : string ) return string is
temp : file_type;
name : string(1..80);
last : natural;
begin
System_Call.Call("whoami > /tmp/user_name" & pid);
Open(temp,in_file,"/tmp/user_name" & pid);
get_line(temp,name,last);
Close(temp);
System_Call.Call("rm /tmp/user_name" & pid);
return name(1..last);
exception
when others => return "???";
end User_Name;
function Architecture ( pid : string ) return string is
temp : file_type;
answer : string(1..80);
last : natural;
begin
System_Call.Call("uname -a > /tmp/arch_type" & pid);
Open(temp,in_file,"/tmp/arch_type" & pid);
get_line(temp,answer,last);
Close(temp);
System_Call.Call("rm /tmp/arch_type" & pid);
return answer(1..last);
exception
when others => return "???";
end Architecture;
function Architecture ( pid : string; machine : string ) return string is
temp : file_type;
answer : string(1..80);
last : natural;
begin
System_Call.Call("rsh " & machine & " uname -a > /tmp/arch_type" & pid);
Open(temp,in_file,"/tmp/arch_type" & pid);
get_line(temp,answer,last);
Close(temp);
System_Call.Call("rm /tmp/arch_type" & pid);
return answer(1..last);
exception
when others => return "???";
end Architecture;
function Host_Name ( pid : string ) return string is
temp : file_type;
answer : string(1..80);
last : natural;
begin
System_Call.Call("hostname > /tmp/host_name" & pid);
Open(temp,in_file,"/tmp/host_name" & pid);
get_line(temp,answer,last);
Close(temp);
System_Call.Call("rm /tmp/host_name" & pid);
return answer(1..last);
exception
when others => return "???";
end Host_Name;
function Date ( pid : string ) return string is
temp : file_type;
answer : string(1..80);
last : natural;
begin
System_Call.Call("date > /tmp/date" & pid);
Open(temp,in_file,"/tmp/date" & pid);
get_line(temp,answer,last);
Close(temp);
System_Call.Call("rm /tmp/date" & pid);
return answer(1..last);
exception
when others => return "???";
end Date;
end Machines;