Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/ECO30603.ZIP/ECO30603.LZH/ECOLIBCS/DEMOS/QF.PAS

Pascal/Delphi Source File | 1993-03-08 | 13.2 KB | 417 lines

(*
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   QuickFind was conceived, designed and written    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   by Floor A.C. Naaijkens for                      ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   UltiHouse Software / The ECO Group.              ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   (C) MCMXCII by EUROCON PANATIONAL CORPORATION.   ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   All Rights Reserved for The ECO Group.           ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓                                                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓   QuickFind files with content.                    ░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓│                                                  │░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓·──                                              ──·░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░░▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
    ▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓▓
*)
{$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}

uses
  eco_srch, eco_lib,
  crt, dos

  ;


type
  srec_ptr = ^srec_chain;
  srec_chain = record
    srec : searchrec;
    bid  :   longint;
    prev :      word;
    link :  srec_ptr;
  end;

  nodes = record
    name    : string[12];
    bid     :    longint; { bytes in directory }
    parent  :       word;
  end;

  nodearraytype =  array[0..511] of nodes;
  nodearraytypeptr = ^nodearraytype;


const
  sort_items : boolean =  true;
  show       : boolean =  true;
  redirect   : boolean = false;

var
  node_file              :    file of nodes;
  nodearray              : nodearraytypeptr;
  srec                   :        searchrec;
  startx, starty,
  index1, index2         :             word;
  hex, curdir,
  olddir,
  commandstr             :           string;
  searchfilename         :          pathstr;
  searchfile             :             file;
  nf, resultat,
  casesensitive          :          boolean;
  ch                     :             char;
  b4, during, nod,
  nodenumber,
  prevparent,
  after, oldattr,
  longeur, min, max,
  bufpointer,
  sizeread, i, j         :             word;
  longbufpos             :          longint;
  dirinfo                :        searchrec;
  dir                    :           dirstr;
  name                   :          namestr;
  ext                    :           extstr;



  function  __backrem(s: string) : string;
  begin
    if s[length(s)] = '\' then __backrem := copy(s, 1, length(s)-1) else
      __backrem := s;
  end;


  function  __backapp(s: string) : string;
  begin
    if s[length(s)]<>'\' then __backapp := s + '\' else __backapp := s;
  end;



  function __extractname(s : string): string;
  var i : byte;
  begin
    i := length(s); while s[i] <> '\' do dec(i);
    __extractname := copy(s, i+1, length(s)-i);
  end;


  function __extractpath(s : string): string; { alleen ROOT eindigt op \ }
  var i : byte;
  begin
    i := length(s); while (s[i] <> '\') and (i > 1) do dec(i);
    if i > 3 then dec(i);
    __extractpath := copy(s, 1, i);
  end;



  procedure help;
  begin
    textcolor(yellow);
    writeln('QF - QuickFind String Find Utility -- Version 1.0');
    writeln('(C) MCMXCII by UltiHouse Software / The ECO Group.');
    writeln('Part of the UltiGREP package: GSR, USR, QF, UGREP.');
    textcolor(lightgray); writeln;
    writeln('Usage: QF [wildfile] [searchtext] [/c] [/s] [/d]');
    writeln('  /c search case sensitive');
    writeln('  /s search entire subtree');
    writeln('  /d disable show on screen');
    writeln;
    writeln('Examples:');
    writeln('  QF *.PAS helpproc /c /s');
    writeln('  QF C:\PROG\BORLANDC\INCLUDE\*.H _WinExitErr /c /s >d:\find');
    halt(0);
  end;


  function __comp(s1, s2: string): boolean;
  begin
    __comp := (
      __cvtstr(s1, _rem_white_str + _to_upcase_str) =
      __cvtstr(s2, _rem_white_str + _to_upcase_str)
    )
  end;



  function __inparams(s: string): boolean;
  var
    i :    word;
    b : boolean;

  begin
    b := false;
    for i := 1 to paramcount do b := b or __comp(s, paramstr(i));
    __inparams := b;
  end;



  function trace_path(temphead: integer): pathstr;
  var
    off      :                    word;
    st       :                  string;
    i        :                    word;
    tmp      : array[1..50] of integer;

  begin
    off := 0;
    while temphead>0 do begin
      inc(off); tmp[off] := temphead;
      temphead := nodearray^[temphead].parent;
    end; st := '\';
    if off>0 then for i := off downto 1 do
      st := st + nodearray^[tmp[i]].name +'\';
    off := 0; fillchar(tmp, sizeof(tmp), chr(48));
    trace_path := st;
  end;


{$I-}
  procedure search_tree(level: word);
  var
    i         :  integer;
    s         :   string;
    srec_root,
    srec_link : srec_ptr;

    { not much subdirs in one dir, so no efficiency taken into account }
    procedure sort(srec_root: srec_ptr);
    var
      srec1, srec2, srec3 :  srec_ptr;
      srec                : searchrec;

    begin
      srec1 := srec_root;
      while srec1^.link <> nil do begin
        srec2 := srec1^.link; srec3 := srec1;
        repeat { assume we are already sorted properly }
          if srec2^.srec.name < srec3^.srec.name then srec3 := srec2;
          srec2 := srec2^.link;
        until srec2 = nil;
        if srec3 <> srec1 then begin
          srec := srec1^.srec; srec1^.srec := srec3^.srec; srec3^.srec := srec;
        end; srec1 := srec1^.link;
      end;
    end;

  begin
    srec_root := nil; findfirst('*.*', anyfile, srec);
    nodearray^[nodenumber].bid := 0;
    while doserror=0 do begin
      if (((srec.attr and directory)>0) and (srec.name[1]<>'.')) then begin
        if srec_root = nil then begin
          new(srec_root); srec_link := srec_root;
        end else begin
          new(srec_link^.link); srec_link := srec_link^.link;
        end; srec_link^.srec := srec; srec_link^.link := nil;
        srec_link^.prev := prevparent;
      end;
      findnext(srec);
    end; inc(prevparent);
    if srec_root <> nil then begin
      if sort_items then sort(srec_root);
      {
      if (srec_root^.link = nil) and (level = 0) and showscan then __betwscn(
        x3, x4, y3, popup_f, popup_b, '\'
      );
      }
      repeat
        s := srec_root^.srec.name;
        with nodearray^[nodenumber] do begin
          name := s; parent := srec_root^.prev;
        end;
        {
        if showscan then __betwscn(
          x3, x4, y3, popup_f, popup_b, __rep(12, ' ')
        );
        }
        inc(nodenumber);
        {
        if showscan then begin
          __betwscn(x3, x4, y3, popup_f, popup_b,
            __juststr(__num(nodenumber), ' ', 3, _left_just_str) + ' : ' +
            __juststr(s, ' ', 12, _right_just_str)
          );
        end;
        }
        chdir(s); search_tree(level+1); chdir('..');
        srec_link := srec_root; srec_root := srec_root^.link;
        dispose(srec_link);
      until (srec_root = nil); {@}
    end { else if (level = 0) and showscan then __betwscn(
      x3, x4, y3, popup_f, popup_b, 'No <DIR>''s'
    );}
  end; { search_tree }



  procedure trace_tree;
  var oldpath: string;
  begin
    nodenumber := 1; prevparent := 0; new(nodearray);
    getdir(0, oldpath); search_tree(0); chdir(oldpath);
  end;
  {██subtree functions███████████████████████████████}
{$I+}


  procedure dosearch(st: string);
  var searchfn : string;
  begin
    if show then begin
      textcolor(yellow); writeln(st + searchfilename); textcolor(lightgray);
    end;
    findfirst(st + searchfilename, anyfile, dirinfo);
    while doserror = 0 do begin
      nf := false;
      if (
        not(dirinfo.attr in [directory, volumeid]) and (dirinfo.size > 0)
      ) then begin
        searchfn := st + dir + dirinfo.name;
        if show then writeln('  Searching ', dirinfo.name);
        assign(searchfile, searchfn);
        getfattr(searchfile, oldattr); setfattr(searchfile, archive);
{$I-}
        reset(searchfile,1);
{$I+}
        if ioresult<>0 then begin
          writeln('File niet gevonden. Foutje, bedankt!');
          chdir(olddir); halt;
        end;

        longbufpos := 0;
        repeat
          seek(searchfile, longbufpos);
          blockread(searchfile, buffer, maxbuffer, sizeread);
          maxpos := sizeread - ord(target[0]); bufpointer := 0;

          repeat
            i := boyer_moore_search(
              buffer, bufpointer, sizeread,
              target, table1, table2, casesensitive
            );
            if (i > 0) then begin
              bufpointer := i+length(target);
              if redirect then begin
                writeln;
                writeln('▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀');
              end;
              clrscr;
              writeln;
              if i < 80 then b4 := 1 else b4 := i - 80;
              textcolor(cyan); j := b4;
              while (j <= i) and (j < sizeread) do begin
                write(chr(buffer[j])); inc(j);
              end;
              textcolor(white); during := j;
              while (j < sizeread) and (j <= i+length(target)) do begin
                write(chr(buffer[j])); inc(j);
              end;
              textcolor(cyan); after := j;
              while (j < sizeread) and (j < b4+319) do begin
                write(chr(buffer[j])); inc(j);
              end;
              textcolor(white); gotoxy(1, 1);
              write('File: ', searchfn, ' Position: ', longbufpos+i);
              gotoxy(1, 22);
              if not redirect then begin
                writeln; writeln; writeln('Press <RETURN> for next match...');
                write('<Esc> to quit, <N> to skip to next file');
                ch := readkey; if ch=#27 then begin
                  chdir(olddir);  halt(0);
                end;
                if upcase(ch) = 'N' then nf := true;
              end else if keypressed then if readkey = #27 then nf := true;
            end
          until (i = 0) or (bufpointer > maxpos) or (sizeread=0) or nf;
          longbufpos := longbufpos + maxpos;
        until nf or (sizeread < maxbuffer);
        setfattr(searchfile, oldattr); close(searchfile);
      end;
      textcolor(lightgray);
      if keypressed then if readkey = #27 then begin chdir(olddir); halt end;
      findnext(dirinfo);
    end;
  end; { dosearch }



  function __handlfil(var filevar) : word;
  begin
    if (filerec(filevar).mode = fmclosed) then __handlfil := $ffff else
      __handlfil := filerec(filevar).handle
  end;


  function  __isconfil(handle : word) : boolean;
  var reg : registers;
  begin
    with reg do begin
     ah := $44; al := 0; bx := handle; intr($21, reg);
     __isconfil := ((dl and $80) <> 0) and ((dl and $03) <> 0)
    end
  end;


{main}begin
  getdir(0, olddir);
  {commandstr := string(ptr(prefixseg, $80)^);}
  redirect := not __isconfil(__handlfil(output));
  if redirect then begin assign(output, ''); rewrite(output) end;
  textcolor(lightgray);
  if (paramstr(1)='?') or (paramstr(1)='/?') or (paramstr(1)='-?') then help;

  clrscr;
  if paramstr(1) <> '' then begin
    if pos('\', paramstr(1)) > 0 then begin
      searchfilename := __extractname(paramstr(1));
      chdir(__extractpath(fexpand(paramstr(1))));
    end else searchfilename := paramstr(1)
  end else begin
    write('Enter File to search: '); readln(searchfilename); writeln;
  end;
  curdir := fexpand('');
  if paramstr(2) <> '' then target := paramstr(2) else begin
    write('Enter Search text: '); readln(target); writeln;
  end;
  if __inparams('/c') then casesensitive := true else casesensitive := false;
  if __inparams('/d') then show := false;

  make_boyer_moore_table(target, table1, table2, casesensitive);
  writeln; fsplit(searchfilename, dir, name, ext);

  if __inparams('/s') then begin
    textcolor(lightgray); textbackground(black);
    if redirect then begin
      for i := 0 to paramcount do writeln(paramstr(i));
      writeln(searchfilename, ', ', dir, ', ', name, ', ', ext);
      writeln;
    end else begin writeln; write('Tree...') end;
    trace_tree; gotoxy(1, wherey); clreol;
    for nod := 0 to nodenumber-1 do dosearch(
      __backrem(curdir) + __backapp(trace_path(nod))
    );
  end else dosearch('');

  writeln;
  textcolor(black); textbackground(lightgray);
  write('Searches complete...');
  textcolor(lightgray); textbackground(black);
  writeln; chdir(olddir);
{happy}end.

{
  best regards, mark ouellet.
  stuck with a virus, anyone heard of windows ??? (fidonet 1:240/1.4)
}