PC Welt 1999 December/PCWELT_CD.ISO/software/hw/platte/DR_95.exe/Dr95.pas

Pascal/Delphi Source File | 1997-12-10 | 18.7 KB | 675 lines

Program Dr95; {Entire source code for Drastical Restorer, VER 1.00}

Uses Crt,Dos;

var CurrentDirList: Array[0..14] of String;
    DirAlreadyDoneList:Array[1..14] of String;
    OutF :Text;

Function SameString(SourceString,TargetString:String):Boolean;
var I: Byte;
    SameFlag: Boolean;
begin
     If Length(TargetString)<>Length(SourceString) Then
     begin
          SameString:=False;
          Exit;
     end;

     SameFlag:=True;
     For I:=1 To Length(TargetString) Do
         If SourceString[I]<>TargetString[I] Then SameFlag:=False;
    SameString:=SameFlag;
end;

Function IncludedString(SourceString,TargetString:String):Boolean;
var I:Byte;
    SameFlag:Boolean;
begin
     If Length(TargetString)>Length(SourceString) Then
     begin
          IncludedString:=False;
          Exit;
     end;

     SameFlag:=True;
     For I:=1 To Length(TargetString) Do
         If SourceString[I]<>TargetString[I] Then SameFlag:=False;
     IncludedString:=SameFlag;
end;

Function WinDir:String;
var AFile: Text;
    Current, DummyStr: String;
    I: Byte;
begin
     Assign(AFile,'C:\MSDOS.SYS');
     {$I-} Reset(AFile); {$I+}
     If IOResult <> 0 Then
     begin
          WinDir:='';
          Exit;
     end;

     Repeat
           ReadLn(Afile,Current); {WriteLn(Current);}
           If IncludedString(Current,'WinDir=') Then
           begin
                Close(Afile);

                DummyStr:='';
                For I:=8 To Length(Current) Do DummyStr:=DummyStr+Current[I];
                WinDir:=DummyStr+'\';
                Exit;
           end;
     Until EOF(AFile);

     Close(AFile);
     WinDir:='';
end;

Procedure DelFile(FileName:String);
var AFile:File;
begin
     Assign(AFile, FileName);
     {$I-}
          SetFAttr(AFile,$20); {Archive}
          Erase(AFile);
     {$I+}
end;


Procedure Init;
var I:Byte;
begin
     If Windir='' Then
     begin
          WriteLn;
          WriteLn('Unable to find Windows 95''s directory.');
          WriteLn;
          Halt(0);
     end;

     CurrentDirList[0]:=WinDir;
     For I:=1 To 14 Do
     begin
          CurrentDirList[I]:='';
          DirAlreadyDoneList[I]:='';
     end;
end;

Function LastTreeLevel:Byte;
var I:Byte;
begin
     I:=0;
     While (CurrentDirList[I]<>'') and (I<=14) Do
     begin
          Inc(I)
     end;
     LastTreeLevel:=I;
end;

Function CurrentDirName:String;
var Dummy:String;
    I:Byte;
begin
     Dummy:=''; I:=0;

     While (CurrentDirList[I]<>'') and (I<=14) Do  {   <== Pas d'overflow  }
     begin                                         {       checking!       }
           Dummy:=Dummy+CurrentDirList[I];
           Inc(I);
     end;
     CurrentDirName:=Dummy;
end;

Function IsDir(DirInfo:SearchRec):Boolean;
begin
     If (DirInfo.Attr and ($10))=$10 then
     begin
          If ((DirInfo.Name<>'.') and (DirInfo.Name<>'..')) Then
          begin
               IsDir:=True;
               Exit;
          end;
     end;
     IsDir:=False;
end;

Function GiveNextDir:String;
var DirInfo:SearchRec;
    DoneFlag:Boolean;
begin
     If DirAlreadyDoneList[LastTreeLevel]='' Then DoneFlag:=True else DoneFlag:=False;

     FindFirst(CurrentDirName+'*.*',$FF,DirInfo);
     While DosError=0 Do
     begin
           If IsDir(DirInfo) Then
           begin
                 {*} {WriteLn('     '+DirInfo.Name+ ' ',  DoneFlag,' ',DirAlreadyDoneList[LastTreeLevel]); ReadLn;}
                If DoneFlag=True Then
                begin
                     GiveNextDir:=DirInfo.Name+'\';
                     Exit;
                end;
                If (DirInfo.Name+'\')=DirAlreadyDoneList[LastTreeLevel] Then DoneFlag:=True;
           end;
           FindNext(DirInfo);
     end;
     GiveNextDir:='';
end;

Procedure ListFile(DirName:String);
var DirInfo: SearchRec;

begin
     FindFirst(DirName+'*.*',$FF,DirInfo);
     While DosError=0 Do
     begin
          If (DirInfo.Attr and $10)=0 Then WriteLn(OutF,DirName+DirInfo.Name);
          FindNext(DirInfo);
     end;
end;

Procedure ListDir(DestinationDir:String);
var DummyDir:String;
    LastLevel:Byte;
    I:Byte;
begin
     Init;
     WriteLn;
     WriteLn('Listing all files in '+WinDir);
     Assign(OutF,DestinationDir+'LIST.TXT');
     ReWrite(OutF);

     Repeat
           DummyDir:=GiveNextDir;
           If DummyDir<>'' Then CurrentDirList[LastTreeLevel]:=DummyDir;
           If DummyDir='' Then
           begin
                {  Place here the current directory's
                   files registering procedure.       }
                {*} ListFile(CurrentDirName);

                LastLevel:=LastTreeLevel;
                If LastLevel=1 Then
                begin
                     Close(OutF);
                     Exit;
                end;

                DirAlreadyDoneList[LastTreeLevel-1]:= CurrentDirList[LastTreeLevel-1];
                CurrentDirList[LastTreeLevel-1]:='';
                For I:=LastLevel To 14 Do
                begin
                     DirAlreadyDoneList[I]:='';
                     CurrentDirList[I]:='';
                end;
           end;
     Until False;
end;

Procedure Help;
begin
     WriteLn;
     WriteLn(' Command Line:   DR95 S   or   DR95 R:savenum   or   DR95 L');
     WriteLn;
     WriteLn(' Where  S  means   Save the current configuration');
     WriteLn('        R:savenum  Restore de configuration numbered ''savenum''');
     WriteLn(' And    L          List de saved configurations''descriptions');
     WriteLn;
end;

Function ProgramDir:String;
var Dummy, ProgramName: String;
    I,J:Byte;
begin
     ProgramName:=ParamStr(0);
     Dummy:='';
     I:=Length(ProgramName);
     Repeat I:=I-1 Until (ProgramName[I]='\') Or (I=1);
     If I<>1 Then
        For J:=1 To I Do Dummy:=Dummy+ProgramName[J];
     ProgramDir:=Dummy;
end;


Function ListIndexedDescript(IndexNumber:Byte):String;
var InF:Text;
    DummyStr:String;
    I:Byte;
begin
     If IndexNumber<=9 Then
     begin
          Assign(InF,ProgramDir+'DESCRIPT.DAT');
          Reset(InF);
          For I:=1 To IndexNumber Do ReadLn(InF,DummyStr);
          ListIndexedDescript:=DummyStr;
          Close(InF);
     end else ListIndexedDescript:='';
end;

Function Authorized(RestoreNumber:Byte):Boolean;
var Car: Char;
begin
     WriteLn;
     WriteLn('- WARNING -');
     WriteLn('You''re about to restore a previous configuration described as :');
     WriteLn(ListIndexedDescript(RestoreNumber));
     WriteLn;
     WriteLn('This operation would reset Windows 95 to its exact configuration at that time.');
     WriteLn('Do you want to proceed anyway (Y/N)? ');
     Car:=ReadKey;
     If UpCase(Car)='Y' Then Authorized:=True Else Authorized:=False;
end;

Procedure Comparelist(OldListName:String);
var OldList,CurrentList,BlackList:Text;
    OldStr,CurrentStr:String;
begin
     Assign(OldList,OldListName);
     {$I-}Reset(OldList);{$I+}
     If IOResult<>0 Then
     begin
          Help;
          WriteLn('This configuration is missing or corrupt.');
          WriteLn('Please try another ''savenum'' parameter.');
          WriteLn;
          Halt(0);
     end;

     ListDir(ProgramDir);
     WriteLn('Searching for added files...');

     Assign(CurrentList,ProgramDir+'LIST.TXT');
     Reset(CurrentList);
     Assign(BlackList,ProgramDir+'BLACK.TXT');
     ReWrite(BlackList);

     Repeat
           ReadLn(CurrentList,CurrentStr);
           Reset(OldList);
           Repeat
                 ReadLn(OldList,OldStr);
           Until (SameString(OldStr,CurrentStr)) Or (EOF(OldList));

           If Not(SameString(OldStr,CurrentStr)) Then
           begin
                WriteLn('     '+CurrentStr);
                WriteLn(BlackList,CurrentStr);
           end;

     Until EOF(CurrentList);

     Close(OldList);
     Close(CurrentList);
     Close(BlackList);
     Erase(CurrentList);

     WriteLn('Deleting added files.');
     Reset(BlackList);
     While Not EOF(BlackList) Do
     begin
           ReadLn(BlackList,CurrentStr);
           if CurrentStr<>'' Then DelFile(CurrentStr);
     end;
     Close(BlackList);
     Erase(BlackList);
end;



Function Windows( var HVersion, NVersion : integer ) : integer;
const MULTIPLEX  = $2F;               { N° de l'interruption Multiplex }
      NO_WIN     = $00;                            { Windows non actif }
      W_386_X    = $01;                   { Windows /386 V2.X en cours }
      W_REAL     = $81;              { Windows fonctionne en mode réel }
      W_STANDARD = $82;          { Windows fonctionne en mode standard }
      W_ENHANCED = $83;            { Windows fonctionne en mode étendu }

var regs : registers;         {* Registre pour l'appel d'interruption *}
    Res  : integer;

{-- Cette fonction remplace l'appel de intr( $2F, Regs ) --------------}
{-- Regs.ax = $1600 (Test d'installation du mode étendu), -------------}
{-- l'appel avec la fonction Pascal renvois des valeurs erronées    ---}

function int2fcall : integer;

begin
  inline( $b8 / $00 / $16 /             { mov   ax,1600h              *}
          $cd / $2f /                   { int   2Fh                   *}
          $89 / $46 / $FE );            { mov   [bp-2], ax            *}
  { A cet endroit, le compilateur rajoute "mov ax, [bp-2]" pour       *}
  { charger la variable de fonction locale dans le registre de retour *}
end;

begin
  HVersion := 0;                     { Initialise le numéro de version }
  NVersion := 0;

            {-- Identifie Windows x.y en mode étendu ------------------}

  res := int2fcall;               { Test d'installation du mode étendu }

  case ( lo(Res) ) of
    $01,
    $FF:  begin
            HVersion := 2;                        { Version principale }
            NVersion := 0;               { Version secondaire inconnue }
            Windows := W_386_X;
          end;
    $00,
    $80:  begin
            regs.ax := $4680;  { Identifier les modes Réel et Standard }
            intr( MULTIPLEX, regs );
            if ( regs.al = $80 ) then
              Windows := NO_WIN            { Windows ne fonctionne pas }
            else
              begin
                   {-- Windows en mode Réel ou Standard ---------------}

                regs.ax := $1605;   { Simule l'inst. d'un DOS-Extender }
                regs.bx := $0000;
                regs.si := $0000;
                regs.cx := $0000;
                regs.es := $0000;
                regs.ds := $0000;
                regs.dx := $0001;
                intr( MULTIPLEX, regs );
                if ( regs.cx = $0000 ) then
                  begin
                     {-- Windows en mode Réel -------------------------}

                    regs.ax := $1606;
                    intr( MULTIPLEX, regs );
                    Windows := W_REAL;
                  end
                else
                  Windows := W_STANDARD;
              end;
          end;

   {-- Windows en mode Etendu, ax contient le numéro de version -------}

    else
      begin
        HVersion := lo(Res);          { Afficher la version de Windows }
        NVersion := hi(Res);
        Windows := W_ENHANCED;                { Windows en mode Etendu }
      end;
  end;
end;

Procedure CreateDescript;
var I:Byte;
    OutF: Text;
begin
     Assign(OutF,ProgramDir+'DESCRIPT.DAT');
     ReWrite(OutF);
     For I:=1 To 9 Do WriteLn(OutF,'SAV.'+Chr(I+48)+' : no configuration saved');
     Close(OutF);
end;

Procedure RestoreDescript;
var DirInfo:SearchRec;
    InF,OutF:Text;
    DummyStr:String;
    I:Byte;
begin
     FindFirst(ProgramDir+'DESCRIPT.DAT',$FF,DirInfo);
     If DosError<>0 Then CreateDescript Else
     begin
          Assign(InF,ProgramDir+'DESCRIPT.DAT');
          Reset(InF);
          Assign(OutF,ProgramDir+'TEMP.DAT');
          ReWrite(OutF);
          For I:=1 To 9 Do
          begin
              FindFirst(ProgramDir+'SAV.'+CHR(I+48),$FF,DirInfo);
              If DosError=0 Then
              begin
                   ReadLn(InF,DummyStr);
                   WriteLn(OutF,DummyStr);
              end else
              begin
                   ReadLn(InF,DummyStr);
                   WriteLn(OutF,'SAV.'+Chr(I+48)+' : no configuration saved');
              end;
          end;
          Close(InF);
          Close(OutF);
          Erase(InF);
          Rename(OutF,ProgramDir+'DESCRIPT.DAT');
     end;
end;

Procedure AddDescript(SaveDirName:String);
var I,SaveNumber:Byte;
    InF,OutF:Text;
    Descript,DummyStr:String;

begin
     Write('File Description for ',SaveDirName,' : ');
     ReadLn(Descript);

     SaveNumber:=Ord(SaveDirName[Length(SaveDirName)-1])-48;
     Assign(InF,ProgramDir+'DESCRIPT.DAT');
     Reset(InF);
     Assign(OutF,ProgramDir+'TEMP.DAT');
     ReWrite(OutF);
     For I:=1 To SaveNumber-1 Do
     begin
          ReadLn(InF,DummyStr);
          WriteLn(OutF,DummyStr);
     end;
     ReadLn(InF,DummyStr);
     WriteLn(OutF,'SAV.'+Chr(SaveNumber+48)+' : '+Descript);
     For I:=SaveNumber+1 To 9 Do
     begin
          ReadLn(InF,DummyStr);
          WriteLn(OutF,DummyStr);
     end;

     Close(InF);
     Close(OutF);
     Erase(InF);
     Rename(OutF,ProgramDir+'DESCRIPT.DAT');
end;

Procedure ListDescript;
var InF:Text;
    DummyStr:String;
    I:Byte;
begin
     Assign(InF,ProgramDir+'DESCRIPT.DAT');
     Reset(InF);
     WriteLn;
     WriteLn('Saved configurations''descriptions :');
     WriteLn;
     For I:=1 To 9 Do
     begin
          ReadLn(InF,DummyStr);
          WriteLn(DummyStr);
     end;
     WriteLn;
     Close(InF);
end;

Function GiveSaveDir(FileName:String):String; {Warning: just call once!}
var Dummy: String;
    I,J:Byte;
    DirInfo: SearchRec;
begin
     Dummy:='';
     I:=Length(FileName);
     Repeat I:=I-1 Until (FileName[I]='\') Or (I=1);
     If I<>1 Then
        For J:=1 To I Do Dummy:=Dummy+FileName[J];

     I:=1;
     FindFirst(Dummy+'SAV.'+Chr(49),$FF,DirInfo);
     While ((DosError=0) and (I<9)) Do
     begin
          Inc(I);
          FindFirst(Dummy+'SAV.'+Chr(48+I),$FF,DirInfo);
     end;

     If I<9 Then
     begin
          MkDir(Dummy+'SAV.'+Chr(48+I));
          GiveSaveDir:=Dummy+'SAV.'+Chr(48+I)+'\';
     end else
     begin
          WriteLn('There are already nine configurations saved.');
          WriteLn('Manually erase one of them before saving current configuration.');
          WriteLn;
          Halt(0);
     end;
     WriteLn;
     WriteLn('Saving configuration in '+Dummy+'SAV.'+Chr(48+I)); {*}
end;

Procedure CopyFile(FromFName,ToFName:String);
var
  FromF, ToF: File;
  NumRead, NumWritten: Word;
  Buf: Array[1..2048] of Char;
  Attr: Word;
begin
     WriteLn('Copying ',FromFName,' to ',ToFName);  {*}
     Assign(FromF, FromFName); { Open input file }
     {$I-}
     GetFAttr(FromF,Attr);
     SetFAttr(FromF,$20);
     Reset(FromF, 1);  { Record size = 1 }
     Assign(ToF, ToFName); { Open output file }
     Rewrite(ToF, 1);  { Record size = 1 }
     Repeat
           BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
           BlockWrite(ToF, Buf, NumRead, NumWritten);
     Until (NumRead = 0) or (NumWritten <> NumRead);
     Close(FromF);
     Close(ToF);
     SetFAttr(FromF,Attr);
     SetFAttr(ToF,Attr);
     {$I+}
end;

Procedure SaveCurrentConfiguration;
const FilesToSave : Array[1..4] of String =
      ('WIN.INI',
       'SYSTEM.INI',
       'SYSTEM.DAT',
       'USER.DAT');

var SaveDir: String;
    I:Byte;
begin
     SaveDir:=GiveSaveDir(ParamStr(0));
     AddDescript(SaveDir);

     ListDir(SaveDir);
     For I:=1 To 4 Do CopyFile(Windir+FilesToSave[I],SaveDir+FilesToSave[I]);
end;

Procedure RestoreConfiguration(DirName:String);
const FilesToRestore: Array[1..4] of String =
      ('WIN.INI',
       'SYSTEM.INI',
       'SYSTEM.DAT',
       'USER.DAT');
var DirInfo:SearchRec;
    I:Byte;
begin
     For I:=1 To 4 Do
     begin
          FindFirst(WinDir+FilesToRestore[I],$FF,DirInfo);
          If DosError=0 Then
          begin
               FindFirst(DirName+FilesToRestore[I],$FF,DirInfo);
               If DosError=0 Then
               begin
                    DelFile(WinDir+FilesToRestore[I]);
                    CopyFile(DirName+FilesToRestore[I],WinDir+FilesToRestore[I]);
               end;
          end;
     end;
end;

Procedure Intro;
var Car1,Car2: String;
    RestoreNumber:Byte;
    HVersion, NVersion : integer;
begin
     ClrScr;
     WriteLn('DR95.EXE - Drastical Restorer for Windows 95, VER 1.00');
     WriteLn('Written by S.Fourmanoit, MCMXCVIII.');

     If Windows(HVersion, NVersion)<>$00 Then
     begin
          WriteLn;
          WriteLn('Windows is currently running.');
          WriteLn('This program cannot perform his job safely under Windows:');
          WriteLn('please reboot your computer and press F8 in order to run in DOS mode.');
          WriteLn; ReadLn;
          Halt(0);
     end;

     RestoreDescript;

     If ParamCount=0 Then
     begin
          Help;
          Halt(0);
     end;

     Car1:=Copy(ParamStr(1),1,1);
     Case UpCase(Car1[1]) Of
          'S': begin
                    SaveCurrentConfiguration;
                    WriteLn;
                    WriteLn('Configuration sucessfully saved.');
                    WriteLn;
               end;
          'R': begin
                    Car2:=Copy(ParamStr(1),3,1);
                    RestoreNumber:=Ord(Car2[1])-48;
                    If Not (Car2[1] in ['1'..'9']) Then
                    begin
                         Help;
                         WriteLn;
                         WriteLn('Bad ''savenum''.  Please check the syntax.');
                         WriteLn;
                         Halt(0);
                    end;

                    If Authorized(RestoreNumber) Then
                    begin
                         WriteLn;
                         WriteLn('Restoring configuration #'+Car2[1]+'.');
                         CompareList(ProgramDir+'SAV.'+Car2[1]+'\LIST.TXT');
                         RestoreConfiguration(ProgramDir+'SAV.'+Car2[1]+'\');
                         WriteLn;
                         WriteLn('Restoration sucessfully done.');
                         WriteLn;
                    end else
                    begin
                         WriteLn;
                         WriteLn('Operation aborded.');
                         WriteLn;
                         Halt(0);
                    end;

               end;
          'L': ListDescript;
           else Help;
     end;
end;

{***  MAIN  ***}
Begin
     Intro;
End.