|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 57427 (0xe053)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦591c5b094⟧
└─⟦this⟧
with Archive;
with Byte_Defs;
with Common;
with Compilation;
with Debug_Tools;
with Directory_Tools;
with Editor;
with File_Transfer;
with Ftp_Defs;
with Ftp_Profile;
with Text_Io;
with Time_Utilities;
with Library;
with Log;
with Profile;
with String_Map_Generic;
with String_Utilities;
with System_Utilities;
with Table_Sort_Generic;
with Transport;
with Transport_Defs;
with Transport_Name;
with Unchecked_Deallocation;
procedure Ship_To_Unix
(Password : String; -- User's password
Force_Update : Boolean := False; -- Update regardless
Effort_Only : Boolean := False; -- Just checking
Unix_Machine : String := "<SHIP_TO_MACHINE>";
Username : String := "<SHIP_TO_USERNAME>") is
------------------------------------------------------------------------------
-- Copyright 1990 - 1991 by Rational, Santa Clara, California.
--
-- 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 Rational not be used in
-- advertising or publicity pertaining to distribution of the software without
-- specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- 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.
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- Imported Renames
------------------------------------------------------------------------------
package Dt renames Directory_Tools;
function "=" (A, B : Dt.Object.Class_Enumeration) return Boolean
renames Dt.Object."=";
function "=" (A, B : Ftp_Defs.Status_Code) return Boolean
renames Ftp_Defs."=";
function "=" (A, B : Transport_Defs.Status_Code) return Boolean
renames Transport_Defs."=";
------------------------------------------------------------------------------
-- Exceptions
------------------------------------------------------------------------------
I_Am_Confused : exception;
----I give up. Some assumption of the code has changed and the code wasn't
-- changed to reflect it.
Quit : exception;
----Raised when we want to give up on something.
------------------------------------------------------------------------------
-- Types
------------------------------------------------------------------------------
type String_Pointer is access String;
pragma Enable_Deallocation (String_Pointer);
procedure Free_String_Pointer is
new Unchecked_Deallocation (String,
String_Pointer);
type Natural_Array is array (Natural range <>) of Natural;
type Database_Entry_Rec is
record
----These are used only during processing.
-- They are not saved in the database.
Full_R1000_Name : String_Pointer := null;
Update : Boolean := False;
Bad_Name : Boolean := False;
Updated : Boolean := False;
----These are saved in the database.
R1000_Name : String_Pointer; -- Object minus 'V(nn)
Unix_Path : String_Pointer; -- Path on unix
Unix_Name : String_Pointer; -- Name of file on Unix
Version : String_Pointer; -- 'V(nn) or 'V(library)
Directory : Boolean; -- True for libraries/worlds
Ignore : Boolean := False; -- True for R1000-only files
New_One : Boolean := False; -- True for new objects
end record;
type Database_Entry is access Database_Entry_Rec;
pragma Enable_Deallocation (Database_Entry);
procedure Free_Database_Entry is
new Unchecked_Deallocation (Database_Entry_Rec,
Database_Entry);
type Database_Entry_Array is array (Natural range <>) of Database_Entry;
function Check_Object (Obj : Dt.Object.Handle;
Root : String) return Database_Entry;
------------------------------------------------------------------------------
-- Global Data
------------------------------------------------------------------------------
package Obj_Db is
new String_Map_Generic (Range_Type => Database_Entry,
Size => 401,
Ignore_Case => True);
Database : Obj_Db.Map;
Connection : File_Transfer.Connect_Id;
Host_Machine_Name : String_Pointer;
Host_User_Name : String_Pointer;
Files_Processed : Integer := 0;
Files_Transferred : Integer := 0;
Files_Deferred : Integer := 0;
Temp_File_Used : Boolean := False;
Temp_File_Name : constant String :=
"!Machine.Temporary.Ship_To_Unix_" &
Time_Utilities.Image (Time_Utilities.Get_Time,
Date_Style => Time_Utilities.Ada,
Contents => Time_Utilities.Date_Only) & "_" &
Time_Utilities.Image (Time_Utilities.Get_Time,
Time_Style => Time_Utilities.Ada,
Contents => Time_Utilities.Time_Only);
--\f
function X_Env_Get_Environment_Variable
(Var : String) return 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."
& Var;
Env_Ptr : String_Pointer;
function Read_Env return 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 Line & Read_Env;
else
return 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);
Env_Ptr := new String'(Read_Env);
Text_Io.Close (Env);
return Env_Ptr;
exception
when others =>
begin -- Just in case.
Free_String_Pointer (Env_Ptr);
Text_Io.Close (Env);
exception
when others =>
null;
end;
return null;
end;
--/ else
--//
--// begin
--//
--// begin
--// return new X_String'(To_X_String (Ui_Environment.Getenv (Var)));
--// exception
--// when Constraint_Error =>
--// ----Getenv raises this when the variable does not exist.
--// return None_X_String_Pointer;
--// end;
--//
--/ end if;
end X_Env_Get_Environment_Variable;
--\f
function Hs (Str : String) return String_Pointer is
------------------------------------------------------------------------------
-- Str - Specifies the string value
--
-- Called to allocate a string on the heap.
------------------------------------------------------------------------------
Tmp : String (1 .. Str'Length) := Str;
begin
return new String'(Tmp);
end Hs;
--\f
procedure Read_Database (Name : String) is
------------------------------------------------------------------------------
-- Name - Speicifies the name of the database to read
--
-- Called to read in an Ascii database file.
------------------------------------------------------------------------------
Line : String (1 .. 1024);
Len : Natural;
File : Text_Io.File_Type;
Ent : Database_Entry;
Error : Boolean := False;
begin
----Open the file.
begin
Text_Io.Open (File, Text_Io.In_File, Name);
exception
when others =>
Log.Put_Line ("Error opening " & Name & "; exception " &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Exception_Msg,
Profile.Verbose);
raise Quit;
end;
----Read the file.
while not Text_Io.End_Of_File (File) loop
Ent := new Database_Entry_Rec;
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) = '=' then
raise I_Am_Confused;
end if;
Ent.R1000_Name := Hs (Line (1 .. Len));
Text_Io.Get_Line (File, Line, Len);
if Len > 0 and then Line (1) = '=' then
raise I_Am_Confused;
end if;
Ent.Unix_Path := Hs (Line (1 .. Len));
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) = '=' then
raise I_Am_Confused;
end if;
Ent.Unix_Name := Hs (Line (1 .. Len));
Text_Io.Get_Line (File, Line, Len);
if Len > 0 and then Line (1) = '=' then
raise I_Am_Confused;
end if;
Ent.Version := Hs (Line (1 .. Len));
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) = '=' then
raise I_Am_Confused;
end if;
if String_Utilities.Equal ("directory:",
Line (1 .. 10),
Ignore_Case => True) then
Ent.Directory := Boolean'Value (Line (11 .. Len));
else
raise I_Am_Confused;
end if;
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) = '=' then
raise I_Am_Confused;
end if;
if String_Utilities.Equal ("ignore:",
Line (1 .. 7),
Ignore_Case => True) then
Ent.Ignore := Boolean'Value (Line (8 .. Len));
else
raise I_Am_Confused;
end if;
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) = '=' then
raise I_Am_Confused;
end if;
if String_Utilities.Equal ("new:",
Line (1 .. 4),
Ignore_Case => True) then
Ent.New_One := Boolean'Value (Line (5 .. Len));
else
raise I_Am_Confused;
end if;
Text_Io.Get_Line (File, Line, Len);
if Len = 0 or else Line (1) /= '=' then
raise I_Am_Confused;
end if;
if not Ent.Ignore and then
Ent.Unix_Name'Length > 14 and then
(not Ent.Directory or else
String_Utilities.Locate ("/", Ent.Unix_Name.all) = 0) then
Ent.Bad_Name := True;
Error := True;
Log.Put_Line ("Unix name too long," &
Natural'Image (Ent.Unix_Name'Length) &
" characters: " & Ent.Unix_Name.all,
Profile.Error_Msg,
Profile.Verbose);
end if;
Obj_Db.Define (Database, Ent.R1000_Name.all, Ent,
Trap_Multiples => True);
end loop;
----Close the file.
Text_Io.Close (File);
if Error then
raise Quit;
end if;
exception
when Quit =>
raise;
when I_Am_Confused =>
Log.Put_Line ("Database " & Name & " has bad format on line " &
Integer'Image (Integer (Text_Io.Line (File))),
Profile.Error_Msg,
Profile.Verbose);
Text_Io.Close (File);
raise I_Am_Confused;
when others =>
Log.Put_Line ("Database " & Name & " had I/O error: " &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Exception_Msg,
Profile.Verbose);
Log.Put_Line ("Error reading/on line " &
Integer'Image (Integer (Text_Io.Line (File))),
Profile.Error_Msg,
Profile.Verbose);
begin
Text_Io.Close (File);
exception
when others =>
null;
end;
raise I_Am_Confused;
end Read_Database;
--\f
procedure Write_Database (Name : String) is
------------------------------------------------------------------------------
-- Name - Speicifies the name of the database to write
--
-- Called to write out an Ascii database file.
------------------------------------------------------------------------------
File : Text_Io.File_Type;
Ent : Database_Entry;
Iter : Obj_Db.Iterator;
Ary : Database_Entry_Array (1 .. Natural
(Obj_Db.Cardinality (Database)));
function Lss (Left, Right : Database_Entry) return Boolean is
begin
return Left.R1000_Name.all < Right.R1000_Name.all;
end Lss;
procedure Sort is new Table_Sort_Generic (Database_Entry,
Natural,
Database_Entry_Array,
Lss);
begin
----Open the file.
begin
Text_Io.Open (File, Text_Io.Out_File, Name);
exception
when others =>
begin
Text_Io.Create (File, Text_Io.Out_File, Name);
exception
when others =>
Log.Put_Line ("Error opening " & Name & "; exception " &
Debug_Tools.Get_Exception_Name
(True, True),
Profile.Exception_Msg,
Profile.Verbose);
raise Quit;
end;
end;
----Write the file.
Obj_Db.Init (Iter, Database);
for I in Ary'Range loop
Ent := Obj_Db.Eval (Database, Obj_Db.Value (Iter));
Ary (I) := Ent;
if not Ent.Ignore and then
Ent.Unix_Name'Length > 14 and then
(not Ent.Directory or else
String_Utilities.Locate ("/", Ent.Unix_Name.all) = 0) then
Ent.Bad_Name := True;
Ent.Update := False;
Ent.Version := new String (1 .. 0);
Log.Put_Line ("Unix name too long," &
Natural'Image (Ent.Unix_Name'Length) &
" characters: " & Ent.Unix_Name.all,
Profile.Error_Msg,
Profile.Verbose);
end if;
Obj_Db.Next (Iter);
end loop;
Sort (Ary);
for I in Ary'Range loop
Ent := Ary (I);
Text_Io.Put_Line (File, Ent.R1000_Name.all);
Text_Io.Put_Line (File, Ent.Unix_Path.all);
Text_Io.Put_Line (File, Ent.Unix_Name.all);
if Ent.Update or else
(Ent.New_One and then Effort_Only) then
Text_Io.New_Line (File);
else
Text_Io.Put_Line (File, Ent.Version.all);
end if;
Text_Io.Put_Line (File, "Directory: " &
Boolean'Image (Ent.Directory));
Text_Io.Put_Line (File, "Ignore: " & Boolean'Image (Ent.Ignore));
Text_Io.Put_Line (File, "New: " & Boolean'Image (Ent.New_One));
if Ent.New_One then
Log.Put_Line ("New: " & Ent.R1000_Name.all,
Profile.Note_Msg,
Profile.Verbose);
end if;
Text_Io.Put_Line (File, "====");
end loop;
----Close the file.
Text_Io.Close (File);
exception
when others =>
Log.Put_Line ("Database " & Name & " had I/O error: " &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Exception_Msg,
Profile.Verbose);
begin
Text_Io.Close (File);
exception
when others =>
null;
end;
raise Quit;
end Write_Database;
--\f
function Remove_Root (Full : String;
Root : String) return String is
------------------------------------------------------------------------------
-- Full - Specifies the Full_Name of an object
-- Root - Specifies a string that is supposed to match the initial
-- portion of Full
--
-- Removes the Root prefix from the Full name. The initial part of Full must
-- match or we abort.
------------------------------------------------------------------------------
begin
if Full (Full'First .. Full'First + Root'Length - 1) /= Root then
Log.Put_Line ("R1000_Root is " & Root,
Profile.Error_Msg,
Profile.Verbose);
Log.Put_Line ("Object is not contained in R1000_Root: " & Full,
Profile.Error_Msg,
Profile.Verbose);
raise Quit;
end if;
----Drop the '.' that follows the Root.
return Full (Full'First + Root'Length + 1 .. Full'Last);
end Remove_Root;
--\f
function Segment_Name (Name : String) return Natural_Array is
------------------------------------------------------------------------------
-- Name - Specifies the name to segment.
--
-- Returns an array of indexes. Each index indicates the place within the
-- string of a '.' or a ''' or Name'Last+1.
------------------------------------------------------------------------------
Result : Natural_Array (1 .. 2 + Name'Length / 2);
Resulti : Natural := 1;
begin
Result (Resulti) := Name'First - 1;
for I in Name'Range loop
if Name (I) = '.' or else
Name (I) = ''' then
Resulti := Resulti + 1;
Result (Resulti) := I;
end if;
end loop;
Resulti := Resulti + 1;
Result (Resulti) := Name'Last + 1;
return Result (1 .. Resulti);
end Segment_Name;
--\f
function Check_Database (Obj : Dt.Object.Handle;
Root : String) return Database_Entry is
------------------------------------------------------------------------------
-- Obj - Specifies the R1000 object to be transferred to Unix
-- Root - Specifies the root for objects, this portion of the Obj's name
-- must match and it will be removed before we process it
--
-- We take an object handle, we look it up in the database, and we return a
-- pointer to it if we want it transferred and we return null if we do not
-- want it transferred. Makes a new entry in the database if necessary.
------------------------------------------------------------------------------
Uni : constant String :=
Remove_Root (Dt.Naming.Unique_Full_Name (Obj),
Root);
Unique : String (1 .. Uni'Length) := Uni;
Offsets : constant Natural_Array := Segment_Name (Unique);
Offset_Tick : Natural := Offsets'Last;
Class : Dt.Object.Class_Enumeration := Dt.Object.Class (Obj);
Entrec : Database_Entry_Rec;
Ent : Database_Entry;
Subobj : Dt.Object.Handle;
Success : Boolean;
Remote_Name : String (1 .. 1024);
Remote_Namei : Natural := 0;
Len : Natural;
Cap : Boolean;
begin
----Get the name of the object. If it is the same name as the Root then
-- we ignore this object.
if Dt.Naming.Full_Name (Obj) = Root then
return null;
end if;
----For all of the name segments that correspond to directories, make sure that
-- those directories have been processed.
for I in Offsets'First + 1 .. Offsets'Last - 1 loop
if Unique (Offsets (I)) /= '.' then
Offset_Tick := I;
exit;
end if;
Subobj := Dt.Naming.Resolution
(Root & '.' &
Unique (Unique'First .. Offsets (I) - 1));
Ent := Check_Object (Subobj, Root);
if Dt.Object.Class (Subobj) = Dt.Object.Library_Class then
if Ent.Unix_Path'Length > 0 then
Remote_Namei :=
Ent.Unix_Path'Length + Ent.Unix_Name'Length + 1;
Remote_Name (1 .. Remote_Namei) :=
Ent.Unix_Path.all & Ent.Unix_Name.all & '/';
else
Remote_Namei := Ent.Unix_Name'Length + 1;
Remote_Name (1 .. Remote_Namei) := Ent.Unix_Name.all & '/';
end if;
end if;
end loop;
----Locate the 'V version string in the Unique name.
for I in Offsets'First + 1 .. Offsets'Last - 1 loop
if Unique (Offsets (I)) = ''' and then
Unique (Offsets (I) + 1) = 'V' then
Entrec.Version := Hs (Unique
(Offsets (I) .. Offsets (I + 1) - 1));
Entrec.R1000_Name :=
Hs (Unique (Unique'First .. Offsets (I) - 1));
exit;
end if;
end loop;
if Entrec.Version = null then
if Class /= Dt.Object.Library_Class then
Log.Put_Line ("No 'V in Unique name???",
Profile.Error_Msg,
Profile.Verbose);
raise Quit;
else
Entrec.R1000_Name := Hs (Unique);
Entrec.Version := Hs ("'V(library)");
end if;
end if;
----Now look up the R1000_Name in the database. If the name was there already
-- then update the file if that is necessary.
Obj_Db.Find (Database, Entrec.R1000_Name.all, Ent, Success);
if Success then
if Ent.Version.all /= Entrec.Version.all then
Ent.Update := not Ent.Updated and not Ent.Bad_Name;
Free_String_Pointer (Entrec.R1000_Name);
Free_String_Pointer (Ent.Version);
Ent.Version := Entrec.Version;
Ent.Full_R1000_Name := Hs (Unique);
else
Ent.Update := Force_Update and not Ent.Updated;
Free_String_Pointer (Entrec.Version);
Free_String_Pointer (Entrec.R1000_Name);
Ent.Full_R1000_Name := Hs (Unique);
end if;
if Ent.Ignore then
Ent.Update := False;
end if;
if not Ent.Updated and not Ent.Update then
Files_Deferred := Files_Deferred + 1;
end if;
Files_Processed := Files_Processed + 1;
return Ent;
end if;
----Create a Unix name for this object.
Cap := not Lower_Case_Names;
for I in Offsets (Offset_Tick - 1) + 1 .. Offsets (Offset_Tick) - 1 loop
if Unique (I) = '_' then
Cap := not Lower_Case_Names;
elsif Cap then
if Unique (I) in 'a' .. 'z' then
Unique (I) := Character'Val (Character'Pos (Unique (I)) -
Integer (Character'Pos ('a') -
Character'Pos ('A')));
end if;
Cap := False;
else
if Unique (I) in 'A' .. 'Z' then
Unique (I) := Character'Val (Character'Pos (Unique (I)) -
Integer (Character'Pos ('A') -
Character'Pos ('a')));
end if;
end if;
end loop;
Entrec.Unix_Path := Hs (Remote_Name (1 .. Remote_Namei));
Remote_Namei := Offsets (Offset_Tick) - Offsets (Offset_Tick - 1) - 1;
Remote_Name (1 .. Remote_Namei) :=
Unique (Offsets (Offset_Tick - 1) + 1 .. Offsets (Offset_Tick) - 1);
----We have a new object. We need to create a Unix name for this object
-- and make a new database entry.
Entrec.Directory := False;
case Class is
when Dt.Object.Library_Class =>
Entrec.Unix_Name := Hs (String_Utilities.Lower_Case
(Remote_Name (1 .. Remote_Namei)));
Entrec.Directory := True;
when Dt.Object.Ada_Class =>
case Dt.Ada_Object.Unit_Kind'(Dt.Ada_Object.Kind (Obj)) is
when Dt.Ada_Object.Function_Spec |
Dt.Ada_Object.Function_Instantiation =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".FNS");
when Dt.Ada_Object.Function_Body =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".FNB");
when Dt.Ada_Object.Procedure_Spec |
Dt.Ada_Object.Procedure_Instantiation =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PRS");
when Dt.Ada_Object.Procedure_Body =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PRB");
when Dt.Ada_Object.Package_Spec |
Dt.Ada_Object.Package_Instantiation =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PKS");
when Dt.Ada_Object.Package_Body =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PKB");
when Dt.Ada_Object.Generic_Function =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".FNG");
when Dt.Ada_Object.Generic_Procedure =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PRG");
when Dt.Ada_Object.Generic_Package =>
Entrec.Unix_Name :=
Hs (Remote_Name (1 .. Remote_Namei) & ".PKG");
when others =>
Log.Put_Line ("R1000 Ada class " &
Dt.Ada_Object.Unit_Kind'Image
(Dt.Ada_Object.Unit_Kind'
(Dt.Ada_Object.Kind (Obj))) &
" is not supported.",
Profile.Warning_Msg,
Profile.Verbose);
Log.Put_Line ("Not transferred: " &
Dt.Naming.Unique_Full_Name (Obj),
Profile.Warning_Msg,
Profile.Verbose);
raise Quit;
end case;
when Dt.Object.File_Class =>
Entrec.Unix_Name := Hs (Remote_Name (1 .. Remote_Namei));
when others =>
Log.Put_Line ("R1000 object class " &
Dt.Object.Image (Class) & " is not supported.",
Profile.Warning_Msg,
Profile.Verbose);
Log.Put_Line ("Not transferred: " &
Dt.Naming.Unique_Full_Name (Obj),
Profile.Warning_Msg,
Profile.Verbose);
raise Quit;
end case;
----Create the new database entry.
Ent := new Database_Entry_Rec'(Entrec);
Ent.Update := False; -- Do *not* send new entries.
Ent.New_One := True; -- Let the user check the DB entry 1st.
Ent.Full_R1000_Name := Hs (Unique);
if Effort_Only or not Ent.Update then
Ent.Version := new String (1 .. 0);
end if;
if Ent.Unix_Name'Length > 14 then
Ent.Bad_Name := True;
Ent.Update := False;
Log.Put_Line ("Unix name too long," &
Natural'Image (Ent.Unix_Name'Length) &
" characters: " & Ent.Unix_Name.all,
Profile.Error_Msg,
Profile.Verbose);
end if;
Obj_Db.Define (Database, Entrec.R1000_Name.all, Ent);
Files_Processed := Files_Processed + 1;
Files_Deferred := Files_Deferred + 1;
return Ent;
end Check_Database;
--\f
function Natural_Image (Val : Natural) return String is
------------------------------------------------------------------------------
-- Val - Specifies the value
-- Turn a natural into a string with no leading blanks.
------------------------------------------------------------------------------
Str : constant String := Natural'Image (Val);
begin
return Str (Str'First + 1 .. Str'Last);
end Natural_Image;
--\f
function Duration_Image (Time : Duration) return String is
------------------------------------------------------------------------------
-- Time - Specifies the duration
-- Ada doesn't give us a nice way to turn a Fixed quantity into a string so
-- we must hack one up.
------------------------------------------------------------------------------
Val : Integer := Integer (Time * Duration (1000.0));
Valsub : Natural := (abs Val) rem 1000;
begin
if Valsub < 10 then
return Natural_Image (Val / 1000) & ".00" & Natural_Image (Valsub);
elsif Valsub < 100 then
return Natural_Image (Val / 1000) & ".0" & Natural_Image (Valsub);
else
return Natural_Image (Val / 1000) & "." & Natural_Image (Valsub);
end if;
end Duration_Image;
--\f
function Get_Host_Id (Name : String) return Transport_Defs.Host_Id is
------------------------------------------------------------------------------
-- Name - Specifies the name of some remote host
-- Returns the Host_Id of this host or else returns an empty Host_Id if the
-- name isn't known.
------------------------------------------------------------------------------
begin
return Transport_Name.Host_To_Host_Id (Name);
exception
when Transport_Name.Undefined =>
return (1 .. 0 => 0);
end Get_Host_Id;
--\f
procedure Response (Connection : File_Transfer.Connect_Id) is
------------------------------------------------------------------------------
-- Conection - Specifies the connection to check
-- Called to read any and all Response text that has been received from the
-- Unix_Machine host in response to any FTP command. The response text is
-- send to the Log.
------------------------------------------------------------------------------
Str : String (1 .. 1000);
Len : Natural;
begin
while not File_Transfer.End_Of_Response (Connection) loop
File_Transfer.Read_Response (Connection, Str, Len);
Log.Put_Line ("Ftp: " & Str (1 .. Len),
Profile.Note_Msg,
Profile.Verbose);
end loop;
end Response;
--\f
procedure Status_Ok (Status : Ftp_Defs.Status_Code) is
------------------------------------------------------------------------------
-- Status - Specifies a status to check
-- Complains and raises Quit if the Status != Successful
------------------------------------------------------------------------------
begin
if Status /= Ftp_Defs.Successful then
Log.Put_Line ("Error in Ship_To_Unix: " &
Ftp_Defs.Status_Code'Image (Status),
Profile.Error_Msg,
Profile.Verbose);
raise Quit;
end if;
end Status_Ok;
--\f
procedure Status_Ok (Status : Transport_Defs.Status_Code) is
------------------------------------------------------------------------------
-- Status - Specifies a status to check
-- Complains and raises Quit if the Status != Ok.
------------------------------------------------------------------------------
begin
if Status /= Transport_Defs.Ok then
Log.Put_Line ("Error in Ship_To_Unix: " &
Transport_Defs.Image (Status),
Profile.Error_Msg,
Profile.Verbose);
raise Quit;
end if;
end Status_Ok;
--\f
procedure Disconnect (Connection : in out File_Transfer.Connect_Id) is
------------------------------------------------------------------------------
-- Connection - Specifies the connection to destroy
-- Called (at any time, in any state) when we must get rid of a connection.
-- We try to do it nicely but we are prepared to ignore any errors and to
-- simply drop the connection at the worst.
------------------------------------------------------------------------------
Ftp_Status : Ftp_Defs.Status_Code;
begin
----If the Connection isn't "open" (really means allocated) then we have nothing
-- to do.
if Effort_Only or else
not File_Transfer.Is_Open (Connection) then
return;
end if;
----If there is an actual connection then we must try to Quit out of it.
if File_Transfer.Is_Connected (Connection) then
begin
begin
File_Transfer.Send_Quit (Connection);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
----If the Quit fails then report that but also continue.
exception
when others =>
Log.Put_Line
("Unexpected exception during File_Transfer.Send_Quit:" &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Error_Msg,
Profile.Verbose);
end;
----Try to disconnect from the remote server.
File_Transfer.Disconnect (Connection);
exception
when others =>
Log.Put_Line
("Unexpected exception during File_Transfer.Disconnect:" &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Error_Msg,
Profile.Verbose);
end;
end if;
----Finally we close (deallocate) the socket.
File_Transfer.Close (Connection);
end Disconnect;
--\f
procedure Mkdir (Connection : File_Transfer.Connect_Id;
Local : String;
Remote : String) is
------------------------------------------------------------------------------
-- Conection - Specifies the connection to use
-- Local - Specifies the name of an existing local object
-- Remote - Specifies the name of a remote object to be created/written
-- Called to perform (and check) the creation of a remote directory.
------------------------------------------------------------------------------
Ftp_Status : Ftp_Defs.Status_Code;
begin
----Inform the log of the impending creation.
Log.Put_Line ("Create directory: " & Remote,
Profile.Note_Msg,
Profile.Verbose);
----Send the create directory command.
if not Effort_Only then
Files_Transferred := Files_Transferred + 1;
File_Transfer.Send_Verbatim (Connection, "XMKD " & Remote);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
end if;
end Mkdir;
--\f
procedure Store (Connection : File_Transfer.Connect_Id;
Local : String;
Remote : String) is
------------------------------------------------------------------------------
-- Conection - Specifies the connection to use
-- Local - Specifies the name of an existing local object
-- Remote - Specifies the name of a remote object to be created/written
-- Called to perform (and check) the transfer of one file from the R1000 to
-- the Unix_Machine host.
------------------------------------------------------------------------------
Ftp_Status : Ftp_Defs.Status_Code;
Bytes : Natural;
Dura : Duration;
begin
----Copy the Ascii data into a temporary file; Ada can be such a pain; take
-- care to preserve the look-and-feel of our data.
declare
use Text_Io;
Input : File_Type;
Output : File_Type;
Lno : Positive_Count := 1;
Pno : Positive_Count := 1;
Line : String (1 .. 256);
Length : Natural;
Eof : Boolean := False;
Eop : Boolean := False;
Eol : Boolean := False;
begin
----Open the input and output files.
if Effort_Only then
return;
end if;
Files_Transferred := Files_Transferred + 1;
Open (Input, In_File, Local);
begin
Temp_File_Used := True;
Open (Output, Out_File, Temp_File_Name);
exception
when others =>
Create (Output, Out_File, Temp_File_Name);
end;
----Read lines and put them out to the temporary file.
loop
----Try to fit a line into the space available.
if Eof then
if Length > 0 then
New_Line (Output); -- End file with a Lf.
end if;
exit;
end if;
Get_Line (Input, Line, Length);
Eof := Text_Io.End_Of_File (Input);
Eop := Eof or else Pno /= Page (Input);
Eol := Eop or else Length < Line'Length or else
Lno /= Text_Io.Line (Input);
----If we only got part of a line then put out that part. If we got a Ff then
-- append that and add a newline.
if Eol then
Put_Line (Output, Line (1 .. Length));
if Eop and not Eof then
New_Page (Output);
New_Line (Output);
Pno := Page (Input);
end if;
Lno := Text_Io.Line (Input);
else
Put (Output, Line (1 .. Length));
end if;
end loop;
----Close the files.
Close (Input);
Close (Output);
end;
----Inform the log of the impending transfer.
for I in reverse 1 .. 5 loop
Log.Put_Line ("Transfer: " & Local & " => " & Remote,
Profile.Note_Msg,
Profile.Verbose);
----Set up a new socket connection for the actual transfer.
File_Transfer.Send_Data_Port (Connection,
Transport_Defs.Null_Host_Id,
Transport_Defs.Null_Socket_Id);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
delay 1.0; -- Try a delay; we're getting stupid errors that
-- are probably timing related.
----Begin the transfer and wait for it to end.
File_Transfer.Start_Store (Connection,
Local_Filename => Temp_File_Name,
Remote_Filename => Remote,
Append => False);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
if Ftp_Status /= Ftp_Defs.Transfer_Complete then
Status_Ok (Ftp_Status);
end if;
----Inform the log of a successful transfer.
Bytes := File_Transfer.Last_Transfer_Length (Connection);
Dura := File_Transfer.Last_Transfer_Time (Connection);
Log.Put_Line
("Done, bytes: " &
Natural_Image (Bytes) & ", seconds: " &
Duration_Image (Dura),
Profile.Note_Msg,
Profile.Verbose);
if Bytes /= 0 then
exit;
elsif I = 1 then
Log.Put_Line
("Arghhh!!! 0 Bytes transferred in 0.0 seconds again!!!" &
" We Quit.", Profile.Error_Msg,
Profile.Verbose);
raise Quit;
end if;
Log.Put_Line
("Arghhh!!! 0 Bytes transferred in 0.0 seconds again!!!" &
" Trying one more time.",
Profile.Error_Msg,
Profile.Verbose);
delay 2.0;
end loop;
end Store;
--\f
procedure Tcp_Port_Numbers_Bug_Workaround is
----HP has a silly bug that we have to get-around.
-- Assign port numbers until port numbers reach at least 1024.
-- The R1000 assigns successive numbers starting at around 511.
-- HP and apparently some others cannot accept any number less
-- than 1024. Silly bug.
C : Transport.Connection_Id;
Status : Transport_Defs.Status_Code;
Done : Boolean := False;
begin
while not Done loop
Transport.Open (C, Status, "TCP/IP");
exit when Transport_Defs."/=" (Status, Transport_Defs.Ok);
declare
Port : constant Transport_Defs.Socket_Id :=
Transport.Local_Socket (C);
begin
Done := Byte_Defs.">=" (Port (Port'First), 4);
end;
Transport.Close (C);
end loop;
end Tcp_Port_Numbers_Bug_Workaround;
--\f
function Check_Object (Obj : Dt.Object.Handle;
Root : String) return Database_Entry is
------------------------------------------------------------------------------
-- Obj - Specifies the object to check
-- Root - Specifies the local root path
--
-- Does a Check_Database followed by an update of the object if that is
-- desirable.
------------------------------------------------------------------------------
Dbentry : Database_Entry;
begin
Dbentry := Check_Database (Obj, Root);
if Dbentry.Update and not Dbentry.Updated then
if Dbentry.Directory then
Mkdir (Connection,
Root & "." & Dbentry.Full_R1000_Name.all,
Dbentry.Unix_Path.all & Dbentry.Unix_Name.all);
else
Store (Connection,
Root & "." & Dbentry.Full_R1000_Name.all,
Dbentry.Unix_Path.all & Dbentry.Unix_Name.all);
end if;
if not Effort_Only then
Dbentry.Update := False;
Dbentry.Updated := True;
end if;
Log.Put_Line ("-----------------------------------------------",
Profile.Note_Msg,
Profile.Verbose);
end if;
return Dbentry;
exception
when Quit =>
----Mark his as "not done".
Dbentry.Version := new String (1 .. 0);
raise;
end Check_Object;
--\f
begin
if Unix_Machine /= "<SHIP_TO_MACHINE>" then
Host_Machine_Name := new String'(Unix_Machine);
else
declare
Env : String_Pointer :=
X_Env_Get_Environment_Variable ("SHIP_TO_MACHINE");
begin
if Env = null then
Log.Put_Line
("Unix_Machinge => <SHIP_TO_MACHINE> and environment variable SHIP_TO_MACHINE is not set. Use the Setenv command to set it.",
Profile.Error_Msg);
raise Library.Error;
else
Host_Machine_Name := new String'(Env.all);
end if;
end;
end if;
if Username /= "<SHIP_TO_USERNAME>" then
Host_User_Name := new String'(Username);
else
declare
Env : String_Pointer :=
X_Env_Get_Environment_Variable ("SHIP_TO_USERNAME");
begin
if Env = null then
Log.Put_Line
("Username => <SHIP_TO_USERNAME> and environment variable SHIP_TO_USERNAME is not set. Use the Setenv command to set it.",
Profile.Error_Msg);
raise Library.Error;
else
Host_User_Name := new String'(Env.all);
end if;
end;
end if;
declare
Td_Status : Transport_Defs.Status_Code;
Ftp_Status : Ftp_Defs.Status_Code;
Host_Id : constant Transport_Defs.Host_Id
:= Get_Host_Id (Host_Machine_Name.all);
Ascii_Mode : Boolean;
Local_Root : Dt.Object.Handle;
Local_Root_Name : String_Pointer;
Local_Files : Dt.Object.Iterator;
Dbentry : Database_Entry;
begin
----Say hello to the user; let him know we are alive.
Log.Put_Line ("[Ship_To_Unix("
& R1000_Files & ','
& R1000_Root & ','
& Unix_Root & ','
& Host_Machine_Name.all & ','
& Host_User_Name.all & ','
& Database_Name & ","
& "Force_Update => " & Boolean'Image (Force_Update) & ","
& "Effort_Only => " & Boolean'Image (Effort_Only) & ")]",
Profile.Auxiliary_Msg, Profile.Verbose);
----Make sure that the Host_Machine_Name host is known to the R1000.
if Host_Id'Length = 0 then
Log.Put_Line
("Host name [" & Host_Machine_Name.all &
"] is not in the Transport_Name_Map (Host name undefined).",
Profile.Error_Msg,
Profile.Verbose);
return;
end if;
----Resolve the various file names that we were given.
Local_Root := Dt.Naming.Resolution (R1000_Root);
if Dt.Object.Is_Bad (Local_Root) then
Log.Put_Line ("R1000_Root argument is bad. {" &
Dt.Object.Message (Local_Root) & '}',
Profile.Error_Msg,
Profile.Verbose);
return;
end if;
Local_Root_Name := Hs (Dt.Naming.Full_Name (Local_Root));
Local_Files := Dt.Naming.Resolution (R1000_Files);
if Dt.Object.Is_Bad (Local_Files) then
Log.Put_Line ("R1000_Files argument is bad. {" &
Dt.Object.Message (Local_Files) & '}',
Profile.Error_Msg,
Profile.Verbose);
return;
end if;
----Initialiaze our object map.
Obj_Db.Initialize (Database);
Read_Database (Database_Name);
----Try to get a socket for our use.
if not Effort_Only then
Log.Put_Line ("Get network socket.",
Profile.Note_Msg, Profile.Verbose);
Tcp_Port_Numbers_Bug_Workaround;
File_Transfer.Open (Connection, Td_Status);
Status_Ok (Td_Status);
----Try to call up the Host_Machine_Name.all and see if it will talk to us at
-- all.
Log.Put_Line ("Connect to " & Host_Machine_Name.all,
Profile.Note_Msg, Profile.Verbose);
File_Transfer.Connect (Connection, Host_Id);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
----Try to log in as the Username/Password that was given to us.
Log.Put_Line ("Send username.", Profile.Note_Msg, Profile.Verbose);
File_Transfer.Send_Username (Connection, Host_User_Name.all);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
if Ftp_Status = Ftp_Defs.Not_Logged_In then
Log.Put_Line ("Username " & Host_User_Name.all &
" invalid on workstation " &
Host_Machine_Name.all, Profile.Error_Msg,
Profile.Verbose);
raise Quit;
elsif Ftp_Status = Ftp_Defs.Need_Password then
Log.Put_Line ("Send password.", Profile.Note_Msg,
Profile.Verbose);
File_Transfer.Send_Password (Connection, Password);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
end if;
if Ftp_Status = Ftp_Defs.Not_Logged_In then
Log.Put_Line ("Password invalid for username " &
Host_User_Name.all & " on workstation " &
Host_Machine_Name.all, Profile.Error_Msg,
Profile.Verbose);
raise Quit;
end if;
Status_Ok (Ftp_Status);
-- ----Set the account for the logged-in job Host_Machine_Name.
--
-- if Account /= "" and then
-- Account /= " " then
-- Log.Put_Line ("Send account.", Profile.Note_Msg, Profile.Verbose);
-- File_Transfer.Send_Account (Connection, Account);
-- Response (Connection);
-- File_Transfer.Command_Status (Connection, Ftp_Status);
-- if Ftp_Status /= Ftp_Defs.Command_Not_Implemented then
-- Status_Ok (Ftp_Status);
-- end if;
-- end if;
--
----Connect to the Unix_Root directory.
Log.Put_Line ("Connect to " & Unix_Root,
Profile.Note_Msg, Profile.Verbose);
File_Transfer.Send_Cwd (Connection, Unix_Root);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
----We will be working in Stream mode, sending Ascii data, and working in
-- units of Files. These should work on all FTP implementations.
Log.Put_Line
("Set transfer modes (Stream,Image/Telnet/Ascii,File).",
Profile.Note_Msg, Profile.Verbose);
File_Transfer.Set_Mode (Connection, Ftp_Defs.Stream);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
Ascii_Mode := True;
File_Transfer.Set_Type (Connection, Ftp_Defs.Image);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
if Ftp_Status /= Ftp_Defs.Successful then
File_Transfer.Set_Type (Connection, Ftp_Defs.Ascii_Telnet);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
if Ftp_Status /= Ftp_Defs.Successful then
File_Transfer.Set_Type (Connection, Ftp_Defs.Ascii);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
end if;
end if;
Status_Ok (Ftp_Status);
File_Transfer.Set_Structure (Connection, Ftp_Defs.File);
Response (Connection);
File_Transfer.Command_Status (Connection, Ftp_Status);
Status_Ok (Ftp_Status);
end if;
----Send all of the various files.
-- if not Ascii_Mode then
-- Log.Put_Line ("Set transmission modes (Stream,Ascii,File).",
-- Profile.Note_Msg, Profile.Verbose);
-- Ascii_Mode := True;
-- File_Transfer.Set_Type (Connection, Ftp_Defs.Ascii);
-- Response (Connection);
-- File_Transfer.Command_Status (Connection, Ftp_Status);
-- Status_Ok (Ftp_Status);
-- end if;
while not Dt.Object.Done (Local_Files) loop
Dbentry := Check_Object
(Dt.Object.Value (Local_Files), Local_Root_Name.all);
Dt.Object.Next (Local_Files);
end loop;
----We are all done; say "bye", disconnect, and free up the socket.
Log.Put_Line ("Disconnect.", Profile.Note_Msg, Profile.Verbose);
Disconnect (Connection);
----Now write out the database.
Log.Put_Line ("Write database.", Profile.Note_Msg, Profile.Verbose);
Write_Database (Database_Name);
if Temp_File_Used then
Library.Delete (Temp_File_Name, Response => "<ERROR>");
end if;
----We are done.
Log.Put_Line ("Processed: " &
Integer'Image (Files_Processed) & " files.",
Profile.Note_Msg);
Log.Put_Line ("Deferred: " &
Integer'Image (Files_Deferred) & " files.",
Profile.Note_Msg);
Log.Put_Line ("Transferred:" &
Integer'Image (Files_Transferred) & " files.",
Profile.Note_Msg);
Log.Put_Line ("[end of Ship_To_Unix]",
Profile.Auxiliary_Msg,
Profile.Verbose);
exception
----When we Quit we simply disconnect; error messages have already gone out.
when Quit =>
if Force_Update then
Log.Put_Line ("Updating internal database.",
Profile.Note_Msg, Profile.Verbose);
while not Dt.Object.Done (Local_Files) loop
Dbentry := Check_Database (Dt.Object.Value (Local_Files),
Local_Root_Name.all);
Dbentry.Version := new String (1 .. 0);
Dt.Object.Next (Local_Files);
end loop;
end if;
Log.Put_Line ("Write database.", Profile.Note_Msg, Profile.Verbose);
Write_Database (Database_Name);
Disconnect (Connection);
raise Library.Error;
----Anything else is simply unexpected.
when others =>
Log.Put_Line ("Unexpected exception during Ship_To_Unix script:" &
Debug_Tools.Get_Exception_Name (True, True),
Profile.Error_Msg,
Profile.Verbose);
Disconnect (Connection);
end;
end Ship_To_Unix;