[Back to FILES SWAG index] [Back to Main SWAG index] [Original]

    {$A+,B-,D+,E-,F+,I-,L+,N-,O+,R-,S+,V-}

    Unit CWare;

    (* Version 1.1 - CollisionWare Premium SoftWare - Compiled by Kito Mann *)
    (* This unit is a simple collection of some some procedures aquired     *)
    (* from other programs and myself. New versions will have added         *)
    (* procedures, and the present ones will be improved. Comments, bugs,   *)
    (* and questions accepted.                                              *)
    (* Keep in mind that there is NO WARANTY! It IS NOT GAURANTEED that all *)
    (* these procedures will work!                                          *)
    (* If you modify the procedures included, or add your own, I request    *)
    (* that you send me a copy of the new unit and source code.             *)

    (* It'd probably be helpful if you declare ErrorCode: byte in your main *)
    (* program. It is used as an Error variable much like the DosError used *)
    (* in the DOS unit.                                                     *)

    (* The Collision Theory pm-BBS *)
    (*         24 hours            *)
    (*      (703)503-9441          * <--- NUMBER AND HOUR CHANGE! *)
    (*         Burke, VA           *)
    (* "Dedicated to Intelligent   *)
    (*        Conversation"        *)

    INTERFACE

    Uses Crt,
         Dos;

    const
      MaxDirEnteries=       20;    { Maximum number of directories that can be specified to search }
                                   { This doesn't include those searched "below" ones specified.   }

    type
      FullNameStr=          string[12];                 { Type for storing name+dot+extention                                 }
      DirSearchEntry=       record                      { This data type is used to store all the paths that will be searched }
                              Dir:         DirStr;      {   <-- Path to search                                                }
                              Name:        FullNameStr; {   <-- File spec to search                                           }
                              Below:       boolean;     {   <-- TRUE=search directories below the specified one               }
                            end;
      ProcType=             procedure(var S: SearchRec; P: PathStr);
      AnyStr=               string[255];

    var
      EngineMask:           FullNameStr;
      EngineAttr:           byte;
      EngineProc:           ProcType;
      EngineCode:           byte;

      Reg:                  Registers;   { Register storage for DOS calls }
      OldSeg,OldOfs:        word;
      BufData:              longint;
      BufferSeg:            word;
      BufferOfs:            word;
      BufferLen:            word;
      BufferPtr:            pointer;
      T:                    text;
      P:                    PathStr;

    (* File and Keyboard Buffer procedures *)

    function FileFound(F: ComStr): boolean;

    procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType; var ErrorCode: byte);

    function GoodDirectory(S: SearchRec): boolean;

    procedure SearchOneDir(var S: SearchRec; P: PathStr);

    procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                              Proc: ProcType; var ErrorCode: byte);

    procedure IPP;

    procedure NewExitProc2;

    procedure ResetBuffer;

    function BufSize: word;

    function InBuffer(S: string): integer;

    procedure InstallInterruptHandler;

    procedure DeleteFiles(P: string);

    procedure DeleteDir(P:string);

    procedure ListFiles(P: string; complete:boolean; pausenum:integer);

    (* Misc. String procedures *)

    function DateString: string;

    function TimeString: string;

    procedure Tab(s1,s2:AnyStr; i:integer);

    Function UpCaseString(StrIn : String) : String;
    { Convert a string to upper case }

    Function PathOnly(FileName : String) : String;
    { Strip any filename information from a file specification }

    Function NameOnly(FileName : String) : String;
    { Strip any path information from a file specification }

    Function BaseNameOnly(FileName : String) : String;
    { Strip any path and extension information from a file specification }

    Function ExtOnly(FileName : String) : String;
    { Return only the extension portion of a filename }

    Function IntStr(Int : LongInt; Form : Integer) : String;
    { Convert an Integer variable to a string }

    Function Strr(Int:LongInt) : String;
    { Same as IntStr but does not use the variable "Form" }

    Function SameFile(File1, File2 : String) : Boolean;
    { Call to find out if File1 has a name equivalent to File2.  Both filespecs }
    { may contain wildcards.                                                    }

    IMPLEMENTATION

    { -------------------------------------------------------------------------- }

    function FileFound(F: ComStr): boolean;
    {
      This returns TRUE if the file F exists, FALSE otherwise.  F can contain
      wildcard characters.
    }
    var
      SRec:                 SearchRec;
    begin
      SRec.Name := '*';
      FindFirst(F,0,SRec);
      if SRec.Name='*' then FileFound := false else FileFound := true;
    end;

    (********* The following search engine routines are sneakly swiped *********)
    (********* from Turbo Technix v1n6.  See there for further details *********)

    procedure SearchEngine(Mask: PathStr; Attr: byte; Proc: ProcType;
                           var ErrorCode: byte);
    var
      S:                    SearchRec;
      P:                    PathStr;
      Ext:                  ExtStr;
    begin
      FSplit(Mask, P, Mask, Ext);
      Mask := Mask+Ext;
      FindFirst(P+Mask,Attr,S);
      if DosError<>0 then
      begin
        ErrorCode := DosError;
        exit;
      end;
      while DosError=0 do
      begin
        Proc(S, P);
        FindNext(S);
      end;
      if DosError=18 then ErrorCode := 0
      else ErrorCode := DosError;
    end;

    { -------------------------------------------------------------------------- }

    function GoodDirectory(S: SearchRec): boolean;
    begin
      GoodDirectory := (S.name<>'.') and (S.Name<>'..') and
      (S.Attr and Directory=Directory);
    end;

    { -------------------------------------------------------------------------- }

    procedure SearchOneDir(var S: SearchRec; P: PathStr);
    begin
      if GoodDirectory(S) then
      begin
        P := P+S.Name;
        SearchEngine(P+'\'+EngineMask,EngineAttr,EngineProc,EngineCode);
        SearchEngine(P+'\*.*',Directory or Archive, SearchOneDir,EngineCode);
      end;
    end;

    { -------------------------------------------------------------------------- }

    procedure SearchEngineAll(Path: PathStr; Mask: FullNameStr; Attr: byte;
                              Proc: ProcType; var ErrorCode: byte);
    begin
      EngineMask := Mask;
      EngineProc := Proc;
      EngineAttr := Attr;
      SearchEngine(Path+Mask,Attr,Proc,ErrorCode);
      SearchEngine(Path+'*.*',Directory or Archive,SearchOneDir,ErrorCode);
      ErrorCode := EngineCode;
    end;

    (************** Thus ends the sneakly swiped code *************)

    { -------------------------------------------------------------------------- }

    procedure IPP;
    { Interrupt pre-processor.  This is a new handler for interrupt 29h which
      provides special functions.  See comments in IHAND.ASM}
    begin
      InLine(
          $06/                   {          push    es                      }
          $1E/                   {          push    ds                      }
          $53/                   {          push    bx                      }
          $57/                   {          push    di                      }
          $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
          $8E/$C3/               {          mov     es, bx                  }
          $BB/$3F/$3F/           {          mov     bx, 3f3fh               }
          $26/$8B/$3F/           {          mov     di, word ptr [es:bx]    }
          $26/$8E/$5F/$02/       {          mov     ds, word ptr [es:bx+2]  }
          $88/$05/               {          mov     byte ptr [di], al       }
          $26/$FF/$07/           {          inc     word ptr [es:bx]        }
          $5F/                   {          pop     di                      }
          $5B/                   {          pop     bx                      }
          $1F/                   {          pop     ds                      }
          $07/                   {          pop     es                      }
          $3C/$0A/               {          cmp     al, 10                  }
          $75/$28/               {          jne     looper                  }
          $50/                   {          push    ax                      }
          $52/                   {          push    dx                      }
          $51/                   {          push    cx                      }
          $53/                   {          push    bx                      }
          $B4/$03/               {          mov     ah, 3                   }
          $B7/$00/               {          mov     bh, 0                   }
          $CD/$10/               {          int     10h                     }
          $80/$FE/$18/           {          cmp     dh, 24                  }
          $75/$15/               {          jne     popper                  }
          $FE/$CE/               {          dec     dh                      }
          $B7/$00/               {          mov     bh, 0                   }
          $B4/$02/               {          mov     ah, 2                   }
          $CD/$10/               {          int     10h                     }
          $B8/$01/$06/           {          mov     ax, 0601h               }
          $B7/$07/               {          mov     bh, 7                   }
          $B9/$00/$11/           {          mov     cx, 1100h               }
          $BA/$4F/$18/           {          mov     dx, 184fh               }
          $CD/$10/               {          int     10h                     }
          $5B/                   {  popper: pop     bx                      }
          $59/                   {          pop     cx                      }
          $5A/                   {          pop     dx                      }
          $58/                   {          pop     ax                      }
          $9C/                   {  looper: pushf                           }
          $9A/$00/$00/$00/$00/   {          call    far [0:0]               }
          $CF);                  {          iret                            }
    end;

    { -------------------------------------------------------------------------- }

    procedure NewExitProc2;
    { This exit procedure removes the interrupt 29h handler from memory and places
      the cursor at the bottom of the screen. }
    begin
      Reg.AH := $25;
      Reg.AL := $29;
      Reg.DS := OldSeg;
      Reg.DX := OldOfs;
      MsDos(Reg);
      Window(1,1,80,25);
      GotoXY(1,24);
      TextAttr := $07;
      ClrEol;
    end;

    { -------------------------------------------------------------------------- }

    procedure ResetBuffer;
    { Reset pointers to the text buffer, effectivly deleting any text in it }
    begin
      MemW[seg(BufData):ofs(BufData)] := BufferOfs;    { Set first 2 bytes of BufData to point to buffer offset }
      MemW[seg(BufData):ofs(BufData)+2] := BufferSeg;  { And next two bytes to point to buffer segment }
      MemW[seg(IPP):ofs(IPP)+21] := seg(BufData);    { Now point the interrupt routine to BufData for pointer }
      MemW[seg(IPP):ofs(IPP)+26] := ofs(BufData);    {  to the text buffer }
    end;

    { -------------------------------------------------------------------------- }

    function BufSize: word;
    { This returns the number of characters in the text buffer.  It's what BufData
      now points to minus what is origionally pointed to, eg, the number of times
      IPP incremented it }
    begin
      BufSize := MemW[seg(BufData):ofs(BufData)]-BufferOfs;
    end;

    { -------------------------------------------------------------------------- }

    function InBuffer(S: string): integer;
    { This searched the text buffer for the string S, and if it's found returns
      the offset in the buffer.  If it's not found a -1 is returned }
    var
      L,M:                  word;
      X:                    byte;
    begin
      X := 1;
      L := BufferOfs;
      M := BufSize;
      while (X<=length(S)) and (L<=M) do
      begin
        if Mem[BufferSeg:L]=byte(S[X]) then Inc(X) else X := 1;
        Inc(L);
      end;
      if X>length(S) then InBuffer := L-length(S) else InBuffer := -1;
    end;

    { -------------------------------------------------------------------------- }

    procedure InstallInterruptHandler;
    { Installs the int 29h handler }
    begin
      BufferLen := $4000;  { Set up a 16k buffer }
      GetMem(BufferPtr,BufferLen);  { Allocate memory pointed at by BufferPtr }
      BufferSeg := seg(BufferPtr^);  { Read segment and offset of buffer for easy access }
      BufferOfs := ofs(BufferPtr^);
      ResetBuffer;    { Place these values in the IPP routine, resetting buffer }
      Reg.AH := $35;
      Reg.AL := $29;  { DOS service 35h, get interrupt vector for 29h }
      MsDos(Reg);
      OldSeg := Reg.ES;   { Store the segment and offset of the old vector for later use }
      OldOfs := Reg.BX;
      MemW[seg(IPP):ofs(IPP)+90] := Reg.BX;  { And store them so IPP can call the routine }
      MemW[seg(IPP):ofs(IPP)+92] := Reg.ES;
      Reg.AL := $29; { DOS service 25h, set interrupt vector 29h }
      Reg.AH := $25;
      Reg.DS := seg(IPP);    { Store segment and offset for IPP.  The +16 is to skip TP stack }
      Reg.DX := ofs(IPP)+16; { maintainence routines }
      MsDos(Reg);
    end;

    { -------------------------------------------------------------------------- }

      procedure DeleteFiles(P: string);
      {
        Delete all files in the directory named, including
        Hidden, Read-only, System and other file types.
      }
      var
        SRec:               SearchRec;
        ErrorCode:          byte;
      begin
        FindFirst(P+'\*.*',0,SRec);
        while DosError=0 do
        begin
          Assign(T, P+'\'+SRec.Name);
          SetFAttr(T,Archive);
          writeln('Deleting ',P,+'\'+Srec.Name);
          {$I-}
          Erase(T);
          {$I+}
          ErrorCode := IOResult;
          FindNext(SRec);
        end;
        ErrorCode := IOResult;
    end;

    { -------------------------------------------------------------------------- }

    procedure DeleteDir(P:string);

    { Simply deletes specified directory }

    var ErrorCode: byte;
    begin
      DeleteFiles(P);
      {$I-}
      RmDir(P);
      {$I+}
      ErrorCode := IOResult;
    end;

    { -------------------------------------------------------------------------- }

    procedure ListFiles(P: string; complete:boolean; pausenum:integer);
      {
       If complete is true then will show the name and file size of every
       file. Otherwise will just show the filename. Numlines is the number
       of files it will display before a pause. 0 means no pause.
      }
      var
        SRec:               SearchRec;
        ErrorCode:          byte;
        Size:               AnyStr;
        Index:              integer;
        TheChar:            char;
        Quit:               boolean;

      begin
        Quit:=false;
        FindFirst(P+'\*.*',0,SRec);
        Index:=1;
        while DosError=0 do
        begin
           if Index=pausenum then
           begin
            write('[Q=quit, ANY KEY=continue]:');
            TheChar:=UpCase(ReadKey); writeln(TheChar);
            if TheChar='Q' then quit:=true;
            writeln;
            Index:=0;
           end;
          if NOT Quit then
          if complete then begin
            Size:=strr(Srec.Size);
            tab(Srec.Name,Size,15);
            writeln;
          end else
          writeln(Srec.Name);
          FindNext(SRec);
          Inc(Index);
        end;
        ErrorCode := IOResult;
    end;

    { -------------------------------------------------------------------------- }

      function DateString: string;
      {
        Returns the current date in a string of the form:  MON ## YEAR.
        E.g, 21 Feb 1989 or 02 Jan 1988.
      }
      const
        Month:              array[1..12] of string[3]=
                            ('Jan','Feb','Mar','Apr','May','Jun',
                             'Jul','Aug','Sep','Oct','Nov','Dec');
      var
        Y,M,D,Junk:         word;
        DS,YS:              string[5];
      begin
        GetDate(Y,M,D,Junk);
        Str(Y,YS);
        Str(D,DS);
        if length(DS)<2 then DS := '0'+DS;
        DateString := DS+' '+Month[M]+' '+YS;
      end;

    { -------------------------------------------------------------------------- }

      function TimeString: string;
      {
        Returns the current time in the form:  HH:MM am/pm
        E.g, 12:00 am or 09:12 pm.
      }
      var
        H,M,Junk:           word;
        HS,MS:              string[5];
        Am:                 boolean;
      begin
        GetTime(H,M,Junk,Junk);
        case H of
          0:     begin
                   Am := true;
                   H := 12;
                 end;
          1..11: Am := true;
          12:    Am := false;
          else   begin
                   Am := false;
                   H := H-12;
                 end;
        end;
        Str(H,HS);
        Str(M,MS);
        if length(HS)<2 then HS := '0'+HS;
        if length(MS)<2 then MS := '0'+MS;
        if Am then TimeString := HS+':'+MS+' am'
        else TimeString := HS+':'+MS+' pm';
      end;

    { -------------------------------------------------------------------------- }

    procedure Tab(s1,s2:AnyStr; i:integer);

    { Writes s1, then goes to i-length(s1) and writes s2 }

    var j,k:integer;
    begin
      j:=length(s1);
      i:=i-j;
      write(s1);
      for k:=1 to i do write(' ');
      write(s2);
    end;

    { -------------------------------------------------------------------------- }

    Function UpCaseString(StrIn : String) : String;
    Begin
       Inline(                   { Thanks to Phil Burns for this routine }

          $1E/                   {         PUSH    DS                ; Save DS}
          $C5/$76/$06/           {         LDS     SI,[BP+6]         ; Get source string address}
          $C4/$7E/$0A/           {         LES     DI,[BP+10]        ; Get result string address}
          $FC/                   {         CLD                       ; Forward direction for strings}
          $AC/                   {         LODSB                     ; Get length of source string}
          $AA/                   {         STOSB                     ; Copy to result string}
          $30/$ED/               {         XOR     CH,CH}
          $88/$C1/               {         MOV     CL,AL             ; Move string length to CL}
          $E3/$0E/               {         JCXZ    Exit              ; Skip if null string}
                                 {;}
          $AC/                   {UpCase1: LODSB                     ; Get next source character}
          $3C/$61/               {         CMP     AL,'a'            ; Check if lower-case letter}
          $72/$06/               {         JB      UpCase2}
          $3C/$7A/               {         CMP     AL,'z'}
          $77/$02/               {         JA      UpCase2}
          $2C/$20/               {         SUB     AL,'a'-'A'        ; Convert to uppercase}
                                 {;}
          $AA/                   {UpCase2: STOSB                     ; Store in result}
          $E2/$F2/               {         LOOP    UpCase1}
                                 {;}
          $1F);                  {Exit:    POP     DS                ; Restore DS}

    end {UpCaseString};

    { -------------------------------------------------------------------------- }

    Function PathOnly(FileName : String) : String;
    Var
       Dir  : DirStr;
       Name : NameStr;
       Ext  : ExtStr;
    Begin
       FSplit(FileName, Dir, Name, Ext);
       PathOnly := Dir;
    End {PathOnly};

    { --------------------------------------------------------------------------- }

    Function NameOnly(FileName : String) : String;
    { Strip any path information from a file specification }
    Var
       Dir  : DirStr;
       Name : NameStr;
       Ext  : ExtStr;
    Begin
       FSplit(FileName, Dir, Name, Ext);
       NameOnly := Name + Ext;
    End {NameOnly};

    { --------------------------------------------------------------------------- }

    Function BaseNameOnly(FileName : String) : String;
    { Strip any path and extension from a file specification }
    Var
       Dir  : DirStr;
       Name : NameStr;
       Ext  : ExtStr;
    Begin
       FSplit(FileName, Dir, Name, Ext);
       BaseNameOnly := Name;
    End {BaseNameOnly};

    { --------------------------------------------------------------------------- }

    Function ExtOnly(FileName : String) : String;
    { Strip the path and name from a file specification.  Return only the }
    { filename extension.                                                 }
    Var
       Dir  : DirStr;
       Name : NameStr;
       Ext  : ExtStr;
    Begin
       FSplit(FileName, Dir, Name, Ext);
       If Pos('.', Ext) <> 0 then
          Delete(Ext, 1, 1);
       ExtOnly := Ext;
    End {ExtOnly};

    { --------------------------------------------------------------------------- }

    Function IntStr(Int : LongInt; Form : Integer) : String;
    Var
       S : String;
    Begin
       If Form = 0 then
          Str(Int, S)
       else
          Str(Int:Form, S);
       IntStr := S;
    End {IntStr};

    { --------------------------------------------------------------------------- }

    Function Strr(Int : LongInt) : String; { Added for my own sake - KM }
    Var
       S : String;
    Begin
       Str(Int, S);
       Strr := S;
    End {Strr};

    { --------------------------------------------------------------------------- }

    Function SameName(N1, N2 : String) : Boolean;
    {
      Function to compare filespecs.

      Wildcards allowed in either name.
      Filenames should be compared seperately from filename extensions by using
         seperate calls to this function
            e.g.  FName1.Ex1
                  FName2.Ex2
                  are they the same?
                  they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)

      Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
      match just any file...only those with 'XX' as the last two characters of
      the name portion and 'DAT' as the extension).

      This routine calls itself recursively to resolve wildcard matches.

    }
    Var
       P1, P2 : Integer;
       Match  : Boolean;
    Begin
       P1    := 1;
       P2    := 1;
       Match := TRUE;

       If (Length(N1) = 0) and (Length(N2) = 0) then
          Match := True
       else
          If Length(N1) = 0 then
             If N2[1] = '*' then
                Match := TRUE
             else
                Match := FALSE
          else
             If Length(N2) = 0 then
                If N1[1] = '*' then
                   Match := TRUE
                else
                   Match := FALSE;

       While (Match = TRUE) and (P1 <= Length(N1)) and (P2 <= Length(N2)) do
          If (N1[P1] = '?') or (N2[P2] = '?') then begin
             Inc(P1);
             Inc(P2);
          end {then}
          else
             If N1[P1] = '*' then begin
                Inc(P1);
                If P1 <= Length(N1) then begin
                   While (P2 <= Length(N2)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
                      Inc(P2);
                   If P2 > Length(N2) then
                      Match := FALSE
                   else begin
                      P1 := Succ(Length(N1));
                      P2 := Succ(Length(N2));
                   end {if};
                end {then}
                else
                   P2 := Succ(Length(N2));
             end {then}
             else
                If N2[P2] = '*' then begin
                   Inc(P2);
                   If P2 <= Length(N2) then begin
                      While (P1 <= Length(N1)) and Not SameName(Copy(N1,P1,Length(N1)-P1+1), Copy(N2,P2,Length(N2)-P2+1)) do
                         Inc(P1);
                      If P1 > Length(N1) then
                         Match := FALSE
                      else begin
                         P1 := Succ(Length(N1));
                         P2 := Succ(Length(N2));
                      end {if};
                   end {then}
                   else
                      P1 := Succ(Length(N1));
                end {then}
                else
                   If UpCase(N1[P1]) = UpCase(N2[P2]) then begin
                      Inc(P1);
                      Inc(P2);
                   end {then}
                   else
                      Match := FALSE;

       If P1 > Length(N1) then begin
          While (P2 <= Length(N2)) and (N2[P2] = '*') do
             Inc(P2);
          If P2 <= Length(N2) then
             Match := FALSE;
       end {if};

       If P2 > Length(N2) then begin
          While (P1 <= Length(N1)) and (N1[P1] = '*') do
             Inc(P1);
          If P1 <= Length(N1) then
             Match := FALSE;
       end {if};

       SameName := Match;

    End {SameName};

    { ---------------------------------------------------------------------------- }

    Function SameFile(File1, File2 : String) : Boolean;
    Var
       Path1, Path2 : String;
    Begin

       File1 := FExpand(File1);
       File2 := FExpand(File2);
       Path1 := PathOnly(File1);
       Path2 := PathOnly(File2);

       SameFile := SameName(BaseNameOnly(File1), BaseNameOnly(File2)) AND
                   SameName(ExtOnly(File1), ExtOnly(File2))           AND
                   (Path1 = Path2);

    End {SameFile};

    { ---------------------------------------------------------------------------- }

    End {Unit CWARE}.

[Back to FILES SWAG index] [Back to Main SWAG index] [Original]