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

Pascal/Delphi Source File | 1989-07-01 | 19.3 KB | 633 lines

 {$Define RAM}

 { undefine above symbol to use virtual array
         for debugging in IDE }

 {$IFDEF RAM}
   Uses Dos,TPDos,
     TPInline,TPString,TPDate,TPRArray,TPMemchk;
 {$ELSE}
   Uses Dos,TPDos,
     TPInline,TPString,TPDate,TPVArray,TPMemChk;
 {$ENDIF}

 const
   NoDate   : longint = $0;
   DriveLetter : char = #0;
   FileMask : byte = Directory;
   { used to set sector buffer size }
   MaxSectorSize  = 2048;
   { must be 1/2 of above }
   MaxWordSize   =  MaxSectorSize div 2;
   { MaxSectorSize div 32 }
   MaxEntry = MaxSectorSize div 32;
   { used to hold files for
     matching cluster search }
   MaxDirEntry  = 150;
   Verbose: boolean = False;

 {$IFNDEF RAM}
   DeleteArray : boolean = true;
   { set path and file name virtual array }
   FatWName: string = 'c:\FatW.dta';
   FatBName: string = 'c:\FatB.dta';
 {$ENDIF}

 type

   { holds entries found by findfirst
     to be used in matching directory entries }
   DataPtr  = ^DataRec;
   DataRec  =  string[12];
   Searchtype = (Root,Cluster);

   SearName = object
         FName : array[1..MaxDirEntry] of DataPtr;
         MatchFound : word;
         function PrepFileName(SearDir :String) : String;
         procedure DirFind;
         procedure ShowVerbose(SearDir :String ; Fattr :byte);
      end;

   DirRec   =
      record
        FileNameExt  : array[1..11] of char;
        FileAttr     : byte;
        DirResv      : array[1..10] of byte;
        TimeDate     : longint;
        StartCluster : word;
        FileSize     : longint;
      end;

   BootRec   =
      record
        Junk             : array[1..3] of byte;
        OEM              : array[1..8] of char;
        BytePerSector    : word;
        SectorPerCluster : byte;
        ReservedSectors  : word;
        NumOfFats        : byte;
        RootDirEntries   : word;
        TotalSectors     : word;
        Media            : byte;
        SectorsPerFat    : word;
        SectorPerTrack   : word;
        NumOfHeads       : word;
        NumHiddenSectors : word;
      end;

 var
   SName       : SearName;
   DirBuffer   : array[1..MaxEntry] of DirRec;
   BootEntry   : BootRec;
   FatBits     : byte;
   PakTime     : longint;
   DirTime     : DateTime;
   VerboseDate : DateString;
   VerboseTime : DateString;
   TpBArr      : TpArray;
   TpWArr      : TpArray;
   SearchMode  : SearchType;
   DirChanged,
   RootBegin,RootEnd,
   FatBegin,FatEnd,
   EntryPerSector,
   ClustersAvaiable,
   TotalClusters,
   BytesPerSector,
   SectorsPerClusters :Word;

  function IsWholeNumber(Check :real): Boolean;
  var
    x : Longint;
    y : real;
  begin
    X:=Trunc(Check);
    y:=X;
    IsWholeNumber := Y = Check;
  end; { function IsWholeNumber }

  function ReadBootRecord: boolean;
  var
    DriveNumber        : byte;
    GetInfo,GetBoot    : boolean;
    BootBuffer         : array[1..MaxSectorSize] of byte;
  begin
      FillWord(BootBuffer, SizeOf(BootBuffer) div 2,Word(0));
      DriveNumber := Ord(DriveLetter)-64;
      GetInfo := GetDiskInfo(DriveNumber,ClustersAvaiable,TotalClusters,
          BytesPerSector,SectorsPerClusters);
      {$B+}
      if Not GetInfo or (BytesPerSector > MaxSectorSize) then
      {$B-}
         begin
           ReadBootRecord:=False;
           exit;
         end;
      EntryPerSector:= BytesPerSector div 32;
      GetBoot:= ReadDiskSectors(DriveNumber-1,0,1,BootBuffer);
      if Not GetBoot then
         begin
           ReadBootRecord:=False;
           exit;
         end;
      Move(BootBuffer,BootEntry,Sizeof(BootEntry));
      With BootEntry do begin
          FatBegin := ReservedSectors;
          FatEnd   := FatBegin + SectorsPerFat - 1;
          RootBegin:= ReservedSectors + (NumOfFats * SectorsPerFat);
          RootEnd  := RootDirEntries * 32 div BytePerSector + RootBegin - 1;
        end;
      ReadBootRecord := GetInfo and GetBoot;
  end; { function ReadBootRecord }

  function Cluster2Sector(Cluster: Word): Word;
  begin
     Cluster2Sector := ((Cluster - 2) *
         BootEntry.SectorPerCluster) + RootEnd + 1;
  end; { function Cluster2Sector }

  { convert standard file name to DOS storage format }
  function SearName.PrepFileName(SearDir :String):String;
  var
    Dir   : DirStr;
    Name  : NameStr;
    Ext   : ExtStr;
  begin
    If (SearDir = '.') or (SearDir = '..') then
      PrepFilename:=Pad(SearDir,11)
    else
       begin
         Fsplit(SearDir,Dir,Name,Ext);
         Dir:=Pad(Name,8)+Pad(Ext,4);
         { remove dot from name }
         Delete(Dir,9,1);
         PrepFileName:=Dir;
       end;
  end; { function PrepFileName }

  { check if search file name matches directory entry }
  function FoundMatch(SearDir :String;Ndx :word):Boolean;
  begin
    FoundMatch:=CompStruct(SearDir[1],DirBuffer[Ndx].FileNameExt,11)=Equal;
  end; { function FoundMatch }

  {$I cluster.inc}

  procedure SearName.ShowVerbose(SearDir :String ; FAttr :Byte);
  begin
    Insert(' ',SearDir,9);
    If FlagIsSet(FAttr,VolumeID) then
      Writeln(SearDir,' <VOL>     ',VerboseDate,'  ',VerboseTime)
    else if FlagIsSet(FAttr,Directory) then
      Writeln(SearDir,' <DIR>     ',VerboseDate,'  ',VerboseTime)
    else
      Writeln(SearDir,' <FIL>     ',VerboseDate,'  ',VerboseTime)
  end; { procedure ShowVerbose }

  procedure CalcFatBits;
  const
    BreakPoint : word = 4087;
  Var
    DosVer : word;
    DosLo,DosHi :byte;
  begin
    DosVer := TpDos.DOSVersion;
    DosHi := Hi(DosVer);
    If (DosVer < $0200) or (DosVer > $031E) then
      begin
        Writeln('DOS version ',DosHi,'.',Lo(DosVer),' unsupported');
        halt(1);
      end;
    {$B+}
    If (DosHi < $03) or
       ((DosHi = $03) and (TotalClusters < BreakPoint)) then
      FatBits := 12
    else
      FatBits := 16;
    {$B-}
  end; { procedure FatBits }

  procedure BuildArray;
  begin
    {$IFDEF RAM}
      MakeA(TpWArr,$FFFF,1,Sizeof(Word));
      If Fatbits=12 then
         MakeA(TpBArr,$FFFF,1,Sizeof(byte));
    {$ELSE}
       MakeA(TpWArr,$FFFF,1,Sizeof(Word),FatWName,$FFFF);
       If Fatbits=12 then
          MakeA(TpBArr,$FFFF,1,Sizeof(byte),FatBName,$FFFF);
    {$ENDIF}
  end; { procedure BuildArray }

  procedure GetFat;
  Var
    FatBufferW  : array[1..MaxWordSize] of word;
    FatBufferB  : array[1..MaxSectorSize] of byte absolute FatBufferW;
    DriveNumber : byte;
    Start,Ndx,
    FatRead     : word;
  begin
    Start:=0;
    DriveNumber := Ord(DriveLetter)-65;
    for FatRead := FatBegin to FatEnd do
       begin
         FillWord(FatBufferW, (Sizeof(FatBufferW) div 2),Word(0));
         If Not ReadDiskSectors(DriveNumber,FatRead,1,FatBufferW) then
           begin
             Writeln('error reading fat table');
             halt(1);
           end;
         case fatbits of
           12 : begin
                  for Ndx:= 1 to BytesPerSector do
                    begin
                      SetA(TpBArr,Start,0,FatBufferB[Ndx]);
                      inc(Start);
                    end;
                end;
           16 : begin
                  For Ndx:= 1 to (BytesPerSector div 2) do
                    begin
                      SetA(TpWArr,Start,0,FatBufferW[Ndx]);
                      inc(Start);
                    end;
                end;
         end; { case fatbits }
       end;
  {$IFNDEF RAM}
      If Fatbits=12 then
         FlushA(TpBArr);
      FlushA(TpWArr);
  {$ENDIF}
  end; { procedure GetFat }

  { converts 12 bit entries to words }
  procedure CookTheFat;
  Var
    ByteLocR   : Real;
    ByteLocL   : longint;
    ClusterNum : Word;
    WorkWord   : Word;
    Workbyte   : Array[1..2] of byte Absolute WorkWord;
  begin
    CalcFatBits;
    BuildArray;
    GetFat;
    case fatbits of
      12 : Begin
             For ClusterNum := 2 to TotalClusters do
               begin
                 ByteLocR:= ClusterNum * 1.5;
                 BytelocL := Trunc(BytelocR);
                 RetA(TpBArr,BytelocL+0,0,Workbyte[1]);
                 RetA(TpBArr,BytelocL+1,0,Workbyte[2]);
                 If IsWholeNumber(BytelocR) then
                   WorkWord:=WorkWord and 4095
                 else
                   WorkWord:=WorkWord SHR 4;
                 SetA(TpWArr,ClusterNum,0,WorkWord);
               end;
           end;
      16 : {}
    end; { case fatbits }

    { done with 12 bit entries }
    {$IFDEF RAM}
       If Fatbits=12 then
         DisposeA(TpBArr);
    {$ELSE}
       If Fatbits=12 then
         DisposeA(TpBArr,DeleteArray);
       FlushA(TpWArr);
    {$ENDIF}
  end; { procedure CookTheFat }

  procedure TimeAndDate;
  const
    Done        : boolean = False;
    NeedToWrite : boolean = False;
  var
    DirNdx,StartPoint,
    SectorNumber,
    SectorCount,
    CurrentEntry,
    FatReturned,
    CurrentCluster : word;
    DriveNumber    :byte;
  begin
    DriveNumber := Ord(DriveLetter)-65;
    { comes from include to locate starting
      cluster number for searching FAT table}
    CurrentCluster := ClusterNumber;
    StartPoint:=1;
    SectorCount:=1;
    DirChanged:=0;
    FatReturned:=0;
    { include set search mode }
    Case SearchMode of
       Cluster: SectorNumber := Cluster2Sector(CurrentCluster);
          Root: SectorNumber := RootBegin;
    end; { case searchmode }
    Repeat
      FillWord(DirBuffer,SizeOf(DirBuffer) Div 2,Word(0));
      If not ReadDiskSectors(DriveNumber,SectorNumber,1,DirBuffer) then
        begin
          Writeln('error ',DosError,' reading sector ',SectorNumber);
          DosError:=0;
          exit;
        end;
      for CurrentEntry := 1 to EntryPerSector do
        begin
          { check for end of directory }
          If DirBuffer[CurrentEntry].FileNameExt[1]=#0 then Done:=True;
          If FlagIsSet(DirBuffer[CurrentEntry].FileAttr,FileMask) then
            begin
              { scan list for matching entry }
              for DirNdx := StartPoint to SName.MatchFound do
                begin
                  If FoundMatch(SName.Fname[DirNdx]^,CurrentEntry) then
                    Begin
                      DirBuffer[CurrentEntry].TimeDate:=PakTime;
                      If Verbose then Sname.ShowVerbose(Sname.FName[DirNdx]^,
                          DirBuffer[CurrentEntry].FileAttr);
                      Inc(DirChanged);
                      { found match set start point }
                      StartPoint:=DirNdx+1;
                      { set to update sector }
                      NeedToWrite:=True;
                    end;
                end;
            end;
        end;
      If NeedToWrite then
        begin
          If not WriteDiskSectors(DriveNumber,SectorNumber,1,DirBuffer) then
             begin
                Writeln('error ',DosError,' writing sector ',SectorNumber);
                DosError:=0;
                Exit;
             end;
          NeedToWrite:=False;
        end;
      { process all sector or get next cluster }
      Case SearchMode of
         Cluster:Begin
                   If SectorCount >= SectorsPerClusters then
                      begin
                        RetA(TpWArr,CurrentCluster,0,FatReturned);
                        CurrentCluster:=FatReturned;
                        SectorNumber := Cluster2Sector(FatReturned);
                        SectorCount:=1;
                      end
                   else
                      begin
                        Inc(SectorNumber);
                        Inc(SectorCount);
                      end;
                   { check for last cluster in chain }
                   case fatbits of
                     12 : if FatReturned >= $0FF8 Then Done:=True;
                     16 : if FatReturned >= $FFF8 Then Done:=True;
                   end; { case fatbits }
                 end;
            Root:Begin
                   inc(SectorNumber);
                   { check for last entry in root directory }
                   If SectorNumber > RootEnd then Done:=True;
                 end;
       end; { case searchmode }
    Until Done;
  end; { procedure TimeAndDate }

  { search directory for file spec to match }
  Procedure SearName.DirFind;
  var
    DirInfo       : SearchRec;
    SearStr       : DirStr;
    FileMaskName  : NameStr;
    FileMaskExt   : ExtStr;
  begin
    MatchFound:=0;
    DriveLetter:=DefaultDrive;
    FSplit(ParamStr(1),SearStr,FileMaskName,FileMaskExt);
    SearStr := FileMaskName + FileMaskExt;
    { must be in root to change VolumeID }
    If FileMask=VolumeID then
      begin
        {$I-}
        ChDir(DriveLetter+':\');
        {$I+}
        If IOResult=0 then {};
      end;
    { check for dot entries in filespec }
    If (SearStr = '.') or (SearStr = '..') then
       begin
         inc(MatchFound);
         If Not GetMemCheck(FName[MatchFound],Sizeof(DataRec)) then
            begin
              MatchFound:=0;
              exit;
            end;
         Fname[MatchFound]^:=PrepFileName(SearStr);
         exit;
       end;
    FindFirst(SearStr,FileMask,DirInfo);
    While DosError = 0 do
      begin
        If FlagIsSet(DirInfo.Attr,FileMask) then
          begin
            inc(MatchFound);
            if (MatchFound > MaxDirEntry) then
              begin
                Writeln('Will only process first ',MaxDirEntry,' entries.');
                Dec(MatchFound);
                exit;
              end;
            If Not GetMemCheck(FName[MatchFound],Sizeof(DataRec)) then
              begin
                Dec(MatchFound);
                exit;
              end;
            Fname[MatchFound]^:=PrepFileName(DirInfo.Name);
          end;
        FindNext(DirInfo);
      end;
  end;

  { flush dos buffers
    to see changes }
  procedure ResetDir;
  var
    reg : registers;
  begin
    reg.ah:=$0D;
    Msdos(reg)
  end;

  procedure Clock;
  var
    sec100,
    dayofWeek : word;
  begin
    Fillchar(DirTime,Sizeof(DirTime),0);
    with DirTime do
      begin
        GetTime(hour,min,sec,sec100);
        GetDate(year,month,day,dayofweek);
      end;
  end;{ procedure Clock }

  Procedure ShowHelp;
  begin
    Writeln('DD-Directory Date, Version 1.1, (C) Copr 1989, Ted Stephens');
    Writeln;
    Writeln('    DD filespec [switches]');
    {$IFNDEF RAM}
       Writeln;
       Writeln('    VIRTUAL MODE ');
    {$ENDIF}
    Writeln;
    Writeln('Switches');
    Writeln('    /D[mm-dd-yy]  Set the date to [month-day-year]');
    Writeln('    /T[hh:mm:ss]  Set the time to [hour:minute:second]');
    Writeln('    /N            Eliminate time & date stamp');
    Writeln('    /V            Verbose listing of changes');
    Writeln('    /SD           Select only directories (default)');
    Writeln('    /SF           Select only files');
    Writeln('    /SV           Select only volume label');
    Writeln('    /SA           Select all directory entries');
    Writeln;
    Writeln('Running DD without /D and /T will stamp the current');
    Writeln('date and time on all entries matching the file specified');
    halt(1);
  end;

  procedure CheckCommand;
  const
    DateOut :boolean = False;
  var
    ParamS : string;
    myhr,mymin,mysec :byte;
    TimeWork  : time;
    i,myday,mymonth,myyear  : integer;
  begin
    if ParamCount = 0 then ShowHelp; { no switches }
    Clock; { set directory time and date to dos }
    for i := 2 TO ParamCount DO
       begin
         ParamS := StUpCase(ParamStr(i));
         If ParamS[1] = '/' Then
           case ParamS[2] OF
             'D' : begin
                     ParamS:=Copy(ParamS,3,8);
                     If DateStringToDMY('mm/dd/yy',
                          ParamS,myday,mymonth,myyear) then
                            begin
                              { date cannot be less than 1-1-80 }
                              If myyear in [80..99] then
                                 With DirTime do
                                   begin
                                     Year := 1900+myyear;
                                     month:= mymonth;
                                     day  := myday;
                                   end
                              else
                                ShowHelp; { invalid date }
                            end
                     else
                       ShowHelp; { bad date format }
                   end;
             'S' : begin
                     Case ParamS[3] OF
                        'F' : FileMask:=AnyFile-Directory-VolumeID;
                        'A' : FileMask:=AnyFile;
                        'D' : FileMask:=Directory;
                        'V' : FileMask:=VolumeID;
                     else
                       ShowHelp; { bad switch character }
                     end;
                   end;
             'T' : begin
                     ParamS:=Copy(ParamS,3,8);
                     If Length(ParamS) = 8 then
                        begin
                          TimeWork:=TimeStringToTime('hh:mm:ss',ParamS);
                          If (TimeWork=BadTime) then ShowHelp;
                          If (TimeWork=0) and (ParamS<>'00:00:00') then ShowHelp;
                          TimeToHMS(TimeWork,myHr,mymin,mysec);
                          With DirTime do
                            begin
                              hour:= myhr;
                              Min := mymin;
                              Sec := mysec;
                            end;
                        end
                     else
                       ShowHelp; { bad time format }
                   end;
             'V' : Verbose:=True;
             'N' : DateOut:=True;
           else
             ShowHelp; { bad switch character }
           end { case params }
         else
            ShowHelp; { bad switch character }
       end; { for i }
       If Verbose then
         begin
           With DirTime do
             begin
               VerboseDate:=DMYtoDateString('Mm-dd-yy',day,month,year);
               TimeWork:=HMSToTime(hour,min,sec);
               If TimeWork=0 then
                 VerboseTime:='no time'
               else
                 VerboseTime:=TimeToAmPmString('Hh:mmt',TimeWork);
             end;
         end;
       If DateOut then
         begin
           VerboseDate:=' no date';
           VerboseTime:='no time';
           PakTime:=NoDate;
         end
       else
         Packtime(DirTime,PakTime);
    SName.DirFind; { find matching files }
  end; { procedure CheckCommand }

  { main processing }
  begin
    CheckCommand;
    If SName.MatchFound=0 then
       begin
         Writeln(' ');
         Writeln('no directory entries found');
         halt(1);
       end;
    If Not ReadBootRecord then
       begin
         Writeln(' ');
         Writeln('error reading drive');
         halt(1);
       end;
     CookTheFat;
     TimeAndDate;
     If DirChanged >0 then
       begin
         Writeln(' ');
         If DirChanged=1 then
           Writeln(DirChanged,' directory entry restamped')
         else
           Writeln(DirChanged,' directory entries restamped');
         ResetDir;
       end;
     {$IFDEF RAM}
         DisposeA(TpWArr);
     {$ELSE}
         DisposeA(TpWArr,DeleteArray);
     {$ENDIF}
  end.