Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ADC_TP3.ZIP/BUILD.PAS

Pascal/Delphi Source File | 1987-03-01 | 15.8 KB | 499 lines

{ This program is hereby placed in the public domain and may be freely copied
  and distributed as long as the author is given due credit.  Comments,
  suggestions and patches are more then welcome. Forward to me on CompuServe
  or Delphi and I will see that they are incorporated with credit due.

12-26-85 Version 1.00
12-30-85 Extract Procedure Replaced by breaking Dos file into seperate
         components when they are extracted from the Buffer Version 1.05   }


program Batch_File_Builder ( input, output );

{$C-,U-,V-,R-}

const
  Version       = '1.05';
  Max_Path      = 63;       { Maximum Characters in any DOS path }
  Max_Lines     = 10;       { Maximum Batch file Lines }
  Register      : record    { MsDos and Bios function calls }
                    case integer of
                      1 : ( AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer );
                      2 : ( AL, AH, BL, BH, CL, CH, DL, DH            : Byte    );
                    end = ( AX : 0 );


type
  String3       = String[  3 ];
  String8       = String[  8 ];
  String12      = String[ 12 ];
  String80      = String[ 80 ];
  Buffer        = array[ 1..128 ] of byte;            { Disk Transfer Area }
  Sort_Type     = (  N, E, NE, EN );                  { Name, Extension }
  Dos_File_Type = String[ Max_Path ];                 { All Dos Files   }
  Batch_Lines   = array[ 1.. Max_Lines ] of String80; { Batch Line Storage }
  Entry         = record
                    Name : String8;
                    Ext  : String3;
                  end;
  Link          = ^Node;                              { Dynamic Heap Structure }
  Node          = record
                    Dos_File : Entry;
                    Process  : Boolean;             { Used if Negate active }
                    Left     : Link;                { Left and Right Node Pointers }
                    Right    : Link;
                  end;


var
  Batch_Spec    : Dos_File_Type;      { Batch File Name to Create }
  File_Spec     : Dos_File_Type;      { Files to qualify or not qualify }
  Mask          : String12;           { Used if Negate active }
  File_Var      : Text;               { Batch File handle }
  DTA           : Buffer;             { Disk Transfer Area }
  Sort_On       : Sort_Type;          { What order to Sort by }
  Reverse       : Boolean;            { Ascending or Descending Sort }
  Negate        : Boolean;            { Negate on or off }
  Line          : Batch_Lines;        { Batch file lines }
  Num_Lines     : byte;               { Total of batch lines }
  Index         : byte;               { General String Index }
  Dir_File      : Entry;              { File as returned by DOS }
  Binary_Tree   : Link;               { Tree of File Names }
  Now_Tree      : Link;               { Temporary Holding Pointer }
  File_Count    : integer;            { Count of files to Process }
  Back_Color    : byte;               { Color variables for Mono and Color }
  Hi_Fore_Color : byte;
  Lo_Fore_Color : byte;
  Message_Color : byte;



  procedure Set_Border( Color : byte);   { Bios Video Call to set Border Color }
  begin
    Register.AH := 11;                   { Set Color Palette }
    Register.BH :=  0;
    Register.BL :=  Color;
    Intr( $10, Register );
  end; { procedure Set_Border }



  function Video_Mode : byte;         { Bios Video Call to determine Monitor }
  begin                               { Commercial Programmers take note this }
    Register.AH := 15;                { call really eats up a lot of code,    }
    Intr( $10, Register );            { slows execution down, and frustrates  }
    Video_Mode := Register.AL;        { users by not asking for Monitor type  }
  end; { function Video_Mode }


  procedure Set_DTA;                  { Set the Disk Transfer Area }
  begin                               { This call could be eliminated as DOS  }
    File_Spec   := File_Spec + #00;   { defaults a DTA at offset $80 into the }
    Register.AH := $1A;               { Program Segment Prefix. However program }
    Register.DS := Seg( DTA );        { will not run in Turbo Enviorment }
    Register.DX := Ofs( DTA );
    MsDos( Register );                            { Set DTA Location }
  end; { procedure Set_DTA; }


  procedure Get_First;                { Get the first matching file }
  begin
    Register.AH := $4E;
    Register.DS :=       Seg( File_Spec );
    Register.DX := succ( Ofs( File_Spec )) ;
    Register.CX := 32;
    MsDos( Register );
  end; { procedure Get_First; }



  procedure Decode_Buffer;            { Extract the file name from the DTA }

  var
    Dot : boolean;

  begin
    Dir_File.Name := '';
    Dir_File.Ext  := '';
    Index := 31;
    Dot   := FALSE;
    while ( DTA[ Index ] <> 0 ) do
      with Dir_File do
        begin
          Dot := Dot or ( DTA[ Index ] = ord( '.' ));
          if Not Dot then
            Name := Name + chr( DTA[ Index ] )
          else
            if DTA[ Index ] <> ord( '.' ) then
              Ext := Ext + chr( DTA[ Index ] );
          Index := succ( Index );
        end;
  end; { procedure Decode_Buffer; }




  function Less( File1, File2 : Entry ) : boolean;
  begin
    case Reverse of
      FALSE : case Sort_On of
                 N : Less :=    File1.Name < File2.Name;
                 E : Less :=    File1.Ext  < File2.Ext;
                NE : Less :=  ( File1.Name < File2.Name ) or
                             (( File1.Name = File2.Name ) and
                              ( File1.Ext  < File2.Ext  ));
                EN : Less :=  ( File1.Ext  < File2.Ext  ) or
                             (( File1.Ext  = File2.Ext  ) and
                              ( File1.Name < File2.Name ));
              end;
      TRUE  : case Sort_On of
                 N : Less :=    File1.Name > File2.Name;
                 E : Less :=    File1.Ext  > File2.Ext;
                NE : Less :=  ( File1.Name > File2.Name ) or
                             (( File1.Name = File2.Name ) and
                              ( File1.Ext  > File2.Ext  ));
                EN : Less :=  ( File1.Ext  > File2.Ext  ) or
                             (( File1.Ext  = File2.Ext  ) and
                              ( File1.Name > File2.Name ));
              end;
    end;
  end; { function Less }




  procedure Insert( var Tree : Link; New_File : Entry );
  begin
    if Tree = Nil then
      begin
        New( Tree );
        with Tree^ do
          begin
            Left     := Nil;            { Either a new Tree or a new node }
            Right    := Nil;
            Dos_File := New_File;
            Process  := TRUE;
          end
      end
    else
      with Tree^ do                         { Recursive call to find the right }
        if Less( New_File, Dos_File ) then  { spot on the tree }
          Insert( Left, New_File )
        else
          Insert( Right, New_File );
  end; { procedure Insert }



  function Find( Tree : Link; This_File : Entry ) : Link;
  begin
    if Tree = Nil then
      Find := Nil
    else
      with Tree^ do
        if ( This_File.Name = Dos_File.Name) and
           ( This_File.Ext  = Dos_File.Ext ) then
          Find := Tree                            { We found it or }
        else
          if Less( This_File, Dos_File ) then     { we need to look further }
            Find := Find( Left, This_File )
          else
            Find := Find( Right, This_File );
  end; { function Find }



  procedure Print_Tree( Tree : Link );

  var
    I : byte;

  begin
    if Tree <> Nil then
      with Tree^ do
        begin
          Print_Tree( Left );
          if Tree^.Process then
            begin                                  { Batch file lines are }
              for Index := 1 to Num_Lines do       { created here }
                begin
                  for I := 1 to length( Line[ Index ] ) do
                    if Line[ Index ][ I ] <> '!' then
                      write( File_Var, Line[ Index ][ I ] )
                    else
                      write( File_Var, Tree^.Dos_File.Name, '.', Tree^.Dos_File.Ext );
                  writeln( File_Var );
                  write( '.' );
                end;
            end;
          Print_Tree( Right );
        end;
  end; { procedure Print_Tree }



  procedure Build_Batch;
  begin
    write( 'Creating Batch File ' );   { Batch file is opened and closed here }
    assign( File_Var, Batch_Spec );
    rewrite( File_Var );
    writeln( File_Var, 'ECHO OFF' );
    writeln( File_Var, 'CLS' );
    writeln( File_Var, 'ECHO Batch File Builder  Version ', Version );
    Print_Tree( Binary_Tree );
    close( File_Var );
    writeln( ' Finished.' );
  end; { procedure Build_Batch; }



  procedure Build_Tree;
  begin
    write( 'Building Tree ' );
    Set_DTA;
    Get_First;
    while Register.AX = 0 do                { Are there still more files? }
      begin
        Decode_Buffer;
        Insert( Binary_Tree, Dir_File );
        write( '.' );                       { User friendly }
        File_Count := succ( File_Count );
        Register.AH := $4F;                 { Dos call for next match }
        MsDos( Register );
      end;
    if Negate then
      begin
        writeln;
        write( 'Searching Tree ' );
        Delete( File_Spec, pos( '*.*', File_Spec ), 4 );
        File_Spec := File_Spec + Mask;
        Set_DTA;
        Get_First;
        while Register.AX = 0 do            { If the user opted to negate   }
          begin                             { we first build a tree for *.* }
            Decode_Buffer;                  { and then for the users mask   }
            Now_Tree := Find( Binary_Tree, Dir_File );
            Now_Tree^.Process := FALSE;     { we then search the tree for the }
            write( '.' );                   { file and flag it as no process }
            File_Count := pred( File_Count );
            Register.AH := $4F;
            MsDos( Register );
          end;
      end;
    writeln;
  end; { procedure Build_Tree; }




  procedure Get_User_Info;

  const
    Yes_No   : set of char = [ 'Y', 'y', 'N', 'n' ];
    Yes      : set of char = [ 'Y', 'y' ];

  type
    Char_Set = set of Char;

  var
    C        : char;


    function Get_Key( Prompt : String80; Valid : Char_Set ) : char;
    begin
      TextColor( Lo_Fore_Color );
      repeat
        write( #13, Prompt + '-'#16' ':20 );
        read ( kbd, C );
      until C in Valid;
      TextColor( Hi_Fore_Color );
      writeln( C );
      Get_Key := C;
    end; { function Get_Key }


    procedure Get_Batch_Spec;

    var
      Temp_File : File;

      function Exist( File_Name : Dos_File_Type ) : boolean;
      begin
        assign( Temp_File, File_Name );      { Guess what this does and }
        {$I-} reset( Temp_File ); {$I+}      { where it came from }
        Exist := IOResult = 0;
        Close( Temp_File );
      end; { function Exist }


      function Validate( File_Name : Dos_File_Type ) : boolean;

      var
        Dummy : boolean;

      begin
        if Exist( File_Name ) then
          Validate := TRUE
        else
          begin
            assign( Temp_File, File_Name );      { This procedure validates     }
            {$I-} rewrite( Temp_File );  {$I+}   { the drive path and file name }
            Validate := IOResult = 0;            { but not wild cards. Dos }
            {$I-} Erase( Temp_File );    {$I+}   { calls validate wild cards }
            Dummy := IOResult = 0;               { with Register.AX returns. }
            Close( Temp_File );
          end;
      end; { function Validate }


    begin
      while not Validate( Batch_Spec ) do
        begin
          gotoxy( 1, WhereY );
          ClrEol;
          TextColor( Lo_Fore_Color );
          write( 'Batch File Name -'#16' ':20 );
          TextColor( Hi_Fore_Color );
          read( Batch_Spec );
        end;
      writeln;
    end;  { procedure Get_Batch_Spec; }


    procedure Get_File_Spec;
    begin
      Register.AX := 99;
      while Register.AX <> 0 do
        begin
          gotoxy( 1, WhereY );
          ClrEol;
          TextColor( Lo_Fore_Color );
          write( 'File Spec -'#16' ':20 );
          TextColor( Hi_Fore_Color );
          read( File_Spec );
          Set_DTA;
          Get_First;
        end;
      writeln;
    end; { procedure Get_File_Spec; }


    procedure Get_Sort;
    begin
      TextColor( Lo_Fore_Color );
      write( 'Sort Orders -'#16' ' :20 );
      TextColor( Message_Color );
      writeln( '1. Name              '    );
      writeln( '2. Extension         ':41 );
      writeln( '3. Name and Extension':41 );
      writeln( '4. Extension and Name':41 );
      case Get_Key( 'Sort Order ', [ '1'..'4' ] ) of
        '1' : Sort_On := N;
        '2' : Sort_On := E;
        '3' : Sort_On := NE;
        '4' : Sort_On := EN;
      end;
      Reverse := Get_Key( 'Reverse Sort ', Yes_No ) in Yes;
    end; { procedure Get_Sort; }


    procedure Get_Negate;
    begin
      Negate := Get_Key( 'Negate Mask ',  Yes_No ) in Yes;
      if Negate then   { If negate we strip off user mask and change to *.* }
        begin          { later we will change back }
          Index := length( File_Spec );
          while not ( File_Spec[ Index ] in [ '\', ':' ] ) and ( Index > 1 ) do
            Index := pred( Index );
          if File_Spec[ Index ] in [ '\', ':' ] then
            Index := succ( Index );
          Mask := copy( File_Spec, Index, length( File_Spec ) - Index );
          Delete( File_Spec, Index, length( File_Spec ) - pred( Index ) );
          File_Spec := File_Spec + '*.*';
        end;
    end; { procedure Get_Negate; }



    procedure Get_Batch_Lines;

    var
      More : boolean;

    begin
      writeln;
      writeln;
      TextColor( Message_Color );
      writeln( 'Enter Batch Files Lines.  Use ''!'' for file name substitution symbol.' );
      writeln;
      Index := 1;
      More  := TRUE;
      while More do
        begin
          TextColor( Lo_Fore_Color );
          write( '-'#16' ' );
          TextColor( Hi_Fore_Color );
          readln( Line[ Index ] );
          More  := ( length( Line[ Index ] ) <> 0 ) and ( Index < Max_Lines );
          if More then
            Index := succ( Index )
          else
            Num_Lines := pred(Index );
      end;
    end; { procedure Get_Batch_Lines; }


  begin
    Get_Batch_Spec;
    Get_File_Spec;
    Get_Negate;
    Get_Sort;
    Get_Batch_Lines;
  end; { procedure Get_User_Info; }



  procedure Init;
  begin
    Binary_Tree := Nil;
    Batch_Spec  := '';
    File_Spec   := '';
    Mask        := '';
    File_Count  := 0;
    if Video_Mode = 7 then
      begin
        Back_Color    := Black;            { MonoChrome defaults }
        Hi_Fore_Color := White;
        Lo_Fore_Color := LightGray;
        Message_Color := White;
        TextMode;
      end
    else
      begin
        Back_Color    := Black;            { Color defaults }
        Hi_Fore_Color := LightCyan;
        Lo_Fore_Color := Yellow;
        Message_Color := LightMagenta;
        Set_Border( Back_Color );
        TextMode( C80 );
      end;
    TextBackGround( Back_Color );
    TextColor( Message_Color );
    ClrScr;
    writeln( 'Batch File Builder Version ', Version );
    writeln( 'Public Domain Software by Jay S Pondy' );
    writeln;
  end; { Init }


begin
  Init;
  Get_User_Info;
  TextColor( Message_Color );
  Build_Tree;
  if ( File_Count > 0 ) and ( Num_Lines > 0 ) then
    Build_Batch
  else
    writeln( 'Batch File not built. No Files and / or No Lines to Process.' );
end.  { program Batch_File_Builder ( input, output ); }