Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/tools/vaxtape.src

Text File | 1988-05-03 | 24.8 KB | 844 lines

::::::::::
vax_tape.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : H. J. Clarke, A. F. Niessner, Jr.
-- Unit Name    : program Vax_Tape.Ada
-- Document     : ARL Internal Memorandum  87-176
-- Version      : 1.0
-- Release Date : October 3, 1987
-- Last Update  : October 3, 1987
--
-- (c)  Copyright 1986 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



With Text_Io;
With Current_Exception;
With Write_Vax_Tape_Support;


Procedure Vax_Tape is

   Label_Length      : Constant := 6;
   Max_Path_Length   : Constant := 256;
   Space             : Constant Character := ' ';
   Equal             : Constant Character := '=';
   Files_List_Name   : Constant String    := "Vax_Tape.Files";

   Subtype Label is String (1..Label_Length);

   Label_Line        : String (1..80) := (Others => Space);
   Last              : Natural;
   Path_Name         : String (1..Max_Path_Length) := (Others => space);
   Path_Name_Length  : Natural;
   Files_List        : Text_Io.File_Type;


   Function Upper_Case (Line : String) Return String is

      Subtype Lower_Case is Character Range 'a'..'z';

      Shift  : Integer := Character'Pos ('a') - Character'Pos ('A');
      Result : String (Line'Range) := Line;

   Begin  --  function Upper Case

      For i in Result'Range
      Loop
         If Result (i) in Lower_Case
         Then Result (i) := Character'Val
                           (Character'Pos (Result (i)) - Shift);
         End If;
      End Loop;
      Return Result;

   End Upper_Case;


   Function Extract_Label (Input : String) Return Label is

      Result : Label := (Others => Space);

   Begin  --  function Extract Label from an input string

      Extract_Loop:
      For i in Input'Range
      Loop
         If Input (i) = Equal
         Then For j in (i + 1)..Input'Last
              Loop
                 If Input (j) /= Space
                 Then For k in Result'Range
                      Loop
                         Exit Extract_Loop
                              When ((j - 1 + k) > Input'Last);
                         Result (k) := Input (j - 1 + k);
                      End Loop;
                      Exit Extract_Loop;
                 End If;
              End Loop;
         End If;
      End Loop Extract_Loop;

      Return Upper_Case (Result);

   End Extract_Label;


   Use Text_Io;
   Use Write_Vax_Tape_Support;

Begin -- Start of main program Vax Tape

   -- Open the file containing the list of files to be written
   -- to magnetic tape.

   Open (Files_List, In_File, Files_List_Name);

   -- Get the tape label

   Get_Line (Files_List, Label_Line, Last);

   -- Extract the names of the files to be written to tape.

   While not End_of_File (Files_List)
   Loop

      -- Read a file name with the full path

      Get_Line (Files_List, Path_Name, Path_Name_Length);

      -- Write the file to tape

      Declare
      Begin
         Write_File (Extract_Label (Label_Line (1..Last)),
                     Upper_Case (Path_Name (1..Path_Name_length)));

         Exception
            When File_Not_Found =>
               Put      ("File - ");
               Put      (Path_Name (1..Path_Name_Length));
               Put_Line (" - was NOT found.");

      End;

   End Loop;

   Close (Files_List);

   Exception
      When Others => New_Line (3);
                     Put (Current_Exception.Name);
                     New_Line (2);

End Vax_Tape;

Pragma Main;
::::::::::
write_vax_tape_support_sp.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : H. J. Clarke, A. F. Niessner, Jr.
-- Unit Name    : package Write_Vax_Tape_Support
-- Document     : ARL Internal Memorandum  87-176
-- Version      : 1.0
-- Release Date : October 3, 1987
-- Last Update  : October 3, 1987
--
-- (c)  Copyright 1986 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



Package Write_Vax_Tape_Support is

   File_Not_Found : Exception;

   Procedure Write_File (Tape_Label : In String;
                         Path_Name  : In String);

End Write_Vax_Tape_Support;
::::::::::
write_vax_tape_support_b.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : H. J. Clarke, A. F. Niessner, Jr.
-- Unit Name    : package Write_Vax_Tape_Support
-- Document     : ARL Internal Memorandum  87-176
-- Version      : 1.0
-- Release Date : October 3, 1987
-- Last Update  : November 10, 1987
--
-- (c)  Copyright 1986 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



With Text_Io;
With Calendar;
With Block_Tape_Write;


Package Body Write_Vax_Tape_Support is


   Space : Constant Character := ' ';
   Zero  : Constant Character := '0';

   Label_Block_Size : Constant := 80;
   Data_Block_Size  : Constant := 2048;
   Max_Record_Size  : Constant := 400;

   Subtype Label_Range is Positive Range 1..Label_Block_Size;
   Subtype Data_Range  is Positive Range 1..Data_Block_Size;

   Disk_File_Count  : Natural := 1;
   Blocks           : Natural := 0;

   Label_Line : String (Label_Range) := (Others => Space);

   Vol_Line   : String (Label_Range);
   Line_One   : String (Label_Range);
   Line_Two   : String (Label_Range);
   Line_Three : String (Label_Range);
   Line_Four  : String (Label_Range);


   Function Zero_Fill (Number : Natural;
                       Size   : Natural) Return String is

      Space : Constant Character := ' ';
      Zero  : Constant Character := '0';

      Result : String (1..Size);

      Package N_Io is new Text_Io.Integer_Io (Natural);

   Begin  --  function Zero Fill, replace spaces with zeros

      N_Io.Put (Result, Number);
      For i in Result'Range
      Loop
         If Result (i) = Space
         Then Result (i) := Zero;
         End If;
      End Loop;
      Return Result;

   End Zero_Fill;


   Procedure Set_Labels (Label : In String) is

      System_Code : Constant String := "DECFILE11A";

      Function Date_Number Return String is

         Use Calendar;

         Today      : Time         := Clock;
         This_Year  : Year_Number  := Year (Today);
         This_Month : Month_Number := Month (Today);
         This_Day   : Day_Number   := Day (Today);

         Days_Until : Array (Month_Number) of Integer
                    := (  0,  31,  59,  90, 120, 151,
                        181, 212, 243, 273, 304, 334);

         Result     : String (1..6) := (Others => ' ');

      Begin  --  function Date Number

         If ((This_Year mod 4) = 0) and (This_Month > 2)
         Then Days_Until (This_Month) := Days_Until (This_Month) + 1;
         End If;
         Result (2..3) := Zero_Fill (This_Year - 1900, 2);
         Result (4..6) := Zero_Fill (Days_Until (This_Month)
                                   + This_Day, 3);
         Return Result;

      End Date_Number;


   Begin  --  procedure Set Labels

   --  Set the Volume line

      If Disk_File_Count = 1
      Then Vol_Line := Label_Line;
           Vol_Line (1..10) := "VOL1" & Label;
           Vol_Line (80)    := '3';
      End If;

   --  Set the first line constants

      Line_One          := Label_Line;
      Line_One (4)      := '1';          -- Label number
      Line_One (22..27) := Label;        -- File set identifier
      Line_One (28..31) := "0001";       -- File section number
      Line_One (36..39) := "0001";       -- Generation number
      Line_One (40..41) := "00";         -- Generation version number
      Line_One (42..47) := Date_Number;  -- Creation date
      Line_One (48..53) := " 00000";     -- Experation date
      Line_one (54)     := Space;        -- Accessibility
      Line_One (55..60) := "000000";     -- Block count
      Line_One (61..(60 + System_Code'Length))
                        := System_Code;  -- System code

   --  Set the second line constants

      Line_Two          := Label_Line;
      Line_Two (4)      := '2';          -- Label number
      Line_Two (5)      := 'D';          -- Record format
      Line_Two (6..10)  := Zero_Fill (Data_Block_Size, 5);
      Line_Two (11..15) := Zero_Fill (Max_Record_Size, 5);
      Line_Two (51..52) := "00";         -- Buffer offset length

   --  Set the third line constants

      Line_Three          := Label_Line;
      Line_Three (4)      := '3';        -- Label number
      Line_Three (5..8)   := "0190";     -- Maximum record length, hex

      -- The rest are unknown and were taken from a Vax written tape

      Line_Three (9..68)  := (Others => Zero);
      Line_Three (10)     := '2';
      Line_Three (12)     := '2';
      Line_Three (24)     := '1';

   --  Set the fourth line constants

      Line_Four          := Label_Line;
      Line_Four (4)      := '4';         -- Label number

   End Set_Labels;


   Procedure Write_Header_File (File_Name : In String) is

      Header    : Constant String := "HDR";
      Remainder : Natural;

      Use Block_Tape_Write;

   Begin  --  procedure Write Header File

      Line_One   (1..3) := Header;
      Line_Two   (1..3) := Header;
      Line_Three (1..3) := Header;
      Line_Four  (1..3) := Header;
      If File_Name'Length > 17
      Then Line_One (5..21) := File_Name (File_Name'First
                            .. File_Name'First + 16);
           Remainder := File_Name'Length - 17;
           Line_Four (6..(5 + Remainder))
                   := File_Name ((File_Name'First + 17)
                               .. File_Name'Last);
           Line_Four (68..69) := Zero_Fill (Remainder, 2);
      Else Line_One (5..(4 + File_Name'Length)) := File_Name;
           Line_Four (68..69) := Zero_Fill (0, 2);
      End If;
      Line_One (32..35) := Zero_Fill (Disk_File_Count, 4);

      If Disk_File_Count = 1
      Then Write_Tape_File (Vol_Line & Line_One & Line_Two
                          & Line_Three & Line_Four, 5);
      Else Write_Tape_File (Line_One & Line_Two
                          & Line_Three & Line_Four, 4);
      End If;

   End Write_Header_File;


   Procedure Write_Data_File (Source : In Text_Io.File_Type;
                              Error  : Out Boolean) is

      Use Block_Tape_Write;
      Use Text_Io;

      Block      : String (1..Data_Block_Size) := (Others => Fill);
      Line       : String (1..Max_Record_Size);
      Last       : Natural;
      Size       : Natural;
      Last_Entry : Natural := 0;

   Begin  --  procedure Write Data File

      Error := False;
      Blocks := 0;
      Open_Tape;
      Read_Write_Loop:
      Declare
      Begin
         While not End_of_File (Source)
         Loop
            Get_Line (Source, Line, Last);
            Size := Last + 4;
            If Size > (Data_Block_Size - Last_Entry)
            Then Write_Tape (Block, 1, Data_Block_Size);
                 Blocks     := Blocks + 1;
                 Last_Entry := 0;
                 Block      := (Others => Fill);
            End If;
            Block ((Last_Entry + 1) .. (Last_Entry + Size))
                       := Zero_Fill (Size, 4) & Line (1..Last);
            Last_Entry := Last_Entry + Size;
         End Loop;

         Exception
            When End_Error => Error := True;

      End Read_Write_Loop;
      If Last_Entry > 0
      Then Write_Tape (Block, 1, Data_Block_Size);
           Blocks := Blocks + 1;
      End If;
      Close_Tape;

   End Write_Data_File;


   Procedure Write_EOF_File is

      EOF : Constant String := "EOF";

      Use Block_Tape_Write;

   Begin  --  procedure Write EOF File

      Line_One   (1..3) := EOF;
      Line_Two   (1..3) := EOF;
      Line_Three (1..3) := EOF;
      Line_Four  (1..3) := EOF;
      Line_One (55..60) := Zero_Fill (Blocks, 6);

      Write_Tape_File (Line_One & Line_Two & Line_Three & Line_Four, 4);

   End Write_EOF_File;



   Procedure Write_File (Tape_Label : In String;
                         Path_Name  : In String) is

      Use Text_Io;

      Source_File : Text_Io.File_Type;
      Error       : Boolean := False;


      Function Name (Path : String) Return String is

         Colon  : Constant Character := ':';
         Equal  : Constant Character := '=';
         Result : String (Path'Range) := Path;


         Function One_Period (x : String) Return String is

            Period     : Constant Character := '.';
            Underscore : Constant Character := '_';
            Result     : String (x'Range)   := x;
            Count      : Integer            := 0;

         Begin  --  function One Period  ie: Remove extra periods

            For i in reverse x'Range
            Loop
               If Result (i) = Period
               Then Count := Count + 1;
                    If Count > 1
                    Then Result (i) := Underscore;
                    End If;
               End If;
            End Loop;
            Return Result;

         End One_Period;

      Begin  --  function Name, extracts the file name from the path

         For i in reverse Path'Range
         Loop
            If (Result (i) = Colon) or (Result (i) = Equal)
            Then Return One_Period (Result ((i + 1)..Result'Last));
            End if;
         End Loop;
         Return Result;

      End Name;


   Begin  --  procedure Write File

      Open (Source_file, In_File, Path_Name);
      Set_Labels (Tape_Label);
      Write_Header_File (Name (Path_Name));
      Write_Data_File (Source_File, Error);
      Close (Source_File);
      Write_EOF_File;
      Disk_File_Count := Disk_File_Count + 1;
      If Error
      Then Put_Line ("      ****************************************");
           New_Line;
           Put ("There was an END_ERROR raised when copying the file:");
           New_Line;
           Put ("      ");
           Put_Line (Path_Name);
           New_Line;
           Put_Line ("      ****************************************");
      End If;

      Exception
         When Name_Error => Raise File_Not_Found;

   End Write_File;

End Write_Vax_Tape_Support;
::::::::::
block_tape_write_sp.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : H. J. Clarke, A. F. Niessner, Jr.
-- Unit Name    : package Block_Tape_Write
-- Document     : ARL Internal Memorandum  87-176
-- Version      : 1.0
-- Release Date : October 3, 1987
-- Last Update  : October 3, 1987
--
-- (c)  Copyright 1986 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



Package Block_Tape_Write is

   Fill : Constant Character := '^';

   Tape_File_Open_Error  : Exception;
   Tape_File_Write_Error : Exception;
   Tape_File_Close_Error : Exception;

Procedure Open_Tape;

Procedure Write_Tape (Data             : In String;
                      Number_of_Blocks : In Natural;
                      Block_Size       : In Positive := 2048);

Procedure Close_Tape;

Procedure Write_Tape_File (Data             : In String;
                           Number_of_Blocks : In Natural;
                           Block_Size       : In Positive := 80;
                           Fill_Character   : In Character := Fill);

End Block_Tape_Write;
::::::::::
block_tape_write_b.ada
::::::::::

---------------------------------------------------------------
--        *****************************************          --
--       ***   The Applied Research Laboratory   ***         --
--      ***                 of the                ***        --
--       ***    Pennsylvania State University    ***         --
--        *****************************************          --
---------------------------------------------------------------
--                                                           -*
-- Author       : H. J. Clarke, A. F. Niessner, Jr.
-- Unit Name    : package Block_Tape_Write
-- Document     : ARL Internal Memorandum  87-176
-- Version      : 1.0
-- Release Date : October 3, 1987
-- Last Update  : October 3, 1987
--
-- (c)  Copyright 1986 the Pennsylvania State University
--                                                           -*
---------------------------------------------------------------



With Sys_Calls;
With String_Conversion;
With Bit_Ops;
With Dyn;    -- Dynamic Strings package from the Ada Repository.
             -- Found in PD2:<Ada.Components> subdirectory.
             -- Named DSTR3.SRC

Package Body Block_Tape_Write is

   --  Define a constant to shift a word to the high order end of
   --  double word.

   Shift_High : Constant Integer := 2**16;

   --  The following variables are used to hold information
   --  defining the state of the tape write process.

   --  Channel Number is assigned by Gopen and is used by
   --  Wrb and Gclose.

   Channel_Number : Integer;

   --  Tape File Number gives the number of the number of the
   --  file being written on tape.  It is initialized to zero
   --  since that is the number of the first file on tape.  It
   --  is used by Open Tape and is incremented at the end of
   --  Close Tape.

   Tape_File_Number : Natural := 0;

   --  Block Number gives the number of the block to be written.
   --  It is set to zero by Open Tape when a tape file is opened.
   --  It is used by Write Tape and is incremented at the end
   --  of Write Tape.

   Block_Number : Natural := 0;

   Type System_Call_Packet is
      Record
         Double_Word_1 : Integer := 0;
         Double_Word_2 : Integer := 0;
         Double_Word_3 : Integer := 0;
         Double_Word_4 : Integer := 0;
      End Record;

   Packet         : System_Call_Packet;
   Packet_Address : Integer := Integer (Packet'Address);


Procedure Open_Tape is

   --  Control of the tape drive is provided by the following
   --  Data General variables as described in the Data General
   --  System Call Dictionary (AOS/VS and AOS/DVS)

   --  DG name   Hex   Decimal   Tape Density Mode
   --  ?opdl     800      2048     800 bpi.
   --  ?opdm    1000      4096    1600 bpi.
   --  ?opdh    2000      8192    6250 bpi.
   --  ?opam    1800      6144    Automatic Density Mode.

   --  For the DG installation at ARL, the Automatic mode was
   --  chosen so that ?opam is used.

   opam : Constant := 6144;

   Assign_Channel_Number : Integer := -1;

   Use Dyn;

   Tape_Unit  : Constant Dyn_String := D_String ("@mtb0:");

   Use String_Conversion;

   Tape_File         : Packed_String (1..80);
   Tape_File_Pointer : Integer
                     := Bit_Ops.Left_Shift
                        (Integer (Tape_File (1)'Address), 1);
   Use Sys_Calls;

   Error     : Error_Code;

Begin  --  procedure Open Tape

   Pack_String (Str (Tape_Unit
                     & Right (D_String (Tape_File_Number), 2))
                & Ascii.Nul, Tape_File);
   Packet := (opam * Shift_High, 0, 0, 0);

   Sys (Gopen, AC0   => Tape_File_Pointer,
               AC1   => Assign_Channel_Number,
               AC2   => Packet_Address,
               Error => Error);

   If Error /= ok
   Then Raise Tape_File_Open_Error;
   End If;

   Channel_Number := Packet.Double_Word_1 / Shift_High;
   Block_Number   := 0;

End Open_Tape;


Procedure Write_Tape (Data             : In String;
                      Number_of_Blocks : In Natural;
                      Block_Size       : In Positive := 2048) is

   Dummy      : Integer;
   Byte_Count : Integer;

   Use String_Conversion;

   Buffer : Packed_String (1 .. Block_Size * Number_of_Blocks / 2);

   Use Sys_Calls;

   Error : Error_Code;

Begin  -- procedure Write Tape

   Pack_String (Data, Buffer);
   Packet := (Number_of_Blocks * Shift_High,
              Integer (Buffer (1)'Address),
              Block_Number,
              Block_Size * Shift_High);

   --  Sys with independent input and output variables is used so
   --  that the Channel Number is not corrupted on return from
   --  the procedure.

   Sys (Wrb, In_AC0  => 0,
             In_AC1  => Channel_Number,
             In_AC2  => Packet_Address,
             Out_AC0 => Dummy,
             Out_AC1 => Byte_Count,
             Out_AC2 => Dummy,
             Error   => Error);

   If Error /= ok
   Then Raise Tape_File_Write_Error;
   End If;

   Block_Number := Block_Number + Number_of_Blocks;

End Write_Tape;


Procedure Close_Tape is

   Undefined : Integer := 0;

   Use Sys_Calls;

   Error : Error_Code;

Begin  --  procedure Close Tape

   Sys (Gclose, AC0   => Undefined,
                AC1   => Channel_Number,
                AC2   => Undefined,
                Error => Error);

   If Error /= ok
   Then Raise Tape_File_Close_Error;
   End If;

   Tape_File_Number := Tape_File_Number + 1;

End Close_Tape;


Procedure Write_Tape_File (Data             : In String;
                           Number_of_Blocks : In Natural;
                           Block_Size       : In Positive  := 80;
                           Fill_Character   : In Character := Fill) is

   Data_Length   : Natural := Data'Length;
   Buffer_Length : Natural := Number_of_Blocks * Block_Size;
   Buffer : String (1..Buffer_Length) := (Others => Fill_Character);

Begin  --  procedure Write Tape File

   If Data_Length > Buffer_Length
   Then Data_Length := Buffer_Length;
   End If;
   Buffer (1..Data_Length) := Data (1..Data_Length);
   Open_Tape;
   Write_Tape (Buffer, Number_of_Blocks, Block_Size);
   Close_Tape;

End Write_Tape_File;

End Block_Tape_Write;
::::::::::
vax_tape.cli
::::::::::
push
[!equal,%0/label=%, ]
   string DGTAPE
[!else]
   string %0/label=%
[!end]
[!equal,%1%, ]
   Write
   Write No file names were given
   Write
[!else]
   [!equal,([!filenames %1-%]),()]
      write
      write No files match %1-%
      write
   [!else]
      [!equal, [!filenames vax_tape.files], ]
      [!else] del vax_tape.files
      [!end]
      write/l=vax_tape.files Tape Label = [!string]
      write/l=vax_tape.files ([!filenames %1-%])
      comment *** the full path name to the vax_tape pr file
      comment *** should be included in the next line.
      x vax_tape
      write
      write The following files have been written to Tape
      write
      type vax_tape.files
      write
   [!end]
[!end]
pop
::::::::::
compile_vax_tape.cli
::::::::::

ada block_tape_write_sp.ada
ada block_tape_write_b.ada
ada write_vax_tape_support_sp.ada
ada write_vax_tape_support_b.ada
ada vax_tape.ada
adalink vax_tape


Double_Word_2 : Integer := 0;
         Double_Word_3 : Integer := 0;
         Double_Word