ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/UTILITY/DIR/ODEL12.ZIP/ODEL.PAS

Pascal/Delphi Source File | 1991-10-10 | 18.1 KB | 578 lines

{$A+,B+,D-,E-,F-,I+,L-,N-,O-,R+,S+,V+}
{$M 8096,0,0}

PROGRAM Odel;

(***********************************************************************
 NOTICE
 ======
     This program and every file distributed with it are copyright (C)
 by the authors, who retain authorship both of the pre-compiled and
 compiled codes.  Their use and distribution are unrestricted, as long
 as nobody gets any richer in the process.  Although these programs
 were developed to the best of the authors abilities, no guarantees
 can be given as to their performance.  By using them, the user
 accepts all risks and the authors decline all liability.
************************************************************************)

USES Crt,Dos;

CONST
  MaxParam = 2;
  MaxRow = 25;
  MaxCol = 80;

VAR
  g : FILE;
  m,d,y,w : WORD;
  Date : REAL;
  ch : CHAR;
  OldF : STRING[12];
  Dir : DirStr;
  Nam : NameStr;
  Ext : ExtStr;
  p : ARRAY[1..MaxParam] OF PathStr;
  Size : LONGINT;
  Code : INTEGER;
  Plus : STRING;
  f: SEARCHREC;
  FAttr : WORD;
  DirSiz : LONGINT;
  r : BOOLEAN;
  OdelSiz : LONGINT;
  ClusSize : WORD;
  DFree : LONGINT;

(************************************************************************
This function returns the cluster size (bytes per cluster) in the default
drive. See PC Techniques vol2 num 3 (Aug/Sept 1991) pp. 96.
*************************************************************************)
FUNCTION ClusterSize: WORD;
VAR
  r : REGISTERS;
BEGIN
  r.ah:= $1B;
  MSDOS(r);
  ClusterSize:= r.al * r.cx;
END;

(*************************************************************************
This function returns the size in bytes occupied by all the clusters taken
by the default directory.
**************************************************************************)
FUNCTION ActualDirSize: LONGINT;
VAR
  f : SEARCHREC;
  NumClusters : WORD;
BEGIN
  FindFirst('*.*',AnyFile - Directory - VolumeId - SysFile - Hidden,f);
  WHILE DosError = 0 DO BEGIN
    IF f.Size MOD ClusSize <> 0 THEN
      NumClusters:= NumClusters + (f.Size DIV ClusSize) + 1
    ELSE
      NumClusters:= NumClusters + (f.Size DIV ClusSize);
    FindNext(f);
  END;
  ActualDirSize:= NumClusters * ClusSize;
END;

(*************************************************************************
Given the size of a file (fsize) this function returns the actual space in
bytes that the clusters of the file would occupy in the default drive.
**************************************************************************)
FUNCTION ActualFSize(FSize: LONGINT): LONGINT;
BEGIN
  IF FSize MOD ClusSize <> 0 THEN
    ActualFSize:= ((FSize DIV ClusSize) + 1) * ClusSize
  ELSE
    ActualFSize:= FSize;
END;

FUNCTION DiskFreeSize: LONGINT;
BEGIN
  DiskFreeSize:= (DiskFree(0) DIV ClusSize) * ClusSize;
END;

(* see PC Mag Vol 10 N9, April 16 1991 *)
FUNCTION OutputRedirected: BOOLEAN;
VAR
  r : REGISTERS;
  Handle : WORD ABSOLUTE Output;

BEGIN
  WITH r DO BEGIN
    ax:= $4400;
    bx:= Handle;
    MSDOS(r);
    IF dl AND $82 = $82 THEN OutputRedirected:= False
                        ELSE OutputRedirected:= True;
  END;
END;

PROCEDURE TestRow;
VAR
  c : CHAR;
BEGIN
  IF OutputRedirected THEN Exit;
  IF WhereY = MaxRow THEN BEGIN
    GotoXY(1,MaxRow);
    ClrEol;
    Write('- more - ');
    REPEAT UNTIL KeyPressed;
    WHILE KeyPressed DO c:= ReadKey;
    ClrScr;
  END;
END;

PROCEDURE Writ(s: STRING; Test:BOOLEAN);
VAR
  r : REGISTERS;
BEGIN
  IF Test AND NOT (p[1][1] IN ['#','$']) THEN TestRow;
  WITH r DO BEGIN
    ah:= $40;
    bx:= $01;
    cx:= Ord(s[0]);
    Ds:= Seg(s);
    dx:= Ofs(s) + $01;
    MSDOS(r);
  END;
END;

PROCEDURE WritLn(s: STRING; Test: BOOLEAN);
BEGIN
  IF Ord(s[0]) > 253 THEN s:= Copy(s,1,253);
  s:= s + #13 + #10;
  Writ(s, Test);
END;

FUNCTION St(w:LONGINT): STRING;
VAR
  s  : STRING;
BEGIN
  Str(w,s);
  St:= s;
END;

FUNCTION Power(x,y: REAL): REAL;
BEGIN
  Power:= Exp(y * Ln(x));
END;

FUNCTION BitB(VAR b     : BYTE;     { the variable }
                  p     : BYTE;     { the bit }
                  o     : BYTE): BOOLEAN;
                                    { the operation: }
                                    { 0 : switch off }
                                    { 1 : switch on }
                                    { 2 : swap }
                                    { 3 : just test, leave as is }
                                    { the result: }
                                    { true if on }
                                    { false if off }
VAR
  v : BYTE;


BEGIN
  CASE p OF
    0 : v:= 1;
    1 : v:= 2;
    ELSE v:= Trunc(Power(2,p));
  END;
  CASE o OF
    0 {switch off}  : IF (b AND v = v) THEN b:= b - v;
    1 {switch on}   : IF NOT(b AND v = v) THEN b:= b + v;
    2 {swap on/off} : IF (b AND v = v) THEN b:= b - w
                                       ELSE b:= b + v;
  END;
  IF (b AND v = v) THEN BitB:= True   {is on...}
                   ELSE BitB:= False; {is off...}
END;

FUNCTION BitW(VAR b     : WORD;     { the variable }
                  p     : BYTE;     { the bit }
                  o     : BYTE): BOOLEAN;
                                    { the operation: }
                                    { 0 : switch off }
                                    { 1 : switch on }
                                    { 2 : swap }
                                    { 3 : just test, leave as is }
                                    { the result: }
                                    { true if on }
                                    { false if off }
VAR
  v : WORD;


BEGIN
  CASE p OF
    0 : v:= 1;
    1 : v:= 2;
    ELSE v:= Trunc(Power(2,p));
  END;
  CASE o OF
    0 {switch off}  : IF (b AND v = v) THEN b:= b - v;
    1 {switch on}   : IF NOT(b AND v = v) THEN b:= b + v;
    2 {swap on/off} : IF (b AND v = v) THEN b:= b - w
                                       ELSE b:= b + v;
  END;
  IF (b AND v = v) THEN BitW:= True   {is on...}
                   ELSE BitW:= False; {is off...}
END;

PROCEDURE Logo;
BEGIN
  WriteLn;
  WriteLn('╔══════════════════════════════════════════════════════════════════════╗');
  WriteLn('║ ODEL 1.2 Copyright (c) Aug.91 ■ J.Campione/C.J.Taylor/C.R.Parkinson. ║');
  WriteLn('║ Searches default directory & displays/deletes oldest file(s) first.  ║');
  WriteLn('╠══════════════════════════════════════════════════════════════════════╣');
  WriteLn('║ - No parameter .. displays this help.                                ║');
  WriteLn('║ - Param. ? ...... displays files in reverse date/time order.         ║');
  WriteLn('║ - Param. @ ...... prompts before deleting each oldest file(s).       ║');
  WriteLn('║ - Param. ! ...... deletes all file(s) with oldest time/date.         ║');
  WriteLn('║ - Param. #xxxx .. deletes old file(s) until "xxxx" bytes are freed.  ║');
  WriteLn('║ - Param. %xxxx .. preview for parameter "#", files are not deleted.  ║');
  WriteLn('║ - Param. $<file>. deletes old file(s) until enough space for "file". ║');
  WriteLn('║ - Param. &<file>. preview for parameter "$", files are not deleted.  ║');
  WriteLn('╚══════════════════════════════════════════════════════════════════════╝');
END;

PROCEDURE GetChar(VAR ch: CHAR; VAR FuncKey: BOOLEAN);
BEGIN
  REPEAT UNTIL KeyPressed;
  FuncKey:= False;
  ch:= ReadKey;
  IF ch = #0 THEN BEGIN
    FuncKey:= True;
    ch:= ReadKey;
  END;
END;

(* gets actual size of default directory in bytes per used cluster *)
(* and resets bit 5 in all file attributes *)
FUNCTION DirSize: LONGINT;
VAR
  CSize : LONGINT;
  f : SEARCHREC;
  g : FILE;
BEGIN
  CSize:= 0;
  { find all files to determine eraseable size of directory }
  FindFirst('*.*', AnyFile - Directory - VolumeId - SysFile - Hidden, f);
  WHILE (DosError = 0) DO
  BEGIN
    IF f.Name <> 'ODEL.EXE' THEN BEGIN
      Assign(g,f.Name);
      IF p[1][1] IN ['%','&'] THEN r:= BitB(f.Attr,5,0);
      SetFAttr(g,f.Attr);
      CSize:= CSize + ActualFSize(f.Size);
    END;
    FindNext(f);
  END;
  DirSize:= CSize;
END;

PROCEDURE Halting(e: BYTE; f: STRING; n: WORD);
BEGIN
  (* just to reset bit 5 : *)
  DirSiz:= DirSize;
  WriteLn;
  CASE e OF
    0 : IF (p[1][1] IN ['?','%','&'])
        THEN Writ('>>> ' + St(n) + ' file(s) could have been deleted ',True)
        ELSE Writ('>>> ' + St(n) + ' file(s) deleted ',True);
    1 : Writ('>>> No file deleted ',True);
    2 : Writ('>>> Enough free space in disk, no file deleted ',True);
    3 : Writ('>>> Error in space specification ',True);
    4 : Writ('>>> Error in file "' + f + '" ',True);
    5 : Writ('>>> Error in number of parameters ',True);
    6 : Writ('>>> Error in first parameter ',True);
    7 : Writ('>>> Error in second parameter ',True);
    8 : Writ('>>> Error: requested space larger than disk size ',True);
    9 : Writ('>>> Error: requested space larger than directory size ',True);
   10 : Writ('>>> Unknown error: file "' + f + '" could not be deleted ',True);
   11 : Writ('>>> Error: output cannot be redirected with parameters "?" or "@" ',True);
   12 : Writ('>>> Error: the name of "' + f + '" must be "ODEL.EXE" ',True);
  END;
  WritLn('[' + St(e) + '].',True);
  Halt(e);
END;

(****************************************************************)
(* This function takes into consideration the date and the time *)
(* The date generates the integer portion,                      *)
(* and corresponds to the classical julian function.            *)
(* The time is used to generate the decimal fraction.           *)
(* -Jose-                                                       *)
(****************************************************************)
FUNCTION Julian(Year, Month, Day, Hour, Min, Sec:INTEGER): REAL;
VAR
  Yr, Mth : INTEGER;
  NoLeap, Leap, Days, Yrs : REAL;
  Jul : REAL;
BEGIN
  Jul:= (Hour * 3600 + Min * 60 + Sec) / 86400;
  IF Year<0 THEN Yr:= Year + 1
            ELSE Yr:= Year;
  Mth:= Month;
  IF Month < 3 THEN BEGIN
    inc(Mth,12);
    dec(Yr);
  END;
  Yrs:= 365.25 * Yr;
  IF ((Yrs < 0) AND (Frac(Yrs) <> 0)) THEN Yrs:= Int(Yrs) - 1
                                      ELSE Yrs:= Int(Yrs);
  Days:= Int(Yrs) + Int(30.6001*(Mth + 1)) + Day-723224.0;
  IF Days < -145068.0 THEN Julian:= Jul + Days
                      ELSE BEGIN
                        Yrs:= Yr/100.0;
                        IF ((Yrs < 0 ) AND (Frac(Yrs) <> 0)) THEN Yrs:= Int(Yrs) - 1;
                        NoLeap:= Int(Yrs);
                        Yrs:= NoLeap/4.0;
                        IF ((Yrs < 0 ) AND (Frac(Yrs) <> 0)) THEN Yrs:= Int(Yrs) - 1;
                        Leap:= 2 - NoLeap + Int(Yrs);
                        Julian:= Jul + Days + Leap;
                      END;
END;

PROCEDURE DelOldest;
LABEL 000, 001, 002;
VAR
  ODelF,OlF : FILE;
  Count : INTEGER;
  OldY, OldM, OldD : WORD;
  OldH, OldMin, OldS : WORD;
  MInt, LMInt : REAL;
  First : BOOLEAN;
  Dt : DateTime;
  ftj : REAL;
  ch : CHAR;
  FuncKey : BOOLEAN;
  CurrDir : STRING;
  wx, wy : BYTE;
  Space : LONGINT;
  Files : INTEGER;
  Sum : LONGINT;
  FFile, LFile : STRING[12];
  BegFlag : BOOLEAN;

BEGIN
  LFile:= '';
  FFile:= '';
  Space:= 0;
  Count:= 0;
  Sum:= 0;
  LMInt:= -1.7e38;
  BegFlag:= True;
  DirSiz:= DirSize;
  GetDir(0,CurrDir);

  OdelSiz:= 0;
  {$I-}
  Assign(ODelF,CurrDir + '\ODEL.EXE');
  Reset(ODelF,1);
  {$I+}
  IF IOResult = 0 THEN BEGIN
    OdelSiz:= ActualFSize(FileSize(ODelF));
    Close(ODelF);
  END;

  WritLn('',True);
  WritLn('>>> Default directory : ' + CurrDir + ' uses ' + St(DirSiz+OdelSiz) + ' bytes, ', True);
  Writ('>>> ' + St(DirSiz) + ' are erasable',True);
  IF OdelSiz = 0 THEN WritLn('.',True)
                 ELSE WritLn(' and ' + St(OdelSiz) + ' are taken by ODEL.EXE.',True);
  WritLn('>>> Disk '+ CurrDir[1] + ': has ' + St(DiskSize(0)) + ' bytes and '+ St(DFree) + ' are free. ', True);
  WritLn('>>> The default disk has ' + St(ClusSize) + ' bytes per cluster.', True);
  WritLn('>>> ODEL could free up to ' + St(DirSiz + DFree) + ' bytes. ',True);
  WritLn('',True);
  IF p[1][1] IN ['#','%'] THEN BEGIN
    Val(Copy(p[1],2,Ord(p[1][0])-1),Size,Code);
    IF (Code <> 0) OR (Size <= 0) THEN Halting(3,'',0);
    Size:= ActualFSize(Size);
  END;
  IF p[1][1] IN ['$','&'] THEN BEGIN
    Size:= 0;
    FindFirst(Copy(p[1],2,Ord(p[1][0]) - 1), AnyFile, f);
    WHILE (DosError = 0) DO BEGIN
      IF f.Name <> 'ODEL.EXE' THEN Size:= Size + ActualFSize(f.Size);
(*  writln(F.name + ' ' + st(F.size),true);  *)
      FindNext(f);
    END;
    IF Size = 0 THEN Halting(4,Copy(p[1],2,Ord(p[1][0])-1),0);
  END;
  IF p[1][1] IN ['#','%','$','&'] THEN BEGIN
    WritLn('>>> size to be regained = ' + St(Size) + '.',True);
    Size:= Size - DFree;
    IF Size <= 0 THEN Halting(2,'',0);
    IF Size > DiskSize(0) THEN Halting(8,'',0);
    IF Size > DirSiz THEN Halting(9,'',0);
  END;

  000:
  MInt:= 1.7e38;
  FillChar(OldF,SizeOf(OldF),0);
  FillChar(Dt,SizeOf(Dt),0);

  Files:= 0;
  { find eraseable files according to plus mask in second }
  { parameter. This is to files to determine oldest for deletion. }
  FindFirst(Plus, AnyFile - Directory - VolumeId - SysFile - Hidden, f);
  WHILE (DosError = 0) DO
  BEGIN
    IF f.Name <> 'ODEL.EXE' THEN BEGIN
      inc(Files,1);
      IF (p[1][1] IN ['%','&']) AND BitB(f.Attr,5,3) THEN GOTO 001;
      UnpackTime(f.Time,Dt);
      ftj:= Julian(Dt.Year,Dt.Month,Dt.Day,Dt.Hour,Dt.Min,Dt.Sec);
      IF (ftj < MInt) AND (ftj > LMInt) THEN BEGIN
        MInt:= ftj;
        OldF:= f.Name;
        OldY:= Dt.Year;
        OldM:= Dt.Month;
        OldD:= Dt.Day;
        OldH:= Dt.Hour;
        OldMin:= Dt.Min;
        OldS:= Dt.Sec;
      END;
    END;
    001:
    FindNext(f);
  END;
  IF MInt = 1.7e38 THEN Halting(0,'',Count);

  First:= True;
  FindFirst(Plus, AnyFile - Directory - VolumeId - SysFile - Hidden, f);
  WHILE (DosError = 0) DO
  BEGIN
    IF f.Name <> 'ODEL.EXE' THEN BEGIN
      IF (p[1][1] IN ['%','&']) AND BitB(f.Attr,5,3) THEN GOTO 002;
      UnpackTime(f.Time,Dt);
      IF (Dt.Year = OldY) AND
        (Dt.Month = OldM) AND
        (Dt.Day = OldD) AND
        (Dt.Hour = OldH) AND
        (Dt.Min = OldMin) AND
        (Dt.Sec = OldS) THEN BEGIN
        IF First THEN BEGIN
          First:= False;
          IF BegFlag THEN BEGIN
            WritLn('', True);
          END;
        END;

        FSplit(f.Name,Dir,Nam,Ext);
        Sum:= Sum + ActualFSize(f.Size);
        Writ(' - ' + Nam + Ext + ' ' + St(ActualFSize(f.Size)) + ' ' + St(Sum) +
             ' (' + St(OldY) + '-' + St(OldM) + '-' + St(OldD) + ')' +
             ' [' + St(OldH) + ':' + St(OldMin) + ':' + St(OldS) + ']', True);
        wx:= WhereX; wy:= WhereY;
        IF wy = 25 THEN dec(wy,1);
        IF (p[1][1] = '@') THEN BEGIN
          WritLn('', True);
          Writ('>>> Delete file "' + f.Name + '" [Y/N/Esc]? ', False);
          REPEAT
            GetChar(ch,FuncKey);
          UNTIL (NOT FuncKey) AND (UpCase(ch) IN ['Y','N',#27]);
          GotoXY(1,WhereY); ClrEol;
          GotoXY(wx,wy);
        END;
        IF (UpCase(ch) = 'Y') OR
           (p[1][1] IN ['?','!','#','$','%','&'])
        THEN BEGIN
          {$I-}
          Assign(OlF,f.Name);
          Reset(OlF);
          IF NOT (p[1][1] IN ['?','%','&']) THEN Erase(OlF) ELSE
            IF p[1][1] IN ['%','&'] THEN BEGIN
              GetFAttr(OlF,FAttr);
              r:= BitW(FAttr,5,1);
              SetFAttr(OlF,FAttr);
            END;
          {$I+}
          IF (IOResult = 0) THEN BEGIN
                                 Space:= Space + ActualFSize(f.Size);
                                 IF p[1][1] = '?' THEN Writ(' - NOT ',True) ELSE
                                   IF p[1][1] IN ['%','&'] THEN Writ(' - would be ',True) ELSE
                                     Writ(' - ',True);
                                 WritLn('deleted (' + St(Space) + ').',True);
                                 inc(Count,1);
                               END
                          ELSE Halting(10,f.Name,0);
        END ELSE WritLn(' - NOT deleted.',True);
        IF ch = #27 THEN Halting(0,'',Count);
      END;
      IF ((p[1][1] IN ['#','%','$','&']) AND (Space >= Size)) THEN BEGIN
        WritLn('',True);
        IF p[1][1] IN ['#','$'] THEN WritLn('>>> ' + St(Space) + ' bytes have been freed.',True)
                                ELSE WritLn('>>> ' + St(Space) + ' bytes could have been freed.',True);
        IF Count = 0 THEN Halting(1,'',0)
                     ELSE Halting(0,'',Count);
      END;
    END;
    002:
    FindNext(f);
  END;
  IF (p[1][1] IN ['?']) THEN BEGIN
    Writ('>>> Press return to continue preview : ',True);
    REPEAT
      GetChar(ch,FuncKey);
    UNTIL (NOT FuncKey);
    IF (ch = #13) THEN BEGIN
      IF (MInt > LMInt) AND (MInt < 1.7e38) THEN BEGIN
        LMInt:= MInt;
        GotoXY(1,WhereY); ClrEol;
        BegFlag:= False;
        GOTO 000;
      END;
    END ELSE BEGIN GotoXY(1,WhereY); ClrEol; END;
  END;
  IF (p[1][1] IN ['@']) THEN BEGIN
    IF (MInt > LMInt) AND (MInt < 1.7e38) THEN BEGIN
      LMInt:= MInt;
      BegFlag:= False;
      GOTO 000;
    END;
  END;
  IF (Files > 0) AND (p[1][1] IN ['#','%','$','&','@']) THEN BEGIN
    BegFlag:= False;
    GOTO 000;
  END;
  IF Count = 0 THEN Halting(1,'',0) ELSE Halting(0,'',Count);
END;


BEGIN
  Plus:= '*.*';
  ClusSize:= ClusterSize;
  DFree:= DiskFreeSize;

  FillChar(p,SizeOf(p),0);

  IF (ParamCount = 0) THEN BEGIN Logo; Halt(0); END;
  IF (ParamCount > 2) THEN BEGIN Logo; Halting(5,'',0); END;

  p[1]:= ParamStr(1);
  IF NOT (p[1][1] IN ['?','!','@','#','%','$','&']) THEN BEGIN Logo; Halting(6,'',0); END;

  IF ParamCount > 1 THEN BEGIN
    p[2]:= ParamStr(2);
    IF (NOT (p[2][1] IN ['+'])) THEN BEGIN
      Logo;
      Halting(7,'',0);
    END ELSE
      Plus:= Copy(p[2],2,Ord(p[2][0]) - 1);
  END;

  IF OutputRedirected AND (p[1][1] IN ['?','@']) THEN Halting(11,'',0);

  FSplit(ParamStr(0),Dir,Nam,Ext);
  IF Nam + Ext <> 'ODEL.EXE' THEN BEGIN Logo; Halting(12,Nam + Ext,0); END;

  DelOldest;
  DirSiz:= DirSize;
END.