⟦8debcdb3f⟧

TextFile

with Default;
with Ftp;
with Put_Mailbox;
with What;
with Transport_Name;
with Ftp_Interface;
with Directory;
with System_Utilities;
with Time_Utilities;
with Unbounded_String;
with Simple_Status;
with System;
with Job_Segment;
with Message;
with Common;
with Object_Editor;
with Profile;
with Calendar;
with Ftp_Defs;
with Ftp_Profile;
with String_Utilities;
with Io;
with Queue;
with Polymorphic_Io;
with Directory_Tools;
with Debug_Tools;

procedure Network_Print (File : String := "<IMAGE>";
                         Two_Up : Boolean := True;
                         Border : Boolean := True;
                         Headers_Footers : Boolean := True;
                         Default_Class : Boolean := True;
                         One_Message_Per_Page : Boolean := False;
                         Options : String := "";
                         Trace_Only : Boolean := False) is

    package Su renames String_Utilities;
    package Dir renames Directory;
    package Naming renames Dir.Naming;

    Object : Dir.Object;
    Status : Naming.Name_Status;

    Machine_Name : constant String := Transport_Name.Local_Host_Name ("tcp/ip");

    Text_Special_Name : constant String := "<text>";
    T_Special_Name : constant String := "<t>";
    Image_Special_Name : constant String := "<image>";
    I_Special_Name : constant String := "<i>";
    Mailboxes_String : constant String := "Mailboxes: ";

    Error_Termination : exception;

    Is_Network_Name : Boolean;
    Left : Natural;
    Right : Natural;
    Length : Natural;

    Ftp_Channel : Ftp_Interface.Channel;

    procedure Copy_Messages_To_File (Mailbox_Image : String;
                                     File : String;
                                     One_Message_Per_Page : Boolean);

    package Unbounded is new Unbounded_String (30);

    Separator : constant String :=
       "--------------------------------------------------------------";

    function Find_Mailbox_Name (Image : String) return String;

    function Is_Image (X : String) return Boolean;

    function Is_Text (X : String) return Boolean;

    procedure Write_File (Name : String; Retries : Natural := 4);

    -- note: the following procedure is used to recover from lock errors
    -- that can sometimes occur creating files in !machine.temporary
    procedure Write_File (Name : String; Retries : Natural := 4) is
        File : Io.File_Type;
    begin
        Io.Create (File, Io.Out_File, Name);
        Io.Close (File);
        Common.Write_File (Name);
    exception
        when Io.Use_Error =>
            if Retries = 0 then
                What.Locks ("!machine.temporary");
                Io.Echo
                   ("NETWORK PRINT: Unable to print image because Use_Error raised attempting to create file in !Machine.Temporary.");
                raise Error_Termination;
            else
                delay 2.0;
                Write_File (Name, Retries - 1);
            end if;
    end Write_File;

    function Is_Image (X : String) return Boolean is
    begin
        return Su.Equal (X, Image_Special_Name) or else
                  Su.Equal (X, I_Special_Name);
    end Is_Image;

    function Is_Text (X : String) return Boolean is
    begin
        return Su.Equal (X, Text_Special_Name) or else
                  Su.Equal (X, T_Special_Name);
    end Is_Text;

    function Is_Main (Name : String) return Boolean is
    begin
        return String_Utilities.Equal (Name, String_Utilities.Upper_Case (Name),
                                       Ignore_Case => False);
    end Is_Main;

    function File_Contents (Name : String) return String is
        F : Io.File_Type;
        function Close_And_Return (S : String) return String is
        begin
            Io.Close (F);
            return S;
        end Close_And_Return;
    begin
        Io.Open (F, Io.In_File, Name);
        return Close_And_Return (Io.Get_Line (F));
    exception
        when others =>
            Io.Put_Line ("Unable to read class from file : " & Name &
                         " due to " & Debug_Tools.Get_Exception_Name);
            Io.Put_Line ("Check acls and file existence.");
            raise Error_Termination;
    end File_Contents;

    function Find_Mailbox_Name (Image : String) return String is
        Next_Blank : constant Natural := String_Utilities.Locate (" ", Image);
        Next_Lf : constant Natural := String_Utilities.Locate (Ascii.Lf, Image);
    begin
        if Image = "" or else Next_Lf = Image'First then
            -- its an empty image or there is no mailbox
            raise Program_Error;
        elsif Next_Blank = 0 and then Next_Lf /= 0 then
            -- its multiple lines with the first line containing no blanks
            if Is_Main (Image (Image'First .. Next_Lf - 1)) then
                return Image (Image'First .. Next_Lf - 1);
            else
                raise Program_Error;
            end if;
        elsif Next_Blank /= 0 then
            -- there is something else on the line beyond the next name
            if Is_Main (Image (Image'First .. Next_Blank - 1)) then
                return Image (Image'First .. Next_Blank - 1);
            else
                return Find_Mailbox_Name (Image (Next_Blank + 1 .. Image'Last));
            end if;
        else
            -- its a single line with no blanks
            if Is_Main (Image) then
                return Image;
            else
                raise Program_Error;
            end if;
        end if;
    end Find_Mailbox_Name;

    procedure Copy_Messages_To_File (Mailbox_Image : String;
                                     File : String;
                                     One_Message_Per_Page : Boolean) is
    begin
        Put_Mailbox (File, One_Message_Per_Page,
                     Find_Mailbox_Name (Mailbox_Image
                                           (Mailbox_Image'First +
                                            Mailboxes_String'Length ..
                                               Mailbox_Image'Last)));
    end Copy_Messages_To_File;

    procedure Xfer (From_Host : String; From_File : String; To_File : String) is

        Command_Status : Ftp_Defs.Status_Code;
        Transfer_Status : Ftp_Defs.Transfer_Status;

    begin

        if Ftp_Profile.Username /= "" and Ftp_Profile.Password /= "" then

            Ftp_Interface.Open (Chan => Ftp_Channel,
                                To_Machine => From_Host,
                                For_User => Ftp_Profile.Username,
                                With_Password => Ftp_Profile.Password,
                                Status => Command_Status,
                                Log_Responses => False);

        else

            Ftp_Interface.Open (Chan => Ftp_Channel,
                                To_Machine => From_Host,
                                For_User => Default.User_Name,
                                With_Password => Default.Password,
                                Status => Command_Status,
                                Log_Responses => False);
        end if;

        if not Ftp_Defs."=" (Ftp_Defs.Successful, Command_Status) then
            Io.Echo ("NETWORK PRINT: FTP open failed with status ");

            Io.Echo (Ftp_Defs.Status_Code'Image (Command_Status));

            raise Error_Termination;
        end if;

        Ftp_Interface.Transfer_File
           (Chan => Ftp_Channel,
            Direction => Ftp_Interface.Receive_From_Remote,
            Local_File_Name => To_File,
            Remote_File_Name => From_File,
            Status => Command_Status,
            Log_Responses => False);


        if not Ftp_Defs."=" (Ftp_Defs.Transfer_Complete, Command_Status) then
            Io.Echo ("NETWORK PRINT: FTP transfer failed with command status ");
            Io.Echo (Ftp_Defs.Status_Code'Image (Command_Status) &
                     " and transfer status ");

            Ftp_Interface.Get_Status (Chan => Ftp_Channel,
                                      Cmd_Status => Command_Status,
                                      Xfer_Status => Transfer_Status);

            Io.Echo (Ftp_Defs.Transfer_Status'Image (Transfer_Status));

            Ftp_Interface.Close (Chan => Ftp_Channel);
            raise Error_Termination;
        end if;

        Ftp_Interface.Close (Chan => Ftp_Channel);

    end Xfer;



    function Parse (Net_Filename : String) return Boolean is

    begin

        Length := Net_Filename'Length;

        Left := 1 + String_Utilities.Locate (Fragment => "!!",
                                             Within => Net_Filename,
                                             Ignore_Case => True);

        if Left > 1 then
            Right := String_Utilities.Locate
                        (Fragment => "!",
                         Within => Net_Filename (Left + 1 .. Length),
                         Ignore_Case => True);

            if Right > Left then
                return True;
            else
                return False;
            end if;

        else
            return False;
        end if;

    end Parse;


    function Join (A, B : String) return String is
    begin
        if B'Length = 0 then
            return A;
        elsif A'Length = 0 then
            return B;
        else
            return A & "," & B;
        end if;
    end Join;


    function Is_Ada (Name : String) return String is
        -- return format=>fancy if the first object is ada.
        Ada_Class : Directory.Class := Directory.Class_Value ("ada");
        Iter : Directory.Naming.Iterator;
        Name_Status : Directory.Naming.Name_Status;
        use Directory;
    begin
        Directory.Naming.Resolve (Iter, Name, Name_Status);
        if Directory.Naming.Done (Iter) then
            return "";
        end if;
        if Directory.Naming.Get_Class (Iter) = Ada_Class then
            return "format=>fancy";
        else
            return "";
        end if;  
    exception
        when others =>
            return "";
    end Is_Ada;

    function Machine_Is (Name : String) return Boolean is
    begin
        return Su.Equal (Machine_Name, Name);
    end Machine_Is;

    function Class_Name return String is
    begin
        if Machine_Is ("logo") then
            if Default_Class then
                return "mlaser";
            else
                return "!!rational!apple";
            end if;
        elsif Machine_Is ("rational") then
            if Default_Class then
                return "!!logo!mlaser";
            else
                return "apple";
            end if;
        elsif Machine_Is ("stan") then
            if Default_Class then
                return "apple";
            else
                return "!!logo!mlaser";
            end if;

        elsif Machine_Is ("ollie") or else Machine_Is ("gator") or else
              Machine_Is ("universe") then
            if Default_Class then
                return "!!logo!mlaser";
            else
                return "!!rational!apple";
            end if;
        else
            return File_Contents ("!machine.laser_class");
        end if;
    end Class_Name;

    function Headers_Footers_Options return String is
    begin
        if not Headers_Footers then
            return "number=false,filename=false,date=false";
        else
            return "";
        end if;
    end Headers_Footers_Options;

    function Get_Real_Name return String is
    begin
        if Is_Text (File) then
            return Object_Editor.Get_Text;
        else
            return File;
        end if;
    end Get_Real_Name;

    procedure Do_Print (Name : String; Options : String) is
    begin
        Io.Put_Line (Io.Current_Error, "Queue.Print ("""  
                                           & Name  
                                           & """, Options=>"""  
                                           & Options  
                                           & """);");
        if not Trace_Only then
            Queue.Print (Name => Name, Options => Options);
        end if;
    end Do_Print;

begin

    declare
        File_Name : constant String := Get_Real_Name;
        Temp : constant String :=
           "!machine.temporary." & System_Utilities.User_Name & "_" &
              Time_Utilities.Image (Time_Utilities.Get_Time,
                                    Time_Utilities.Ada, Time_Utilities.Ada);
    begin

        Is_Network_Name := Parse (File_Name);

        if Is_Network_Name then
            Xfer (From_Host => File_Name (Left + 1 .. Right - 1),
                  From_File => File_Name (Right .. Length),
                  To_File => Temp);
        end if;

        -- check to see if an image without an object and if so, copy to temp file for printing
        if not Is_Network_Name and then Is_Image (File_Name) then
            Object_Editor.Get_Object (Object, Status,
                                      Precision => Object_Editor.Image);
            if Naming."/=" (Status, Naming.Successful) then
                if Object_Editor.Name = "mail" then
                    declare
                        Image_String : constant String :=
                           Object_Editor.Get_Text
                              (Precision => Object_Editor.Image);
                    begin
                        if Image_String'Length >
                           Mailboxes_String'Length and then
                           String_Utilities.Equal
                              (Mailboxes_String,
                               Image_String
                                  (Image_String'First ..
                                      Image_String'First +
                                         Mailboxes_String'Length - 1)) then
                            -- its a mailbox image
                            Copy_Messages_To_File
                               (Mailbox_Image => Image_String,
                                File => Temp,
                                One_Message_Per_Page => One_Message_Per_Page);
                        else
                            -- its a mail message image
                            Write_File (Temp);
                        end if;
                    end;
                else
                    Write_File (Temp);
                end if;
                Is_Network_Name := True;
            else
                if Directory."/=" (Directory.Ada.Get_Class,
                                   Directory.Get_Class (Object)) and then
                   not (Directory."=" (Polymorphic_Io.Get_Class,
                                       Directory.Get_Class (Object)) and then
                        (Su.Equal (Directory.Subclass_Image
                                      (Directory.Get_Subclass (Object)), "text",
                                   Ignore_Case => True) or else
                         Su.Equal (Directory.Subclass_Image
                                      (Directory.Get_Subclass (Object)),
                                   "postscript",
                                   Ignore_Case => True))) and then
                   Directory."/=" (Directory.Control_Point.Get_Class,
                                   Directory.Get_Class (Object)) then
                    Write_File (Temp);
                    Is_Network_Name := True;
                end if;

            end if;
        end if;

        declare
            Opt : constant String :=  
               Join (Join ("class=>" & Class_Name & ", postscript=>(twoup=" &
                           Boolean'Image (Two_Up) &  
                           ",border=>" & Boolean'Image (Border),
                           Is_Ada (File_Name)),
                     Join (Headers_Footers_Options, Options) & ")");
        begin
            if Is_Network_Name then
                Do_Print (Temp, Opt);
            else
                Do_Print (File_Name, Opt);
            end if;
        end;

    exception
        when Error_Termination =>
            null;
    end;
end Network_Print;
DataMuseum.dk

Rational R1000/400 Tapes

⟦8debcdb3f⟧ TextFile

Derivation

TextFile
