RBBS in a Box Volume 1 #2/RBBS_vol1_no2.iso/050z/listwild.pas

Pascal/Delphi Source File | 1985-11-17 | 6KB | 245 lines

{This program accesses files using command line wild-cards. It works
 with MS-DOS (or PC-DOS) versions 1 and 2. }

{As Published in "Turbo Pascal Corner" in
                  Micro/Systems Journal
                  November/December 1985 issue}

{Copyright 1985 by David W. Carroll}
{All commercial rights reserved.}

{This program can be used as a form for programs which must process
 a group of files specified by wild card characters. Just substitute
 your file processing procedure for the function "LISTPROC" and use
 a heading similar to:
               function listproc(fname:strtype) : byte;
 "fname" will contain each file name found to match the specified mask
 and your function should return 0 if no error otherwise an error code.}

{This program and some 300+ other programs are available on:
            The High Sierra RBBS-PC
                209-296-3534
}

program listwild;

type
  regpack = record
              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;

  fcbarray =    array[0..36] of char;
  strtype  =    string [14];
  comstr   =    string[127];


const
   getdta =       $1a;
   get1stdir =    $11;
   getnextdir =   $12;
   parsename =    $29;

var
  buffer  : comstr;
  comline : comstr absolute cseg:$80;
  inch    : char;
  filestr,
  filename: strtype;
  dfcb,
  dta,
  dta2    : fcbarray;
  user_input : boolean;

function listproc(fname:strtype) : byte;

const
  lines_per_page = 66;
  chars_per_line = 79;
  bottom_margin = 8;
var
  infile       :  text;
  time1,
  date1        :  string[8];
  infname      :  string[20];
  max_lines    :  integer;
  goodfile     :  boolean;


procedure open_file;
const
  bell = 07;

begin
    infname := fname;
    assign(infile,infname);
    {$I-} reset(infile) {$I+};
    goodfile := (IOresult = 0);
    if not goodfile then
    begin
      write (chr(bell));
      writeln ('FILE ',infname,' NOT FOUND');
      delay(2000)
    end;
end;

procedure list;
var
  p,
  line  : integer;
  txtline,
  printline  : string[255];

procedure print_heading(page:integer);
const
  space = ' ';
begin
  if page <> 1 then writeln(lst,chr(12));
  write(lst,'File: ',infname,space:(60-(5+length(infname))));
  writeln(lst,'Page #',page:3);
  writeln(lst);
  writeln(lst);
end;

begin     {list}
  p := 0;
  while not eof(infile) do
  begin
    p := p + 1;
    print_heading(p);
    line := 4;
    while (not eof(infile)) and (line < max_lines) do
    begin
      readln(infile,txtline);
      writeln(lst,txtline);
      line := line + 1;
    end;
  end;
  writeln(lst,chr(12));    {form feed}
end;     {list}

begin     {listproc}
  max_lines  := lines_per_page - bottom_margin;
  open_file;
  if goodfile then
  begin
    list;
    close(infile);
    listproc := 0;    {no error}
    writeln;
    writeln(' - listing done -');
  end
  else
    listproc := 1;    {error code}
end;    {listproc}

procedure setDTA(num:byte);      {set Disk Transfer Address}
var
  regs:       regpack;

begin
  with regs do begin
    ah := getdta;
    case num of
    1:  begin
         ds := seg(dta);
         dx := ofs(dta);
        end;
    2:  begin
         ds := seg(dta2);
         dx := ofs(dta2);
        end;
    end;
    MSDOS(regs)
  end
end; {setDTA}

procedure calldir(calltype : byte; var errflag : byte);
var
  regs:       regpack;

begin
  with regs do begin
    ah := calltype;
    cx := 0;
    ds := seg(dfcb);
    dx := ofs(dfcb);
    MSDOS(regs);
    errflag:= al
  end
end; {calldir}

procedure parse(var errflag:byte);
var
  regs : regpack;
begin
  with regs do begin
    ah := parsename;
    ds := seg(buffer[1]);
    si := ofs(buffer[1]);
    es := seg(dfcb);
    di := ofs(dfcb);
    al := $0F;
    MSDOS(regs);
    errflag := al;
  end;
end;  {parse}

procedure find;
const
  space  = ' ';
  period = '.';
var
   i,
   err:    byte;

begin
  for i := 0 to 36 do dfcb[i] := chr(0);
  if not user_input then
    writeln('Search mask: ',buffer:15);
  writeln;
  parse(err);
  setDTA(1);                          { set 1st DTA for get func.}
  calldir(get1stdir, err);            { get first entry matching mask }
  while err = 0 do
  begin
    filename:= '';
    for i:= 1 to 11 do
    begin
      if dta[i] <> space then
        filename := filename + dta[i];
      if i = 8 then filename := filename + period;
    end;
    writeln(filename);
    setDTA(2);                        { set 2nd DTA for file processing }
    err := listproc(filename);        { process file }
    if err = 0 then
    begin
      setDTA(1);
      calldir(getnextdir, err);          { get next entry }
    end;
  end;
  writeln;
end; {find}

begin  {listwild}
  buffer := comline;
  user_input := false;
  writeln('Wild card program lister');
  writeln('This program formats and lists all specified files on the');
  writeln('default drive to the system printer.');
  writeln;
  if length(buffer) < 1 then
  begin
    write('Enter search mask: ');
    readln(buffer);
    user_input := true;
  end;
  if length(buffer) > 0 then
    find
  else
    writeln('Program Terminated');
end.   {listwild}