Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/GF100.ZIP/GF.PAS

Pascal/Delphi Source File | 1988-11-05 | 6.7 KB | 215 lines

uses crt,dos;

  type
    dtstr = string[20];
    attrstr = string[6];
    str2 = string[2];

  var
    lcount,fcount : word;
    fsize : longint;
    path,origpath,mask : string;
    sdrive : str2;
    ch : char;

  procedure docopyright;
    begin
      writeln('GF - Get File, (C) Copyright 1988, Basil Groman',#10)
    end;

  procedure init;

   (*  Initializes Variables *)

    var
      test : integer;
    begin
      fcount := 0;
      lcount := 25-whereY;
      fsize := 0;
      getdir(0,path);
      test := pos(':',mask);
      if test <> 0 then          { If a particular drive was specified }
        begin
          sdrive := copy(mask,pred(test),2);
          delete(mask,1,2);
        end
      else                       { Else use current drive }
        sdrive := copy(path,pred(pos(':',path)),2);
      sdrive[1] := upcase(sdrive[1]);
    end;

  function PadZero(num : integer):str2;

    (* Takes an integer value and returns a 2 character string )
    (  with the first character a '0' if the number was less   )
    (  than 10.  This function only works with numbers with 2  )
    (  digits or less.                                        *)

    var
      temp : str2;
    begin
      str(num:2,temp);
      if num < 10 then
        temp[1] := '0';
      PadZero := temp;
    end;

  function timedate(it:longint):dtstr;
    (* This function takes the value returned in SearchRec.Time )
    (  and fills a string with Time and Date information to be  )
    (  displayed on the screen.                                *)
    var
      dt : datetime;
      temp : dtstr;
    begin
      unpacktime(it,dt);
      with dt do
        timedate := PadZero(hour)+':'+PadZero(min)+':'+PadZero(sec)+'   '+
                PadZero(month)+'/'+PadZero(day)+'/'+PadZero(year-1900);
    end;

  function attributes(attr : byte):attrstr;
    (* This function takes the value in SearchRec.Attr and fills )
    (  a string with attribute information to be displayed on    )
    (  the screen.                                              *)
    var
      temp : attrstr;
    begin
      temp := '      ';
      if attr and $01 <> 0 then
        temp[1] := 'R'
      else
        temp[1] := '-';
      if attr and $02 <> 0 then
        temp[2] := 'H'
      else
        temp[2] := '-';
      if attr and $04 <> 0 then
        temp[3] := 'S'
      else
        temp[3] := '-';
      if attr and $08 <> 0 then
        temp[4] := 'V'
      else
        temp[4] := '-';
      if attr and $10 <> 0 then
        temp[5] := 'D'
      else
        temp[5] := '-';
      if attr and $20 <> 0 then
        temp[6] := 'A'
      else
        temp[6] := '-';
      attributes := temp;
    end;

  procedure incrline;
    (* This procedure keeps track of how many lines have have been )
    (  written to the screen and pauses when screen is full.      *)
    begin
      inc(lcount);
      if lcount > 23 then               { If screen is full }
        begin
          write('   <--- More --->');
          ch := readkey;                { Pause til key is pressed }
          if ch = #27 then              { If <Esc> was pressed }
            begin                       { allow user to stop program }
              writeln(#10,fcount,' files found at ',fsize,' total bytes');
                            { ^  Tell what it's found so far ^ }
              halt(0);             { Stop  program }
            end;
          writeln;           { Otherwise business as usual }
          lcount := 0
        end;
    end;

  procedure writeEntry(srec :searchrec);
    (* This procedure formats the File info returned in SearchRec )
    (  and writes the line to the screen.                        *)
    begin
      write('','   ',srec.name);
      gotoxy(20,whereY);
      if srec.attr and $18 = 0 then
        writeln('',srec.size : 7,' bytes     ',timedate(srec.time),
                '    ',attributes(srec.attr))
      else
        if srec.attr and $10 <> 0 then
          writeln('','< DIR >':13,'     ',timedate(srec.time),
                '    ',attributes(srec.attr))
        else
          writeln('','<Volume_ID>':13,'     ',timedate(srec.time),
                '    ',attributes(srec.attr));
      incrline
    end;

  procedure getfiles(path,mask : string);
    (* This procedure finds all files in a directory matching the )
    (  mask and lists them on the screen.                        *)
    var
      srec : searchrec;
      ch : char;
    begin
      if path <> '' then                       { If Root Directory }
        findfirst(sdrive+'\'+path+'\'+mask,$FF,srec)
      else                                     { Any Other Directory }
          findfirst(sdrive+path+'\'+mask,$FF,srec);
      if doserror = 0 then
        begin
          writeln;
          incrline;
          writeln(sdrive+'\'+path);          { Directory being searched }
          incrline
        end;
      while doserror = 0 do                  { List Files }
        begin
          inc(fcount);
          inc(fsize,srec.size);
          writeEntry(srec);
          findnext(srec);
        end;
    end;

  procedure finddirs(path : string;mask:string);
    (* This procedure finds all directories and searches for )
    (  files in each that match mask.                       *)
    var
      srec : searchrec;
      temp : string;
    begin
      findfirst(sdrive+'\'+path+'*.',$12,srec);   {  Find first Dir }
      while doserror = 0 do
        begin
          if (srec.name <> '.') and (srec.name <> '..') and
             ((srec.attr and $12) <> 0) then      {  If a New Dir }
            begin
              temp := path+Srec.name;
              getfiles(temp,mask);         { Check for mask matching files }
              finddirs(temp+'\',mask);        { Recursive call to find }
                                              { other directories in this}
                                              { one}
            end;
          findnext(srec);
        end;
    end;

         {  \/      Main  Program     \/ }
  begin
    docopyright;
    if paramcount <= 0 then          {  If no parameters were specified }
      begin
        write ('Enter Search Spec: ');
        readln(mask);
      end
    else                             { Else go ahead }
      mask := paramstr(1);
    init;
    writeln('Searching Drive -> ',sdrive);
    getfiles('',mask);               { Check Root Directory }
    finddirs('',mask);               { Check the rest       }
    if fcount <> 0 then
      writeln(#10,fcount,' files found at ',fsize,' total bytes')
    else
      writeln(#10,'No files found');
  end.