home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / TUR6_102.ZIP / ARCITLBR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-02-02  |  11.7 KB  |  296 lines
  1. PROGRAM Arcitlbr;
  2.  
  3. {------------------------------------------------------------------------------
  4.      PROGRAM ARCITLBR 1.00A                                  02/01/86
  5.      BY  Karson W. Morrison  Caleb Computing Center
  6.          RD1 Box 531 Ringoes NJ 08551
  7.          201-788-1846
  8.  
  9.      This program is executed as part of the ARCIT.BAT when a library file
  10.      is squeezed.  i.e. *.lqr.  The program, amd batch file as originally
  11.      issued worked fine except when there was a numeric number as part of
  12.      the library name and the basic program went into the wild blue yonder.
  13.      This program uses the ability of Turbo pascal to execute other programs.
  14.  
  15.      I execute program LU a XXXXXX.LBR
  16.      Then I execute program DEL XXXXXX.LBR
  17.  
  18.      When this program is compiled you must make the maxavailable memory
  19.      to 0400, or the program will not run.  This is done in the options
  20.      section of TURBO PASCAL.
  21. ------------------------------------------------------------------------------}
  22. {$I-,U-,C-}
  23.  
  24.  
  25.  
  26. Type
  27.   Str66=String[66];
  28.   Str255=String[255];
  29.       registers = record           { register pack used in MSDos call }
  30.                     ax, bx, cx, dx, bp, si, di, ds, es, flags : integer;
  31.                   end;
  32.       char80arr = array [ 1..80 ] of char;
  33.       string80 = string[ 80 ];
  34.  
  35.  
  36.    VAR                              { VARIABLE declarations }
  37.       DTA : array [ 1..43 ] of byte;       { Data Transfer Area buffer }
  38.       DTAseg,                              { DTA segment before exicution }
  39.       DTAofs,                              { DTA offset    "        "     }
  40.       setDTAseg,                           { DTA segment and offset set after }
  41.       setDTAofs,                           { start of program }
  42.       error,                               { error return }
  43.       i, j,                                { used as counters }
  44.       option : integer;                    { used to specify file types }
  45.       regs : registers;                    { register pack for the DOS call }
  46.       FilVar : text;
  47.       space : integer;
  48.       buffer,                              { generic buffer }
  49.       namr : string80;                     { file name }
  50.       mask : char80arr;                    { file mask }
  51.  
  52.       Command: Str255;
  53.  
  54.  
  55. Function SubProcess(CommandLine: Str255): Integer;
  56.  
  57.   Const
  58.     SSSave: Integer=0;
  59.     SPSave: Integer=0;
  60.  
  61.   Var
  62.     Regs: Record Case Integer Of
  63.             1: (AX,BX,CX,DX,BP,SI,DI,DS,ES,Flags: Integer);
  64.             2: (AL,AH,BL,BH,CL,CH,DL,DH: Byte);
  65.           End;
  66.     FCB1,FCB2: Array [0..36] Of Byte;
  67.     PathName: Str66;
  68.     CommandTail: Str255;
  69.     ParmTable: Record
  70.                  EnvSeg: Integer;
  71.                  ComLin: ^Integer;
  72.                  FCB1Pr: ^Integer;
  73.                  FCB2Pr: ^Integer;
  74.                End;
  75.     I,RegsFlags: Integer;
  76.  
  77.   Begin
  78.     If Pos(' ',CommandLine)=0 Then
  79.      Begin
  80.       PathName:=CommandLine+#0;
  81.       CommandTail:=^M;
  82.      End
  83.     Else
  84.      Begin
  85.       PathName:=Copy(CommandLine,1,Pos(' ',CommandLine)-1)+#0;
  86.       CommandTail:=Copy(CommandLine,Pos(' ',CommandLine),255)+^M;
  87.      End;
  88.     CommandTail[0]:=Pred(CommandTail[0]);
  89.     With Regs Do
  90.      Begin
  91.       FillChar(FCB1,Sizeof(FCB1),0);
  92.       AX:=$2901;
  93.       DS:=Seg(CommandTail[1]);
  94.       SI:=Ofs(CommandTail[1]);
  95.       ES:=Seg(FCB1);
  96.       DI:=Ofs(FCB1);
  97.       MsDos(Regs); { Create FCB 1 }
  98.       FillChar(FCB2,Sizeof(FCB2),0);
  99.       AX:=$2901;
  100.       ES:=Seg(FCB2);
  101.       DI:=Ofs(FCB2);
  102.       MsDos(Regs); { Create FCB 2 }
  103.       ES:=CSeg;
  104.       BX:=SSeg-CSeg+MemW[CSeg:MemW[CSeg:$0101]+$112];
  105.       AH:=$4A;
  106.       MsDos(Regs); { Deallocate unused memory }
  107.       With ParmTable Do
  108.        Begin
  109.         EnvSeg:=MemW[CSeg:$002C];
  110.         ComLin:=Addr(CommandTail);
  111.         FCB1Pr:=Addr(FCB1);
  112.         FCB2Pr:=Addr(FCB2);
  113.        End;
  114.       InLine($8D/$96/ PathName /$42/  { <DX>:=Ofs(PathName[1]); }
  115.              $8D/$9E/ ParmTable /     { <BX>:=Ofs(ParmTable);   }
  116.              $B8/$00/$4B/             { <AX>:=$4B00;            }
  117.              $1E/$55/                 { Save <DS>, <BP>         }
  118.              $16/$1F/                 { <DS>:=Seg(PathName[1]); }
  119.              $16/$07/                 { <ES>:=Seg(ParmTable);   }
  120.              $2E/$8C/$16/ SSSave /    { Save <SS> in SSSave     }
  121.              $2E/$89/$26/ SPSave /    { Save <SP> in SPSave     }
  122.              $FA/                     { Disable interrupts      }
  123.              $CD/$21/                 { Call MS-DOS             }
  124.              $FA/                     { Disable interrupts      }
  125.              $2E/$8B/$26/ SPSave /    { Restore <SP>            }
  126.              $2E/$8E/$16/ SSSave /    { Restore <SS>            }
  127.              $FB/                     { Enable interrupts       }
  128.              $5D/$1F/                 { Restore <BP>,<DS>       }
  129.              $9C/$8F/$86/ RegsFlags / { Flags:=<CPU flags>      }
  130.              $89/$86/ Regs );         { Regs.AX:=<AX>;          }
  131.       If (RegsFlags And 1)<>0 Then SubProcess:=AX
  132.       Else SubProcess:=0;
  133.      End;
  134.   End;
  135.  
  136. Function GetComSpec: Str66;
  137.   Type
  138.     Env=Array [0..32767] Of Char;
  139.   Var
  140.     EPtr: ^Env;
  141.     EStr: Str255;
  142.     Done: Boolean;
  143.     I: Integer;
  144.  
  145.   Begin
  146.     EPtr:=Ptr(MemW[CSeg:$002C],0);
  147.     I:=0;
  148.     Done:=False;
  149.     EStr:='';
  150.     Repeat
  151.       If EPtr^[I]=#0 Then
  152.        Begin
  153.         If EPtr^[I+1]=#0 Then Done:=True;
  154.         If Copy(EStr,1,8)='COMSPEC=' Then
  155.          Begin
  156.           GetComSpec:=Copy(EStr,9,100);
  157.           Done:=True;
  158.          End;
  159.         EStr:='';
  160.        End
  161.       Else EStr:=EStr+EPtr^[I];
  162.       I:=I+1;
  163.     Until Done;
  164.   End;
  165.  
  166. {------------------------------------------------------------------------------
  167.      SetDTA resets the current DTA to the new address specified in the
  168. parameters 'SEGMENT' and 'OFFSET'.
  169. ------------------------------------------------------------------------------}
  170.  
  171.    PROCEDURE SetDTA( segment, offset : integer; var error : integer );
  172.  
  173.       BEGIN
  174.          regs.ax := $1A00;         { Function used to set the DTA }
  175.          regs.ds := segment;       { store the parameter segment in DS }
  176.          regs.dx := offset;        {   "    "      "     offset in DX }
  177.          MSDos( regs );            { Set DTA location }
  178.          error := regs.ax and $FF; { get error return }
  179.       END;
  180.  
  181. {------------------------------------------------------------------------------
  182.      GetCurrentDTA is used to get the current Disk Transfer Area ( DTA )
  183. address.  A function code of $2F is stored in the high byte of the AX
  184. register and a call to the predefined procedure MSDos is made.  This can
  185. also be accomplished by using the "Intr" procedure with the same register
  186. record and a $21 specification for the interrupt.
  187. ------------------------------------------------------------------------------}
  188.  
  189.    PROCEDURE GetCurrentDTA( var segment, offset : integer;
  190.                             var error : integer );
  191.  
  192.       BEGIN
  193.          regs.ax := $2F00;    { Function used to get current DTA address }
  194.                               { $2F00 is used instead of $2F shl 8 to save
  195.                                 three assembly instructions.  An idea for
  196.                                 optimization. }
  197.          MSDos( regs );       { Exicute MSDos function request }
  198.          segment := regs.es;  { Segment of DTA returned by DOS }
  199.          offset := regs.bx;   { Offset of DTA returned }
  200.          error := regs.ax and $FF;
  201.       END;
  202.  
  203. {------------------------------------------------------------------------------
  204.      GetFirst gets the first directory entry of a particular file mask.  The
  205. mask is passed as a parameter 'mask' and,  the option was previosly specified
  206. in the SpecifyOption procedure.
  207. ------------------------------------------------------------------------------}
  208.  
  209.    PROCEDURE GetFirst( mask : char80arr; var namr : string80;
  210.                        segment, offset : integer; option : integer;
  211.                        var error : integer );
  212.  
  213.       VAR
  214.          i : integer;
  215.  
  216.       BEGIN
  217.          error := 0;
  218.          regs.ax := $4E00;          { Get first directory entry }
  219.          regs.ds := seg( mask );    { Point to the file mask }
  220.          regs.dx := ofs( mask );
  221.          regs.cx := option;         { Store the option }
  222.          MSDos( regs );             { Exicute MSDos call }
  223.          error := regs.ax and $FF;  { Get error return }
  224.          i := 1;                    { initialize 'i' to the first element }
  225.          Repeat                     { Enter the loop that reads in the }
  226.                                     { first file entry }
  227.             namr[ i ] := chr( mem[ segment : offset + 29 + i ] );
  228.             i := i + 1;
  229.          Until ( not ( namr[ i - 1 ] in [ ' '..'~' ] ));
  230.          namr[ 0 ] := chr( i - 1 );  { set string length because assigning }
  231.                                      { by element does not set length }
  232.       END;
  233.  
  234.  
  235.  
  236.    BEGIN            { Begin Main Program }
  237.       For i := 1 to 21 Do DTA[ i ] := 0;  { Initialize the DTA buffer }
  238.       For i := 1 to 80 Do                 { Initialize the mask and }
  239.          Begin                            { file name buffers }
  240.             mask[ i ] := chr( 0 );
  241.             namr[ i ] := chr( 0 );
  242.          End;
  243.       namr[ 0 ] := chr( 0 );              { Set the file name length to 0 }
  244.       Option := 1;
  245.       writeln( 'ARCIT Un-LBR version 1.00A           2-1-1986' );
  246.       writeln('         Written by Karson W. Morrison Caleb Computing Company');
  247.       Writeln('         Rd 1 Box 531 Ringoes NJ. 08551           201-788-1846');
  248.       error := 0;
  249.       buffer[ 0 ] := chr( 0 );                      { Set buffer length to 0 }
  250.       buffer := '????????.LBR';                  { then use global search }
  251.       For i := 1 to length( buffer ) Do       { Assign buffer to mask }
  252.          mask[ i ] := buffer[ i ];
  253.       While ( error = 0 ) Do
  254.          Begin
  255.             GetCurrentDTA( DTAseg, DTAofs, error );  { Get the current DTA address }
  256.             If ( error <> 0 ) then                        { Check for errors }
  257.             Begin                                      { If yes then inform user }
  258.                writeln( 'Unable to get current DTA' );
  259.                writeln( 'Program aborting.' );         { and abort. }
  260.                Halt;                                   { End program now }
  261.             End;
  262.             setDTAseg := seg( DTA );
  263.             setDTAofs := ofs( DTA );
  264.             SetDTA( setDTAseg, setDTAofs, error );        { Reset DTA addresses }
  265.             If ( error <> 0 ) then
  266.             Begin                                      { Check for errors }
  267.                writeln( 'Cannot reset DTA' );          { Error message }
  268.                writeln( 'Program aborting.' );
  269.                Halt;                                   { End program }
  270.             End;
  271.  
  272. { Normally you would do one GetFirst and the rest would be GetNext
  273.   however because I am executing other programs the DTA is getting screwed
  274.   up so I use GetFirst all the time.  I am also deleting the file that
  275.   I found the first time so I don't read it again. }
  276.  
  277.             GetFirst( mask, namr, setDTAseg, setDTAofs, option, error );
  278.             If ( error = 0 ) then
  279.             Begin
  280.                for i := 1 to 9 do
  281.                begin
  282.                   space := pos(' ',namr);
  283.                   if space > 0 then
  284.                   delete(namr,space,1);
  285.                end;
  286.                Command:=GetComSpec+' /C '+'LU A ' + namr;
  287.                I:=SubProcess(Command);
  288.                If I<>0 Then WriteLn('Error - ',I);
  289.                Command:=GetComSpec+' /C '+ 'DEL ' + namr;
  290.                I:=SubProcess(Command);
  291.                If I<>0 Then WriteLn('Error - ',I);
  292.                error := 0;
  293.             end;
  294.          End;
  295.    END. { End Main }
  296.