|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 19456 (0x4c00)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Xlbmp_Environment, seg_004f03
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
--/ if R1000 then
with String_Utilities;
with System_Utilities;
with Text_Io;
with Transport_Name;
--/ elsif Cdf_Hpux then
--// with C_Library_Interface;
--// with System;
--// with Unix_Base_Types;
--/ elsif TeleGen2 and then Unix then
--// with System;
--// with Unchecked_Conversion;
--// with Unix_Implementation_Types;
--// with Unix_Types;
--// with Ui_Environment;
--/ end if;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_String;
use Xlbt_String;
--/ if Record_Rep_Clauses then
--// with Xlbmt_Parameters;
--// use Xlbmt_Parameters;
--/ end if;
package body Xlbmp_Environment is
------------------------------------------------------------------------------
-- X Library Machine Dependent Environment Support
--
-- Xlbmp_Environment - Machine-Dependent support for environmental inquiry.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
--\x0c
function X_Env_Concat_Dir_File (Dir : X_String;
File : X_String) return X_String is
------------------------------------------------------------------------------
-- Dir - Specifies a "path" to some "place" in a directory structure
-- File - Specifies a "file" in the directory
--
-- Called to attach a file name to a directory name.
-- e.g.
-- R1000 "!Foo.Bar.Gorp" and "Blat" => "!Foo.Bar.Gorp.Blat"
-- Unix "/foo/bar/gorp" and "blat" => "/foo/bar/gorp/blat"
-- Vms "Foo:[Bar.Gorp]" and "Bl.at" => "Foo:[Bar.Gorp]Bl.at"
--
-- The Dir does not have any "separator" syntax after the name of the
-- path/directory. The File does not have any "separator" syntax at the front.
-- This routine supplies any "glue" syntax required between the Dir and the
-- File.
------------------------------------------------------------------------------
begin
--/ if R1000 then
return Dir & '.' & File;
--/ elsif Unix then
--//
--// return Dir & '/' & File;
--//
--/ else
--// return Need_Something_Here;
--/ end if;
end X_Env_Concat_Dir_File;
--\x0c
function X_Env_Get_Environment_Variable
(Var : X_String) return X_String_Pointer is
------------------------------------------------------------------------------
-- Var - Specifies the name of the variable
--
-- Returns None_X_String_Pointer if the variable does not exist or if
-- this environment/operating-system/run-time does not support any such
-- concept as environment variables.
--
-- Don't forget to free the string result with Free_X_String_Pointer;
------------------------------------------------------------------------------
--/ if R1000 then
Env : Text_Io.File_Type;
Env_Name : constant String :=
System_Utilities.Home_Library (User => System_Utilities.User_Name)
& "."
& System_Utilities.Session_Name & "_Environment."
& To_String (Var);
Env_Ptr : X_String_Pointer;
function Read_Env return X_String is
----Read one line from Env; regardless of the length of the
-- line.
Line : String (1 .. 1024);
Length : Natural;
begin
Text_Io.Get_Line (Env, Line, Length);
if Length = Line'Length and then
Text_Io.">" (Text_Io.Col (Env), 1) then
return To_X_String (Line) & Read_Env;
else
return To_X_String (Line (1 .. Length));
end if;
end Read_Env;
begin
----Open the Environment Variable file. Read the first line. Close the file.
-- Return that line as the value.
begin
Text_Io.Open (Env, Text_Io.In_File, Env_Name);
exception
when others =>
return None_X_String_Pointer;
end;
begin
Env_Ptr := new X_String'(Read_Env);
Text_Io.Close (Env);
return Env_Ptr;
exception
when others =>
begin -- Just in case.
Free_X_String_Pointer (Env_Ptr);
Text_Io.Close (Env);
exception
when others =>
null;
end;
return None_X_String_Pointer;
end;
--/ elsif Cdf_Hpux then
--//
--// begin
--// declare
--// V : constant X_String := Var & Nul;
--// begin
--// return new X_String'(To_X_String
--// (Unix_Base_Types.To_String
--// (C_Library_Interface.Shell.Getenv
--// (Unix_Base_Types.To_Char_Ptr
--// (V (V'First)'Address)))));
--// exception
--// when Constraint_Error =>
--// ----Getenv raises this when the variable does not exist.
--// return None_X_String_Pointer;
--// end;
--//
--/ elsif TeleGen2 and then Unix then
--//
--// begin
--//
--// begin
--// return new X_String'(To_X_String (Ui_Environment.Getenv (
--// To_String (Var))));
--// exception
--// when Constraint_Error =>
--// ----Getenv raises this when the variable does not exist.
--// return None_X_String_Pointer;
--// end;
--//
--/ else
--//
--// begin
--//
--// return Need_Something_Here;
--//
--/ end if;
end X_Env_Get_Environment_Variable;
--\x0c
function X_Env_Get_Host_Name return X_String is
------------------------------------------------------------------------------
-- Called to obtain the name of the machine we are running upon.
------------------------------------------------------------------------------
--/ if Cdf_Hpux then
--// function Get_Host_Name
--// (Name : System.Address; Namelen : S_Long) return S_Long;
--// pragma Interface (C, Get_Host_Name);
--// pragma Import_Function (Internal => Get_Host_Name,
--// External => "_gethostname",
--// Parameter_Types => (System.Address, S_Long),
--// Mechanism => (Value, Value),
--// Result_Type => S_Long);
--//
--// Buffer : X_String (1 .. 256);
--//
--//
--/ elsif TeleGen2 and then Unix then
--// function Get_Host_Name (Name : System.Address;
--// Namelen : S_Long) return S_Long;
--// pragma Interface (Unix, Get_Host_Name);
--// pragma Linkname (Get_Host_Name, "gethostname");
--//
--// Buffer : X_String (1 .. 256);
--//
--/ end if;
begin
--/ if R1000 then
return To_X_String (Transport_Name.Local_Host_Name ("TCP/IP"));
--/ elsif Cdf_Hpux then
--//
--// if Get_Host_Name (Buffer (Buffer'First)'Address, Buffer'Length) < 0 then
--// return "";
--// end if;
--// for I in Buffer'Range loop
--// if Buffer (I) = Nul then
--// return Buffer (Buffer'First .. I - 1);
--// end if;
--// end loop;
--// return Buffer;
--//
--/ elsif TeleGen2 and then Unix then
--//
--// if Get_Host_Name (Buffer (Buffer'First)'Address, Buffer'Length) < 0 then
--// return "";
--// end if;
--// for I in Buffer'Range loop
--// if Buffer (I) = Nul then
--// return Buffer (Buffer'First .. I - 1);
--// end if;
--// end loop;
--// return Buffer;
--//
--/ else
--// return Need_Something_Here;
--/ end if;
exception
when others =>
return "";
end X_Env_Get_Host_Name;
--\x0c
function X_Env_Get_Home_Dir return X_String is
------------------------------------------------------------------------------
-- Called to obtain a string containing the user's home directory. It does
-- *not* have any trailing separator syntax. ie. It returns something
-- like "/usr/home/foobar" and not "/usr/home/foobar/" or else
-- "!Users.Foobar" rather than "!Users.Foobar.".
------------------------------------------------------------------------------
--/ if R1000 then
begin
return To_X_String (System_Utilities.Home_Library
(System_Utilities.User_Name));
--/ elsif Cdf_Hpux then
--// begin
--// return To_X_String (Unix_Base_Types.To_String
--// (C_Library_Interface.Shell.Getenv
--// (Unix_Base_Types.To_Char_Ptr
--// ("HOME" & Ascii.Nul))));
--//
--/ elsif TeleGen2 and then Unix then
--//
--// use Unix_Implementation_Types;
--// use Unix_Types;
--// subtype Integer_32 is Unix_Types.Integer_32;
--//
--// type Passwd_Struct is
--// record
--// Pw_Name : C_String_Pointer;
--// Pw_Passwd : C_String_Pointer;
--// Pw_Uid : Integer_32;
--// Pw_Gid : Integer_32;
--// Pw_Quota : Integer_32;
--// Pw_Comment : C_String_Pointer;
--// Pw_Gecos : C_String_Pointer;
--// Pw_Dir : C_String_Pointer;
--// Pw_Shell : C_String_Pointer;
--// end record;
--//
--// for Passwd_Struct use
--// record
--// Pw_Name at 0 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Passwd at 1 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Uid at 2 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Gid at 3 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Quota at 4 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Comment at 5 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Gecos at 6 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Dir at 7 * X_Word range X_Word0a .. X_Word0b;
--// Pw_Shell at 8 * X_Word range X_Word0a .. X_Word0b;
--// end record;
--//
--// type Passwd is access Passwd_Struct;
--//
--// function Get_Env (Name : C_String_Pointer) return C_String_Pointer;
--// pragma Interface (Unix, Get_Env);
--// pragma Linkname (Get_Env, "getenv");
--//
--// function Get_Pw_Nam (Name : C_String_Pointer) return Passwd;
--// pragma Interface (Unix, Get_Pw_Nam);
--// pragma Linkname (Get_Pw_Nam, "getpwnam");
--//
--// function Get_Pw_Uid (Uid : Integer_32) return Passwd;
--// pragma Interface (Unix, Get_Pw_Uid);
--// pragma Linkname (Get_Pw_Uid, "getpwuid");
--//
--// function Get_Uid return Integer_32;
--// pragma Interface (Unix, Get_Uid);
--// pragma Linkname (Get_Uid, "getuid");
--//
--// function Cvt is new Unchecked_Conversion (Passwd, Integer_32);
--//
--// begin
--//
--// ----First we try the easy way; check the HOME environment variable.
--// -- If it is defined (not null) and if it has a non-zero length then return
--// -- the contents of that string as our result.
--//
--// declare
--// Home : C_String_Pointer;
--// begin
--// Home := Get_Env (Ada_String_To_C_String_Pointer ("HOME"));
--// if Home /= Null_C_String_Pointer then
--// declare
--// Home_Str : constant String :=
--// C_String_Pointer_To_Ada_String (Home);
--// begin
--// if Home_Str'Length > 0 then
--// return To_X_String (Home_Str);
--// end if;
--// end;
--// end if;
--// end;
--//
--// ----The HOME variable is not useable. See if the USER variable is useable.
--// -- If it is then we try getting the system's user information.
--//
--// declare
--// User : C_String_Pointer;
--// Pw : Passwd;
--// begin
--// User := Get_Env (Ada_String_To_C_String_Pointer ("USER"));
--// if User /= Null_C_String_Pointer then
--// Pw := Get_Pw_Nam (User);
--// if Cvt (Pw) = 0 then
--// Pw := Get_Pw_Uid (Get_Uid);
--// end if;
--// else
--// Pw := Get_Pw_Uid (Get_Uid);
--// end if;
--//
--// ----Unix NULL is a 0 so compare the result of our queries to 0. If we got
--// -- something then return the directory name. If not then return "".
--//
--// if Cvt (Pw) = 0 then
--// return "";
--// else
--// return To_X_String
--// (C_String_Pointer_To_Ada_String (Pw.Pw_Dir));
--// end if;
--// end;
--//
--/ else
--// return Need_Something_Else;
--/ end if;
end X_Env_Get_Home_Dir;
--\x0c
function X_Env_Strip_Program_Name (Program : X_String) return X_String is
------------------------------------------------------------------------------
-- Program - Specifies the full/complex/whatever program name
--
-- Called with a string that contains the program name. On a Unix system this
-- is a string that contains the program name complete with possible path
-- information. The string came from the command line. On VMS this would
-- just be the name of the command verb that ran the program. On an R1000 this
-- is whatever string the user wanted to provide.
--
-- The purpose of this routine is to do whatever operating-system specific
-- actions may be necessary to transform the string into a simple name for
-- the purposes of resource lookup.
------------------------------------------------------------------------------
Start : S_Natural;
Stop : S_Natural;
begin
--/ if R1000 then
Start := Program'First;
Stop := Program'Last;
for I in reverse Program'Range loop
if Program (I) = ''' then
Stop := I - 1;
elsif Program (I) = '.' then
Start := I + 1;
exit;
end if;
end loop;
return To_X_String (String_Utilities.Lower_Case
(To_String (Program (Start .. Stop))));
--/ elsif Unix then
--//
--// for I in reverse Program'Range loop
--// if Program (I) = '/' then
--// return Program (I + 1 .. Program'Last);
--// end if;
--// end loop;
--// return Program;
--//
--/ else
--// Need_Something_Here;
--/ end if;
end X_Env_Strip_Program_Name;
--\x0c
end Xlbmp_Environment;
nblk1=12
nid=0
hdr6=24
[0x00] rec0=23 rec1=00 rec2=01 rec3=066
[0x01] rec0=11 rec1=00 rec2=02 rec3=084
[0x02] rec0=14 rec1=00 rec2=03 rec3=022
[0x03] rec0=1f rec1=00 rec2=04 rec3=014
[0x04] rec0=1b rec1=00 rec2=05 rec3=06c
[0x05] rec0=00 rec1=00 rec2=12 rec3=010
[0x06] rec0=1f rec1=00 rec2=06 rec3=05e
[0x07] rec0=18 rec1=00 rec2=07 rec3=006
[0x08] rec0=19 rec1=00 rec2=08 rec3=004
[0x09] rec0=20 rec1=00 rec2=09 rec3=026
[0x0a] rec0=1a rec1=00 rec2=0a rec3=094
[0x0b] rec0=1c rec1=00 rec2=0b rec3=018
[0x0c] rec0=11 rec1=00 rec2=0c rec3=038
[0x0d] rec0=19 rec1=00 rec2=0d rec3=058
[0x0e] rec0=19 rec1=00 rec2=0e rec3=018
[0x0f] rec0=1d rec1=00 rec2=0f rec3=048
[0x10] rec0=16 rec1=00 rec2=10 rec3=00a
[0x11] rec0=1c rec1=00 rec2=11 rec3=000
tail 0x21700642e81978034c14d 0x42a00088462063203