Power-Programmierung/CD1.mdf/pascal/library/dos/murutil/update.pas

Pascal/Delphi Source File | 1988-11-21 | 15.8 KB | 613 lines

PROGRAM UPDATE;

{$N-  Don't use the numeric coprocessor.}

{  Example of use:  UPDATE A:*.* B:*.*

   This Turbo Pascal V4.0 program updates files from a source  directory
   (or device) to a target directory (or device);  in the above example,
   updating from  A:*.* to  B:*.*.   Those source files which are not in
   the target directory,  or which are newer than the same  named  files
   in the target directory are copied to the target directory in  alpha-
   betical order.   This updating process ensures that the most  current
   versions of the source files are on the target directory  or device).

   UPDATE accepts one of two options as a third parameter,  /S  and  /V.
   /S shows which files would be copied, but suppresses any actual copy-
   ing.   /V verifies each file copy.   These options are  mutually  ex-
   clusive.

   Examples:  UPDATE *.* \ZERO\*.* /S
              UPDATE *.* \ZERO\*.* /V

   Hitting any key during the update process will cause the  program  to
   pause.  When paused, ^C and Esc will stop the program;  any other key
   will resume the program.

   Note:  Files with the Hidden, System, Volume ID, or Directory attri-
          bute and files with ".BAK" or ".~??" extensions are excluded
          from this update process.

   Updated 19 May 1988 to show files to be copied.

   Updated 21 Nov 1988 to use BLOCKREAD and BLOCKWRITE to do the copying
   and verifying internally,  rather than using EXEC to invoke the  COPY
   utility.

   Program by Harry M. Murphy  --  13 February 1988.  }

USES
    CRT,
    DOS;

CONST
    BUFFSIZE = 8192;
    ERRPROL  = '        >>>  UPDATE ERROR!  '#7;
    FILELEN  = 12;
    MAXLIST  = 1000;
    PATHLEN  = 64;
    SYNTAX   = 'UPDATE syntax:  UPDATE sourcefile targetfile [/S|/V]';

TYPE
    BUFFER  = ARRAY[1..BUFFSIZE] OF CHAR;
    FILENAM = STRING[FILELEN];
    FILEREC = RECORD
                NAME : FILENAM;
                TIME : LONGINT
              END;
    FILELST = ARRAY [1..MAXLIST] OF FILEREC;
    PATHNAM = STRING[PATHLEN];

VAR
    ABUFF : BUFFER;   { Source file buffer.      }
    APARM : PATHNAM;  { Source parameter string. }
    APATH : PATHNAM;  { Source path name.        }
    ALIST : FILELST;  { Source file list.        }
    ANUMB : INTEGER;  { Number of source files.  }

    BBUFF : BUFFER;   { Target file buffer.      }
    BPATH : PATHNAM;  { Target parameter string. }
    BPARM : PATHNAM;  { Target path name.        }
    BLIST : FILELST;  { Target file list.        }
    BNUMB : INTEGER;  { Number of target files.  }

    NPAR  : WORD;     { Parameter count.         }

    COPY  : BOOLEAN;  { Perform copy flag.       }
    ERROR : BOOLEAN;  { Error flag.              }
    VERI  : BOOLEAN;  { Do copy verify flag.     }

{ -------------------------------- }

PROCEDURE CHECKKEYBD;

{  This procedure checks if any key has been struck.  If so, it pauses
   and waits for a second key.   If the key is ^C or Esc,  it sets the
   error flag, ERROR, to true;  otherwise it simply returns.  }

VAR
  KEY : CHAR;

BEGIN
  IF KEYPRESSED
    THEN
      BEGIN
        WHILE KEYPRESSED DO KEY := READKEY;
        HIGHVIDEO;
        WRITE('PAUSING.   ^C or Esc aborts;  any other key to resume.');
        NORMVIDEO;
        SOUND(880);
        DELAY(100);
        NOSOUND;
        WHILE NOT KEYPRESSED DO;
        WRITE(#13);
        CLREOL;
        KEY := READKEY;
        ERROR := ERROR OR (KEY IN [#3,#27]);
        WHILE KEYPRESSED DO KEY := READKEY
      END
END { Procedure CHECKKEYBD };

{ -------------------------------- }

PROCEDURE CHECKPARCOUNT(VAR NPAR: WORD);

{  This procedure verifies that the parameter count is two or three.
   If no parameters are furnished, it displays the UPDATE syntax and
   halts.  }

BEGIN
  NPAR := PARAMCOUNT;
  IF NPAR = 0
    THEN
      BEGIN
        WRITELN(SYNTAX);
        HALT
      END
    ELSE
      IF (NPAR < 2) OR (NPAR > 3)
        THEN
          BEGIN
            WRITE(ERRPROL);
            IF NPAR < 2
              THEN
                WRITELN('There must be at least two parameters.')
              ELSE
                WRITELN('There must be no more than three parameters.');
            HALT
          END
END { Procedure CHECKPARCOUNT };

{ -------------------------------- }

FUNCTION DIRPATH(FPARM: PATHNAM): PATHNAM;

{  This STRING function returns the path name from the file parameter
   argument.   For example, if FPARM is "A:\SUBR\*.*" DIRPATH returns
   "A:\SUBR\".  If no path nor device is specified, DIRPATH returns a
   null string.  }

VAR
  L : 0..PATHLEN;

BEGIN
  L := LENGTH(FPARM);
  WHILE (L > 0) AND NOT (FPARM[L] IN ['\',':']) DO L := PRED(L);
  FPARM[0] := CHR(L);
  DIRPATH := FPARM
END { Procedure DIRPATH };

{ -------------------------------- }

PROCEDURE DOUPDATE;

{  This procedure compares the Source and Target file lists,  lists  the
   files to be copied and then lists, copies and  [optionally]  verifies
   the copied files.  }
CONST
  SP = ' ';

VAR
  I, J, NCPY  : INTEGER;
  ALPHA, BETA : STRING;

{ ------ Internal Procedure ------ }

PROCEDURE DOCOPY(ALPHA,BETA: STRING; VAR ERROR: BOOLEAN);

{  This internal procedure copies file ALPHA to file BETA.  ERROR is set
   to TRUE if an error occurs.  }

VAR
  ALPHAF, BETAF : FILE;
  NR, NW        : WORD;
  TIME          : LONGINT;

BEGIN
  ASSIGN(ALPHAF,ALPHA);
  RESET(ALPHAF,1);
  GETFTIME(ALPHAF,TIME);
  ASSIGN(BETAF,BETA);
  {$I-} REWRITE(BETAF,1) {$I+};
  ERROR := (IORESULT = 5);
  IF ERROR
    THEN
      WRITELN('  Target file is read-only!',#7)
    ELSE
      BEGIN
        REPEAT
          BLOCKREAD(ALPHAF,ABUFF,BUFFSIZE,NR);
          BLOCKWRITE(BETAF,ABUFF,NR,NW);
          ERROR := (NW <> NR)
        UNTIL (NR = 0) OR ERROR;
        CLOSE(ALPHAF);
        IF NOT ERROR THEN SETFTIME(BETAF,TIME);
        CLOSE(BETAF);
        IF ERROR
          THEN
            BEGIN
              WRITELN('  No room for this file!'#7);
              ERASE(BETAF)
            END
        END
END { Internal Procedure DOCOPY };

{ ------ Internal Procedure ------ }

PROCEDURE DOVERI(ALPHA,BETA: STRING; VAR ERROR: BOOLEAN);

{  This internal procedure verifies that file BETA is identical to  file
   ALPHA.  ERROR is set to TRUE if the files are not identical.  }

VAR
  ALPHAF, BETAF : FILE;
  I, NRA, NRB   : WORD;

BEGIN
  ASSIGN(ALPHAF,ALPHA);
  RESET(ALPHAF,1);
  ASSIGN(BETAF,BETA);
  RESET(BETAF,1);
  ERROR := FILESIZE(ALPHAF) <> FILESIZE(BETAF);
  IF NOT ERROR
    THEN
      REPEAT
        BLOCKREAD(ALPHAF,ABUFF,BUFFSIZE,NRA);
        BLOCKREAD(BETAF,BBUFF,BUFFSIZE,NRB);
        ERROR := (NRA <> NRB);
        IF NOT ERROR
          THEN
            FOR I := 1 TO NRA DO
              ERROR := ERROR OR (ABUFF[I] <> BBUFF[I]);
      UNTIL (NRA = 0) OR ERROR;
  CLOSE(ALPHAF);
  CLOSE(BETAF);
  IF ERROR
    THEN
      WRITELN('  Verification error!'#7)
    ELSE
      WRITELN('  Verified.')
END { Internal Procedure DOVERI };

{ ------ Internal Procedure ------ }

PROCEDURE LISTCOPY;  { Internal to DOUPDATE }

{  This internal procedure lists the files to be copied.  }

CONST
  PAD = '             ';

VAR
  LINE : STRING[80];
  K,KM : BYTE;
  N    : INTEGER;
  REC  : STRING[13];

{ ------ Internal Procedure ------ }

PROCEDURE PUTLINE;  { Internal to LISTCOPY }

{  This internal procedure trims and displays each line of files  to  be
   copied.  }

VAR
  LL : BYTE;

BEGIN { PUTLINE }
  LL := ORD(LINE[0]);
  LINE[0] := CHR(0);
  WHILE LINE[LL] = ' ' DO LL := PRED(LL);
  LINE[0] := CHR(LL);
  WRITELN(LINE);
  LINE := '';
  K := 0;
  KM := 6
END { Internal Procedure PUTLINE };

{ ------ Internal Procedure ------ }

BEGIN { Internal Procedure LISTCOPY }
  K := 0;
  KM := 3;
  LINE := '';
  FOR N := 1 TO NCPY DO
    BEGIN
      REC := ALIST[N].NAME+PAD;
      LINE := LINE+REC;
      K := SUCC(K);
      IF K = KM THEN PUTLINE
    END;
  IF K > 0 THEN PUTLINE
END { Internal Procedure LISTCOPY };

{ ------ Internal Procedure ------ }

BEGIN { Procedure DOUPDATE }
  WRITELN;

  WRITELN('Updating files in ',APARM,' to ',BPARM);
  IF ANUMB = 1
    THEN
      WRITELN('    There is one file in ',APARM)
    ELSE
      WRITELN('    There are ',ANUMB,' files in ',APARM);
  IF BNUMB = 1
    THEN
      WRITELN('    There is one file in ',BPARM)
    ELSE
      WRITELN('    There are ',BNUMB,' files in ',BPARM);

  {  Scan the source and target directories for:

       (1) Files in the source directory which are not in  the  target
           directory;  and
       (2) Files in the source directory which are newer than the same
           files in the target directory.

      Do a "pull-down" of the files to be copied in ALIST.  }

  I := 1;
  J := 1;
  NCPY := 0;
  REPEAT
    WHILE BLIST[J].NAME < ALIST[I].NAME DO J := SUCC(J);
    IF  (BLIST[J].NAME <> ALIST[I].NAME) OR
       ((BLIST[J].NAME =  ALIST[I].NAME) AND
        (BLIST[J].TIME <  ALIST[I].TIME))
      THEN
        BEGIN
          NCPY := SUCC(NCPY);
          ALIST[NCPY].NAME := ALIST[I].NAME
        END;
    I := SUCC(I)
  UNTIL I > ANUMB;

  {  Tell how many files to be copied and list them.  }

  IF NCPY = 0
    THEN
      WRITELN('    There are no files to be copied.')
    ELSE
      BEGIN
        IF NCPY = 1
          THEN
            BEGIN
              WRITELN('    There is one file to be copied:  ',ALIST[1].NAME);
              IF VERI THEN WRITELN('    The copy will be verified.')
            END
          ELSE
            BEGIN
              IF NCPY < 10
                THEN
                  J := 4
                ELSE
                  IF NCPY < 100
                    THEN
                      J := 3
                    ELSE
                      J := 2;
              WRITE('    There are ',NCPY,' files to be copied:',SP:J);
              LISTCOPY;
              IF VERI THEN WRITELN('    All copies will be verified.')
            END;

        {  Copy each file and [optionally] verify it.  }

        IF COPY
          THEN
            BEGIN
              WRITELN;
              CHECKBREAK := FALSE;  { Disable Ctl-Break checking. }
              FILEMODE := 0;  { Enable BLOCKREAD of read-only files. }
              CHECKKEYBD;
              IF NOT ERROR
                THEN
                  BEGIN
                    I := 1;
                    REPEAT
                      ALPHA := APATH+ALIST[I].NAME;
                      BETA := BPATH+ALIST[I].NAME;
                      IF I < 10
                        THEN
                          J := 3
                        ELSE
                          IF I < 100
                            THEN
                              J := 2
                            ELSE
                              J := 1;
                      WRITE('(':J,I,'):  ',ALPHA,' ==> ',BETA);
                      DOCOPY(ALPHA,BETA,ERROR);
                      IF VERI AND (NOT ERROR)
                        THEN
                          DOVERI(ALPHA,BETA,ERROR)
                        ELSE
                          WRITELN;
                      CHECKKEYBD;
                      I := SUCC(I)
                    UNTIL (I > NCPY) OR ERROR
                  END
            END
      END
END { Procedure DOUPDATE };

{ -------------------------------- }

PROCEDURE GETLIST(VAR FPARM: PATHNAM;
                  VAR FLIST: FILELST;
                  VAR FNUM : INTEGER);

{  This procedure gets the file names and times for the specified
   file parameter.   Note that files of the form, *.~?? and *.BAK
   are ignored.  }

CONST
  ATTR = 1;  { Ordinary files plus read-only files. }

VAR
  DTA : SEARCHREC;
  N   : WORD;

BEGIN
  N := 0;
  FINDFIRST(FPARM,ATTR,DTA);
  IF DOSERROR = 2
    THEN
      BEGIN
        WRITE(ERRPROL);
        WRITELN('Directory not found.');
        WRITELN('        ',FPARM);
        ERROR := TRUE
      END;
  WHILE (DOSERROR = 0) AND (N < MAXLIST-1) DO
    BEGIN
      IF (POS('.~',  DTA.NAME) = 0) AND
         (POS('.BAK',DTA.NAME) = 0)
        THEN
          BEGIN
            N := SUCC(N);
            FLIST[N].NAME := DTA.NAME;
            FLIST[N].TIME := DTA.TIME
          END;
      FINDNEXT(DTA)
    END;
  FNUM := N
END { Procedure GETLIST };

{ -------------------------------- }

PROCEDURE GETOPTIONS;

{  This procedure checks for the mutually exclusive options, /S and /V
   and sets the copy and verification flags accordingly.  }

VAR
  OPT : STRING[2];

BEGIN
  COPY := TRUE;
  VERI := FALSE;
  IF NPAR = 3
    THEN
      BEGIN
        OPT := PARAMSTR(3);
        IF OPT = '/S'
          THEN
            COPY := FALSE
          ELSE
            IF OPT = '/V'
              THEN
                VERI := TRUE
              ELSE
                WRITELN('        Unknown option, "',OPT,'", ignored.')
      END
END { Procedure GETOPTIONS };

{ -------------------------------- }

PROCEDURE SORTFILE(VAR FLIST: FILELST; FNUMB: INTEGER);

{  This routine sorts the file name array, FLIST, in ascending order,
   using a modified Shell sort algorithm.  FNUMB is the length of the
   array.  }

VAR
  I,IM,J,M : INTEGER;
  SWAP     : BOOLEAN;
  TEMP     : FILEREC;

BEGIN  { Procedure SORTFILE }
  IF FNUMB > 1
    THEN
      BEGIN
        M := 1;
        WHILE M < FNUMB DO M := 2*M;
        M := PRED(M);
        WHILE M > 1 DO
          BEGIN
            M := M DIV 2;
            FOR J:=1 TO FNUMB-M DO
              BEGIN
                I := J;
                REPEAT
                  IM := I+M;
                  SWAP := FLIST[I].NAME > FLIST[IM].NAME;
                  IF SWAP
                    THEN
                      BEGIN
                        TEMP := FLIST[I];
                        FLIST[I] := FLIST[IM];
                        FLIST[IM] := TEMP;
                        I := I-M
                      END
                UNTIL (I < 1 ) OR (NOT SWAP)
              END
          END
      END
END { Procedure SORTFILE };

{ -------------------------------- }

PROCEDURE UPPARMS;

{  This procedure scans the parameter string in the program's command
   tail at offset 0080H and converts all characters to upper case.

   Procedure by Harry M. Murphy,  22 November 1987.
   Updated to Turbo Pascal V4.0 by H.M.M. on 28 November 1987. }

CONST
  CT = $0080;

VAR
  L,LP : 0..127;
  PSPS : WORD;

BEGIN
  PSPS := PREFIXSEG;
  LP := MEM[PSPS:CT];
  IF LP > 0
    THEN
      FOR L := 1 TO LP DO
        IF MEM[PSPS:L+CT] IN [97..122]
          THEN
            MEM[PSPS:L+CT] := MEM[PSPS:L+CT] XOR $20
END { Procedure UPPARMS };

{ -------------------------------- }

PROCEDURE WILDCARD(VAR FPATH, FPARM: PATHNAM);

{  This procedure appends wildcard characters to the file parameter,
   if necessary. }

BEGIN
  IF FPARM = FPATH
    THEN
      FPARM := FPARM+'*.*'
    ELSE
      IF POS('.',FPARM) = 0 THEN FPARM := FPARM+'.*'
END { Procedure WILDCARD };

{ -------------------------------- }

BEGIN { Program UPDATE }
  NORMVIDEO;
  UPPARMS;
  CHECKPARCOUNT(NPAR);
  GETOPTIONS;
  ERROR := FALSE;

  {  Get the source file directory.  }

  APARM := PARAMSTR(1);
  APATH := DIRPATH(APARM);
  WILDCARD(APATH,APARM);
  GETLIST(APARM,ALIST,ANUMB);
  IF ANUMB = 0
    THEN
      BEGIN
        WRITE(ERRPROL);
        WRITELN('The source directory is empty.');
        ERROR := TRUE
      END
    ELSE
      IF ANUMB > 1 THEN SORTFILE(ALIST,ANUMB);

  {  Get the target file directory.  }

  BPARM := PARAMSTR(2);
  BPATH := DIRPATH(BPARM);
  WILDCARD(BPATH,BPARM);
  GETLIST(BPARM,BLIST,BNUMB);
  SORTFILE(BLIST,BNUMB);
  BLIST[BNUMB+1].NAME := '________.___';
  BLIST[BNUMB+1].TIME := MAXLONGINT;

  {  Compare the source and target files and do the update.  }

  IF NOT ERROR THEN DOUPDATE

END.