Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/BU4DIR.ZIP/BU4DIR.PAS

Pascal/Delphi Source File | 1990-06-14 | 6.8 KB | 282 lines

Program BU4DIR(Input, Output);

Uses Dos;

Const
    Maxlinelength        = 80;
    Maxpath              = 63;
    test0                = false;
    test1                = false;

    {$I-}

Type LineType            = Packed Array[1..Maxlinelength] of char;
     LengthType          = 0..Maxlinelength;
     Pathtype            = String[maxpath];
     String2             = String[2];
     String3             = Packed Array[1..3] of char;
     String8             = Packed Array[1..8] of char;
     String12            = Packed Array[1..12] of char;
     String15            = String[15];

Var
     position            : Longint;
     ch, eoname          : char;
     disknumber,
     startdisk           : word;
     path                : pathtype;
     pathctr, length     : byte;
     filename            : String12;
     filesize,
     sizethisdisk,
     fileoffset,
     filedate            : longint;
     fileattr            : word;
     infile              : file;
     infdt, filedt       : datetime;
     infdatestring       : String8;
     outfile             : text;
     filein              : String15;
     Drive               : String2;
     dirinfo             : Searchrec;
     Line                : LineType;
     m1,m2,t             : char;
     a,b,c,e,f,y         : byte;
     fileoutput          : boolean;
(******************************************************)
PROCEDURE GETCHAR(VAR CHR: char);
Begin
  If not eof(infile) then
    begin
      Blockread(infile,chr,1);
      inc(position);
      dec(length);
    end;
End;
(******************************************************)
PROCEDURE BreadWord(VAR buf: word);
Begin
  If not eof(infile) then
  begin
    Blockread(infile,buf,2);
    inc(position,2);
    dec(length,2);
  end;
End;
(******************************************************)
PROCEDURE BreadLongint(VAR buf: longint);
Begin
  If not eof(infile) then
  begin
    Blockread(infile,buf,4);
    inc(position,4);
    dec(length,4);
  end;
End;
(*****************************************************)
Procedure ClearPath;
Var p : byte;
Begin
  for p := 1 to maxpath DO path[p] := ' ';
End;
(*****************************************************)
Procedure Clearname;
Var p : byte;
Begin
  for p := 1 to 12 DO filename[p] := ' ';
End;
(*****************************************************)
Procedure WritePath;
Var p : byte;
    forty : boolean;
Begin
  Write('\');
  if pathctr > 39 then forty := true else forty := false;
  if pathctr > 0 then
  Begin
  for p := 1 to pathctr DO
    begin
      Write(path[p]);
      if (p > 27) and forty and (path[p] = '\') then
        begin
          Writeln;
          Write('':41);
          forty := false;
        end;
    end;
  Write('\');
  End;
End;
(*****************************************************)
Procedure WriteName;
Var p, q, r : byte;
Begin
  p := 0;
  r := 0;
  While r < 12 DO
  Begin
    inc(p);
    if (filename[p] = '.')
      then For q := p to 9 do
           begin
             write(' ');
             inc(r);
           end
      else begin
             write(filename[p]);
             inc(r);
           end;
  End;
End;
(*****************************************************)
Procedure Writedate(d : datetime);
Begin
  If d.month > 9 then Write(d.month,'-') else Write('0',d.month,'-');
  If d.day > 9 then Write(d.day) else Write('0',d.day);
  Write('-',(infdt.year mod 100),'  ');
  Write((d.hour mod 12):2,':');
  If d.min > 9 then Write(d.min) else Write('0',d.min);
  If d.hour > 12 then Write('p') else Write('a');
End;
(*****************************************************)
Procedure Writeline;
Begin
  Writename;
  Write(filesize:10);
  Write(' ');
  Writedate(filedt);
  Write(' ');
  WritePath;
  Writeln;
End;
(****************************************************)
PROCEDURE GetPath;
Begin
  Clearpath;
  length := ord(ch);
  pathctr := 0;
  getchar(ch);
  While (ord(ch) >  32) and (ord(ch) <= 126) Do
  Begin
    inc(pathctr);
    path[pathctr] := ch;
    getchar(ch);
  End;
  While length > 0 do Getchar(ch);
  {
  Writeln;
  WritePath;
  Writeln;
  }
End;
(****************************************************)
PROCEDURE GetName;
Begin
  if ord(ch)<>34 then Writeln('File info length <> 34, is ',ord(ch));
  Blockread(infile,filename,sizeof(filename));
  inc(position,12);
  dec(length,12);
End;
(****************************************************)
PROCEDURE GetFile;
Var z : byte;
Begin
  length := ord(ch);
  Getname;
  Getchar(eoname);
  Breadlongint(filesize);
  BreadWord(startdisk);
  Breadlongint(fileoffset);
  Breadlongint(sizethisdisk);
  BreadWord(fileattr);
  BreadLongint(filedate);
  While length > 0 do if not eof(infile) then Getchar(ch) else dec(length);
End;
(****************************************************)
PROCEDURE GetDiskNumber;
Var z : byte;
Begin
  length := 1;
  Getchar(ch);
  length := ord(ch);
  For z:= 2 to 9 Do Getchar(ch);
  BreadWord(disknumber);
  While length > 0 do Getchar(ch);
  Writeln('Directory of Backup Disk ',Disknumber);
  Write('Files backed up ');
  Writedate(infdt);
  Writeln;
  Writeln;
End;
(*****************************************************)
Procedure Listdir(Var controlname: String15);
Begin
   Writeln;
   GetDiskNumber;
   While not eof(infile) Do
   begin
     If ord(ch) > 40 then Getpath else
     begin
       GetFile;
       unpacktime(filedate,filedt);
       Writeline;
     end;
   end;
   Writeln;
End;
(*****************************************************)
Procedure GetInfile;
Var y: integer;
    ss : string2;
Begin
  drive := paramstr(1);
  if pos(':',drive) = 0 then drive := drive + ':';
  filein := drive + '\' + 'CONTROL.*';
  findfirst(filein,$21,dirinfo);
  filein := drive+dirinfo.name;
  assign(infile,filein);
  SetFattr(infile, 0);
  Reset(infile,1);
  Unpacktime(dirinfo.time, infdt);
End;
(*****************************************************)
Procedure CloseInfile;
Begin
  close(infile);
  SetFattr(infile, dirinfo.attr);
End;
(*****************************************************)
Procedure NoParms;
Begin
  Writeln;
  writeln('BU4DIR Version 1.0  (C) Curt Freeman 6-14-90');
  Writeln('USAGE: BU4DIR d:');
  Writeln('Gives dir of Dos 4.0x Backup disk from Control.nnn file');
  Writeln;
  halt(0);
end;
(*****************************************************)
Procedure TwoParms;
begin
  assign(outfile,paramstr(2));
  Rewrite(Outfile);
  fileoutput := true;
end;
(*****************************************************)
Procedure Initialize;
Begin
  position := 0;
End;
(*****************************************************)
BEGIN   {MAIN}
if paramcount < 1 then NoParms;
if paramcount > 1 then TwoParms;
Initialize;
Getinfile;
if Doserror = 0 then
begin
  listdir(filein);
end;
halt(0);
end.