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

    {$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V-,X-,Y-}
    {$M 16384,0,655360}
    {$DEFINE Kort}
    Program Extract;
      { extract filenames and accompanying descriptions from bbs files listings }
      { Author: Eddy Thilleman, 19 mei 1994 }
      { written in Borland Pascal version 7.01 }
      {  modified: augustus 1994 - choose between long vs. short directory name }
      {  modified: januari  1995 - keep only filenames with entries found on screen
                                 - total number of found entries
                                 - delete destination directory if no entries found }

    Uses
      Dos;

    Type
      TypeNotAllowed = set of char;  { filter out (some) header lines }
    Const
      NotAllowed : TypeNotAllowed = [''..' ','*',':'..'?','|','°'..'ß'];
      NoFAttr : word =   $1C;  { dir-, volume-, system attributen }
      FAttr   : word =   $23;  { readonly-, hidden-, archive attributes }
      BufSizeBig     = 49152;  { 48 KB }
      BufSizeSmall   =  8192;  {  8 KB }
      Cannot         = 'Cannot create destination ';
      MaxNrLines     =    20;  { max # of lines for one entry }
      MaxNrSearch    =    18;  { max # of words to search for }

    Type
      BufTypeSource  = array [1..BufSizeBig  ] of char;
      BufTypeDest    = array [1..BufSizeSmall] of char;
      string3        = string[03];
      String12       = string[12];
      String16       = string[16];
      String25       = string[25];
      String65       = string[65];
      TypeLine       = array [1..MaxNrLines] of string;

    Var
      Line             : TypeLine;         { filename and description  }
      Tmp1, Tmp2       : string;           { temporary hold lines here }
      FileName         : String12;         { filename in files listing }
      SearchText       : array [1..MaxNrSearch] of String65;
      Count, TotalCount: word;             { # of found entries        }
      SourceFile, DestFile : text;         { sourcefile and dest. file }
      SourceBuf        : BufTypeSource;    { source text buffer        }
      DestBuf          : BufTypeDest;      { destination text buffer   }
    {$IFDEF Kort}
      DestListing      : string16;         { name of destination file  }
      DestDir          : string3 ;         { name of destination directory }
    {$ELSE}
      DestListing      : string25;         { name of destination file  }
      DestDir          : string12;         { name of destination directory }
    {$ENDIF}
      FR               : SearchRec;        { FileRecord }
      FMask, DirName   : String12;
      Exists           : boolean;
      nr,                                  { nr: points to element# where
                                                 to put the next read-in line   }
      NrLines          : byte;             { NrLines: number of lines belonging
                                                 to this entry }
      found, Header    : boolean;
      T                : byte;             { points to char in line: allowed? }
      NrSearch,                            { current word to search for       }
      TotalNrSearch    : byte;             { total # of words to search for   }

    procedure LowerFast( var Str: String );
      { 52 Bytes by Bob Swart, 11-6-1993, '80XXX' FASTEST! }
    InLine(
      $8C/$DA/               {       mov   DX,DS                 }
      $BB/Ord('A')/
          Ord('Z')-Ord('A')/ {       mov   BX,'Z'-'A'/'A'        }
      $5E/                   {       pop   SI                    }
      $1F/                   {       pop   DS                    }
      $FC/                   {       cld                         }
      $AC/                   {       lodsb                       }
      $88/$C1/               {       mov   CL,AL                 }
      $30/$ED/               {       xor   CH,CH                 }
      $D1/$E9/               {       shr   CX,1                  }
      $73/$0B/               {       jnc   @Part1                }
      $AC/                   {       lodsb                       }
      $28/$D8/               {       sub   AL,BL                 }
      $38/$F8/               {       cmp   AL,BH                 }
      $77/$04/               {       ja    @Part1                }
      $80/$44/$FF/
          Ord('a')-Ord('A')/ {@Loop: ADD   Byte Ptr[SI-1],'a'-'A'}
      $E3/$14/               {@Part1:jcxz  @Exit                 }
      $AD/                   {       lodsw                       }
      $28/$D8/               {       sub   AL,BL                 }
      $38/$F8/               {       cmp   AL,BH                 }
      $77/$04/               {       ja    @Part2                }
      $80/$44/$FE/
          Ord('a')-Ord('A')/ {       ADD   Byte Ptr[SI-2],'a'-'A'}
      $49/                   {@Part2:dec   CX                    }
      $28/$DC/               {       sub   AH,BL                 }
      $38/$FC/               {       cmp   AH,BH                 }
      $77/$EC/               {       ja    @Part1                }
      $EB/$E6/               {       jmp   @Loop                 }
      $8E/$DA                {@Exit: mov   DS,DX                 }
    ) { LowerFast };

    procedure CopySubStr( Str1: string; start, nrchars: byte; var Str2: string );
    assembler;
      { copy part of Str1 (beginning at start for nrchars) to Str2
        if start > length of Str1, Str2 will contain a empty string.
        if nrchars specifies more characters than remain starting at the
        start position, Str2 will contain just that remainder of Str1. }
    asm     { setup }
            lds   si, str1     { load in DS:SI pointer to str1 }
            cld                { string operations forward     }
            les   di, str2     { load in ES:DI pointer to str2 }
            mov   ah, [si]     { length str1 --> AH            }
            and   ah, ah       { length str1 = 0?              }
            je    @null        { yes, empty string in Str2     }
            mov   bl, [start]  { starting position --> BL      }
            cmp   ah, bl       { start > length str1?          }
            jb    @null        { yes, empty string in Str2     }

            { start + nrchars - 1 > length str1?               }
            mov   al, [nrchars]{ nrchars --> AL                }
            mov   dh, al       { nrchars --> DH                }
            add   dh, bl       { add start                     }
            dec   dh
            cmp   ah, dh       { nrchars > rest of str1?       }
            jb    @rest        { yes, copy rest of str1        }
            jmp   @copy
    @null:  xor   ax, ax       { return a empty string         }
            jmp   @done
    @rest:  sub   ah, bl       { length str1 - start           }
            inc   ah
            mov   al, ah
    @copy:  mov   cl, al       { how many chars to copy        }
            xor   ch, ch       { clear CH                      }
            xor   bh, bh       { clear BH                      }
            add   si, bx       { starting position             }
            mov   dx, di       { save pointer to str2          }
            inc   di
        rep movsb              { copy part str1 to str2        }
            mov   di, dx       { restore pointer to str2       }
    @done:  mov   [di], al     { overwrite length byte of str2 }
    @exit:
    end  { CopySubStr };

    procedure StrCopy( var Str1, Str2: string ); assembler;
      { copy str1 to str2 }
    asm
            lds   si, str1     { load in DS:SI pointer to str1 }
            cld                { string operations forward     }
            les   di, str2     { load in ES:DI pointer to str2 }
            xor   ch, ch       { clear CH                      }
            mov   cl, [si]     { length str1 --> CX            }
            inc   cx           { include length byte           }
        rep movsb              { copy str1 to str2             }
    @exit:
    end  { StrCopy };

    function StrPos( var str1, str2: string ): byte; assembler;
      { returns position of the first occurrence of str1 in str2 }
      { str1 - string to search for }
      { str2 - string to search in  }
      { return value in AX }
    asm
            cld                 { string operations forward                 }
            les   di, str2      { load in ES:DI pointer to str2             }
            xor   cx, cx        { clear cx                                  }
            mov   cl, [di]      { length str2 --> CL                        }
            jcxz  @not          { if length str2 = 0, nothing to search in  }
            mov   bh, cl        { length str2 --> BH                        }
            inc   di            { di point to 1st char of str2              }
            lds   si, str1      { load in DS:SI pointer to str1             }
            lodsb               { load in AL length str1                    }
            and   al, al        { length str1 = 0?                          }
            jz    @not          { length str1 = 0, nothing to search for    }
            dec   al            { 1st char need not be compared again       }
            sub   cl, al        { length str2 - length str1                 }
            jbe   @not          { length str2 < length str1                 }
            mov   ah, al        { length str1 --> AH                        }
            lodsb               { load in AL 1st character of str1          }
    @start:
      repne scasb               { scan for next occurrence 1st char in str2 }
            jne   @not          { no success                                }
            mov   dx, si        { pointer to 2nd char in str1 --> DX        }
            mov   bl, cl        { number of chars in str2 to go --> BL      }
            mov   cl, ah        { length str1 --> CL                        }
       repe cmpsb               { compare until characters don't match      }
            je    @pos          { full match                                }
            sub   si, dx        { current SI - prev. SI = # of chars moved  }
            sub   di, si        { current DI - # of chars moved = prev. DI  }
            mov   si, dx        { restore pointer to 2nd char in str1       }
            mov   cl, bl        { number of chars in str2 to go --> BL      }
            jmp   @start        { scan for next occurrence 1st char in str2 }
    @not:   xor   ax, ax        { str1 is not in str2, result 0             }
            jmp   @exit
    @pos:   add   bl, ah        { number of chars in str2 left              }
            mov   al, bh        { length str2 --> AX                        }
            sub   al, bl        { start position of str1 in str2            }
    @exit:                      { we are finished. }
    end  { StrPos };

    procedure Trim( var Str: string ); assembler;
      { remove leading and trailing white space from str }
      { white space = all ASCII chars 0h - 20h }
    asm     { setup }
            lds   si, str        { load in DS:SI pointer to Str       }
            xor   cx, cx         { clear cx                           }
            mov   cl, [si]       { length Str --> cx                  }
            jcxz  @exit          { if length Str = 0, exit            }
            mov   bx, si         { save pointer to length byte of Str }
            add   si, cx         { last character                     }

            { look for trailing space }
    @loop1: mov   al, [si]       { load character                     }
            cmp   al, ' '        { no white space                     }
            ja    @stop1         { first non-blank character found    }
            dec   si             { next character                     }
            dec   cx             { count down                         }
            jcxz  @done          { if no more characters left, done   }
            jmp   @loop1         { try again                          }
    @stop1: mov   si, bx         { point to start of Str              }
            inc   si             { point to 1st character             }
            mov   di, si         { pointer to Str --> DI              }
            { look for leading white space }
    @loop2: mov   al, [si]       { load character                     }
            cmp   al, ' '        { no white space                     }
            ja    @stop2         { first non-blank character found    }
            inc   si             { next character                     }
            dec   cx             { count down                         }
            jcxz  @done          { if no more characters left, done   }
            jmp   @loop2         { try again                          }

            { remove leading white space }
    @stop2: cld                  { string operations forward          }
            mov   dx, cx         { save new length Str                }
        rep movsb                { move remaining part of Str         }
            mov   cx, dx         { restore new length Str             }
    @done:  mov   [bx], cl       { new length of Str                  }
    @exit:
    end  { Trim };

    function InSet25(var _Set; OrdElement: Byte): Boolean;
      { I got this function from Bob Swart }
    InLine(
      $58/         {   pop   AX                   }
      $30/$E4/     {   xor   AH,AH                }
      $5F/         {   pop   DI                   }
      $07/         {   pop   ES                   }
      $89/$C3/     {   mov   BX,AX                }
      $B1/$03/     {   mov   CL,3                 }
      $D3/$EB/     {   shr   BX,CL                }
      $88/$C1/     {   mov   CL,AL                }
      $80/$E1/$07/ {   and   CL,$07               }
      $B0/$01/     {   mov   AL,1                 }
      $D2/$E0/     {   shl   AL,CL                }
      $26/         {   ES:                        }
      $22/$01/     {   and   AL,BYTE PTR [DI+BX]  }
      $D2/$E8);    {   shr   AL,CL                }
    { InSet25 }

    function OpenTextFile (var InF: text; const name: string; var buffer: BufTypeSource): boolean;
    begin
      Assign( InF, Name );
      SetTextBuf( InF, buffer );
      Reset( InF );
      OpenTextFile := (IOResult = 0);
    end  { OpenTextFile };

    function CreateTextFile (var OutF: text; const name: string; var buffer: BufTypeDest): boolean;
    begin
      Assign( OutF, Name );
      SetTextBuf( OutF, buffer );
      Rewrite( OutF );
      CreateTextFile := (IOResult = 0);
    end  { CreateTextFile };

    function Exist( Name : string ) : Boolean;
      { Return true if directory or file with the same name is found}
    var
      F    : file;
      Attr : Word;
    begin
      Assign( F, Name );
      GetFAttr( F, Attr );
      Exist := (DosError = 0)
    end;

    {$IFDEF Kort}
    procedure UniekeEntry( var Naam : string3 );
    const
      max    = $39;  { '0'..'9' = $30..$39 }
    var
      Nbyte  : array [0..3] of byte absolute Naam;
      Exists : boolean;

    begin
      Nbyte [0] := 3;  { FileName of 3 characters }

      Exists := True;
      Nbyte [1] := $30;
      while (Nbyte [1] <= max) and Exists do begin
        Nbyte [2] := $30;
        while (Nbyte [2] <= max) and Exists do begin
          Nbyte [3] := $30;
          while (Nbyte [3] <= max) and Exists do begin
            Exists := Exist( Naam );
            if Exists then inc( Nbyte [3] );
          end;
          if Exists then inc( Nbyte [2] );
        end;
        if Exists then inc( Nbyte [1] );
      end;
    end;  { end procedure UniekeEntry }

    {$ELSE}
    procedure UniekeEntry( var Naam : string12 );
    const
      max    = $39;  { '0'..'9' = $30..$39 }
    var
      Nbyte  : array [0..12] of byte absolute Naam;
      Exists : boolean;

    begin
      Nbyte [0] := 12;  { FileName of 12 characters (8+3+".") }
      Nbyte [9] := $2E; { '.' as 9e character }

      Exists := True;
      Nbyte [1] := $30;
      while (Nbyte [1] <= max) and Exists do begin
        Nbyte [2] := $30;
        while (Nbyte [2] <= max) and Exists do begin
          Nbyte [3] := $30;
          while (Nbyte [3] <= max) and Exists do begin
            Nbyte [4] := $30;
            while (Nbyte [4] <= max) and Exists do begin
              Nbyte [5] := $30;
              while (Nbyte [5] <= max) and Exists do begin
                Nbyte [6] := $30;
                while (Nbyte [6] <= max) and Exists do begin
                  Nbyte [7] := $30;
                  while (Nbyte [7] <= max) and Exists do begin
                    Nbyte [8] := $30;
                    while (Nbyte [8] <= max) and Exists do begin
                      Nbyte [10] := $30;
                      while (Nbyte [10] <= max) and Exists do begin
                        Nbyte [11] := $30;
                        while (Nbyte [11] <= max) and Exists do begin
                          Nbyte [12] := $30;
                          while (Nbyte [12] <= max) and Exists do begin
                            Exists := Exist( Naam );
                            if Exists then inc( Nbyte [12] );
                          end;
                          if Exists then inc( Nbyte [11] );
                        end;
                        if Exists then inc( Nbyte [10] );
                      end;
                      if Exists then inc( Nbyte [8] );
                    end;
                    if Exists then inc( Nbyte [7] );
                  end;
                  if Exists then inc( Nbyte [6] );
                end;
                if Exists then inc( Nbyte [5] );
              end;
              if Exists then inc( Nbyte [4] );
            end;
            if Exists then inc( Nbyte [3] );
          end;
          if Exists then inc( Nbyte [2] );
        end;
        if Exists then inc( Nbyte [1] );
      end;
    end;  { end procedure UniekeEntry }
    {$ENDIF}

    procedure Search;
    begin
      found := False;
      NrSearch := 1;
      while (NrSearch <= TotalNrSearch) and not found do
      begin
        nr := 1;
        while (nr <= NrLines) and not found do
        begin                                { search wanted text    }
          StrCopy( Line[nr], Tmp1 );
          LowerFast( Tmp1 );                 { convert to lower case }
          if StrPos( SearchText[NrSearch], Tmp1 ) > 0 then found := True;
          inc( nr );
        end;
        inc( NrSearch );
      end;
      if found then                      { at least one of the wanted words found }
      begin
        for nr := 1 to NrLines do WriteLn( DestFile, Line[nr] );
        inc( Count );
      end;
    end;

    procedure Process( var SourceListing : string12 );
    begin
      Count := 0;
      DestListing  := DestDir + '\' + SourceListing;
      if OpenTextFile( SourceFile, SourceListing, SourceBuf ) then
      begin
        if CreateTextFile( DestFile, DestListing, DestBuf ) then
        begin
          write( SourceListing:12 );
          Header   := False;
          FileName := '';
          NrLines  := 0;
          nr := 1;
          ReadLn( SourceFile, Line[nr] );
          while not Eof(SourceFile) and (IOResult = 0) do
          begin
            StrCopy( Line[nr], Tmp1 );
            Trim( Tmp1 );
            if Length( Tmp1 ) > 0 then                  { no empty lines }
            begin
              CopySubStr( Line[nr], 1, 12, FileName );
              Trim( FileName );
              T := 1;
              while (T <= Length( FileName ))
              and not InSet25( NotAllowed, Byte( FileName[T] ) ) do
                inc( T );                               { look out for headers }
              { }
              Header := (T <= Length( FileName ))
                or ((Length( FileName ) > 0) and (Line[nr][1]=' '));  { header? }
              if Header then
                FileName := ''                          { read next line }
              else                                      { no header }
              begin
                if (Length( FileName ) = 0) then        { more description }
                begin
                  inc( nr );
                  inc( NrLines );
                end
                else
                begin
                  StrCopy( Line[nr], Tmp2 );     { save new textline    }
                  Search;

                  { setup for next entry }
                  NrLines  := 1;                 { already got one line }
                  nr       := 2;                 { so next line in #2   }
                  StrCopy( Tmp2, Line[1] );      { restore new textline }
                  FileName := '';                { make sure a new line is read }
                end;  { endif (Length( FileName ) = 0)) }
              end;  { if Header }
            end;  { if Length( Tmp1 ) > 0 }
            if (Length( FileName ) = 0) then
              ReadLn( SourceFile, Line[nr] );
            { }
          end;  { while not Eof(SourceFile) and (IOResult = 0) }
          inc( NrLines );   { include the last line in the search }
          Search;
          Close( DestFile );
          if (Count = 0) then
          begin
            Erase( DestFile );
            Write( #13 );
          end
          else
          begin
            writeln( Count:7, ' in ', DestListing );
            TotalCount := TotalCount + Count;
          end
        end  { if CreateTextFile }
        else
          writeln( Cannot, 'file ', DestListing );
        { }
        Close( SourceFile );
      end   { if OpenTextFile }
      else
        writeln( 'Cannot open sourcefile ', SourceListing );
      { }
    end;

    begin
      if ParamCount > 1 then                 { parameters: listing catchwords  }
      begin
        TotalCount := 0;
        TotalNrSearch := ParamCount - 1;
        if (TotalNrSearch > MaxNrSearch) then
          TotalNrSearch := MaxNrSearch;      { no more catchwords than maximum }
        UniekeEntry( DestDir );
        if not Exists then
        begin
          MkDir( DestDir );
          if (IOResult=0) then
          begin
            Write( 'Searching:' );
            FMask        := ParamStr( 1 );                    { filemask       }
            for NrSearch := 1 to TotalNrSearch do             { all catchwords }
            begin
              SearchText[NrSearch] := ParamStr( NrSearch+1 ); { each catchword }
              LowerFast( SearchText[NrSearch] );     { translate to lower case }
              Write(' ', SearchText[NrSearch] );
            end;
            WriteLn;
            FindFirst(FMask, FAttr, FR);
            while DosError = 0 do
            begin
              Process(FR.Name);
              FindNext(FR);
            end;
            WriteLn( 'Total found ', TotalCount, ' entries.' );
            if (TotalCount = 0) then RmDir( DestDir );
          end;  { if not IOResult }
        end   { if not Exists }
        else
          writeln( Cannot, 'directory ', DestListing );
        { }
      end   { if ParamCount > 1 }
      else
        WriteLn( 'Extract filename word(s)' );
    end.

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