(********************************************************)
(*							*)
(*          PROJECT 4/PHASE II - TERENCE CHANG          *)
(*							*)
(*  This whopping program is merely a file copier with  *)
(*  3 functions: Copy, Log, and Verify.  It now uses	*)
(*  real tape drives with help of TAPE$SUBS/LIB		*)
(*  and can generate hardcopy.  It is hoped that the	*)
(*  routines will work with no new compatibility	*)
(*  problems.						*)
(*							*)
(********************************************************)

PROGRAM TAPECOPY (INPUT, OUTPUT);

LABEL 9999;

CONST
  LL = '---------------------------------------------------------------';
  GET_AFTER_EOF  = 118; (* These are Pascal codes *)
  ERR_DUR_REW    = 106;
  ERR_DUR_RES    = 105;
  FILE_NOT_FOUND =  29; (* These are now Fortran error codes *)
  ERR_DUR_CLO    =  28;
  ERR_DUR_WRI    =  38;
  END_DUR_REA    =  24;
  ERR_DUR_REA    =  39; (* this one is actually = 1 in routines *)
  DEF_LIMIT = 6       ; (* Number of errors per file before query *)
  FNSIZE = 100	      ; (* Max. length of filename *)	
  LO = 1;
  HI = 65535;
  MAX_LEN = 65535;

TYPE
  LINE       = PACKED ARRAY[1..MAX_LEN] OF CHAR;
  TEXTLINE   = PACKED ARRAY[1..255] OF CHAR;
  MODE       = (None, Copy, Log, Verify, Copy_plus);
  FILENAME   = VARYING[FNSIZE] OF CHAR;
    (* Note: if fn : filename, then fn.length = length of string,
  				    fn.body   = array[1..len] of CHAR *)
  FOR_NAME = PACKED ARRAY[1..FNSIZE] OF CHAR;

VAR
  X_MODE           : MODE        (* Program operation mode *);
  FN, FN_NEW, FN2  : FILENAME    (* Input filename *);
  LOG_FLAG	   : BOOLEAN     (* If true, produce hardcopy *);
  DEF_LOG          : FILENAME    (* Default logical name *);
  FOR_LOG_NAME     : FOR_NAME    (* Converted logical name *);
  INFO		   : TEXT        (* Logged info file_var *);
  ITEM, ITEM2      : LINE        (* Current record *);
  REC_LEN, OLD_LEN : INTEGER     (* Length of record *);
  LAST_REC	   : INTEGER     (* Number of records in last file *);
  FILE_NUM         : INTEGER     (* Total files counter *);
  ERR_LIMIT	   : INTEGER	 (* Number of errors before query *);
  TOTAL_VER	   : INTEGER     (* Total files verified OK *);
  ABORTED          : INTEGER     (* Number of files cancelled by user *);
  VMS_SET          : SET OF CHAR (* Legal filename characters *);
  NUM_SET          : SET OF CHAR (* Legal numeric input characters *);
  TODAYS_DATE,
    CURRENT_TIME   : PACKED ARRAY[1..11] OF CHAR;
  OLD_CLOCK        : INTEGER	 (* CPU time since init *);
  CONT_STATUS      : CHAR        (* If 'Y' or 'y', user wants copy aborted *);

  IOSTAT           : INTEGER     (* Error code for main block *);
  ERR_FLAG         : BOOLEAN     (* If true, halt procedure *);
  ERR_COUNT,
    TEMP_ERR       : INTEGER     (* Number errors during transfer *);
  ASTERISKS	   : LINE        (* Line of 255 asterisks *);

  REC, TEMP_REC    : INTEGER     (* Current record number *);

(*
(* A note about [External] declarations:  the directive that constitutes
(* the routine body is either EXTERN, EXTERNAL, or FORTRAN.  All have
(* the same meaning to the compiler.  I use them for self-documenting
(* my declarations.
(*									*)

[EXTERNAL] PROCEDURE STR$UPCASE
       (%STDESCR DEST_STR, SRCE_STR : PACKED ARRAY[LO..HI : INTEGER] OF CHAR);
        EXTERN;

  (* This declaration almost comes straight out of the R-T Lib Ref *)

(****************************************************************)
(*								*)
(*  STR$UPCASE : Capitalize a packed string array		*)
(*								*)
(****************************************************************)

(*******************************************************************)
(*								   *)
(* TAPE$SUBS/LIB : foreign tape subroutines			   *)
(*								   *)
(* SETUPFT (LUN,CDEV,ISTAT)	         ! Open drive  		   *)
(* RCTAPE (LUN,CBUFF,NBYTE,IBYTE,ISTAT)  ! Reads a record.	   *)
(* WCTAPE (LUN,CBUFF,NBYTE,IBYTE,ISTAT)	 ! Writes a record.	   *)
(* TAPE_EOF (LUN,ISTAT)			 ! Writes an EOF/EOV.      *)
(* REWTAPE (LUN,ISTAT)			 ! Rewinds the file.	   *)
(* SKIPFILE (LUN,NUMB,NSKIP,ISTAT)	 ! Skips to the next file. *)
(*								   *)
(*******************************************************************)

[EXTERNAL(SETUPFT)] PROCEDURE T$OPEN
             (%REF UNIT : INTEGER; %STDESCR FN : FOR_NAME; %REF ERROR : INTEGER);
	     FORTRAN;
             
[EXTERNAL(RCTAPE)] PROCEDURE T$READ 
             (%REF UNIT : INTEGER; %STDESCR BUFFER : LINE; %REF LENGTH : INTEGER;
              %REF IBYTE : INTEGER; %REF ERROR : INTEGER; MODIF : INTEGER);
             FORTRAN;

[EXTERNAL(WCTAPE)] PROCEDURE T$WRITE
             (%REF UNIT : INTEGER; %STDESCR BUFFER : LINE; %REF LENGTH : INTEGER;
              %REF IBYTE : INTEGER; %REF ERROR : INTEGER; MODIF : INTEGER);
             FORTRAN;

[EXTERNAL(TAPE_EOF)] PROCEDURE T$WEOF 
             (%REF UNIT : INTEGER; %REF ERROR : INTEGER);
             FORTRAN;

[EXTERNAL(REWTAPE)] PROCEDURE T$REWIND 
             (%REF UNIT : INTEGER; %REF ERROR : INTEGER; NOWAIT : INTEGER := %IMMED 1);
	     FORTRAN;

[EXTERNAL(SKIPFILE)] PROCEDURE T$SKIP
             (%REF UNIT : INTEGER; %REF NUM : INTEGER; %REF ISKIP : INTEGER;
              %REF ERROR : INTEGER);
	     FORTRAN;

PROCEDURE CAP_VAR (VAR S : FILENAME);

(****************************************************************)
(*								*)
(*  CAP_VAR : Capitalize a varying string array			*)
(*								*)
(*    S : a varying array[fnsize] which is modified		*)
(*								*)
(*  Since Str$UpCase has already been declared using packed	*)
(*  conformant array schema, this procedure converts varying    *)
(*  arrays into the packed array TEMP, which is passed on to	*)
(*  Str$UpCase.							*)
(*								*)
(****************************************************************)

TYPE
  CON_VAR = PACKED ARRAY[1..FNSIZE] OF CHAR;

VAR
  TEMP : CON_VAR (* Converted Varying array *);
  X : INTEGER;

BEGIN
  FOR X := 1 TO S.LENGTH DO TEMP[X] := S[X];
  STR$UPCASE (TEMP, TEMP);
  FOR X := 1 TO S.LENGTH DO S[X] := TEMP[X];
END (* Cap_Var *);

PROCEDURE LOG_LINE (TEMP_REC, LEN : INTEGER);

(****************************************************************)
(*								*)
(*  LOG_LINE : print a line of logging				*)
(*								*)
(*    Temp_Rec : number of records this line			*)
(*    Len : length in bytes this line				*)
(*								*)
(*  Writes 'xxxx records of xxxx bytes' to OUTPUT and INFO.	*)
(*								*)
(****************************************************************)

BEGIN
  WRITE       ('     ', TEMP_REC:4, ' record');
  WRITE (INFO, '     ', TEMP_REC:4, ' record');
  IF TEMP_REC > 1 THEN BEGIN
    WRITE       ('s');
    WRITE (INFO, 's');
    END ELSE BEGIN
      WRITE       (' ');
      WRITE (INFO, ' ');
      END;
  WRITE       (' of ', OLD_LEN:4, ' byte');
  WRITE (INFO, ' of ', OLD_LEN:4, ' byte');
  IF OLD_LEN > 1 THEN BEGIN
    WRITE       ('s');
    WRITE (INFO, 's');
    END;
  WRITELN;
  WRITELN (INFO);
END (* Log_Line *);

PROCEDURE CONVERT_FN (FN : FILENAME; VAR FOR_FN : FOR_NAME);

(****************************************************************)
(*								*)
(*  CONVERT_FN : convert a filename to Class_S array		*)
(*								*)
(*  I almost broke tradition and made this a Function.  This	*)
(*  Procedure converts a filename, which is a Varying[] of CHAR *)
(*  (%DESCR Class_VS), into a Packed Array (%STDESCR Class_S).	*)
(*								*)
(****************************************************************)

VAR
  X : INTEGER (* Temporary counter *);

BEGIN
  FOR X := 1 TO FNSIZE DO FOR_FN[X] := ' ';
  FOR X := 1 TO FN.LENGTH DO FOR_FN[X] := FN[X];
END (* Convert_FN *);

PROCEDURE INITIALIZE;

(****************************************************************)
(*								*)
(*  INITIALIZE : set up miscellaneous variables, etc.		*)
(*								*)
(****************************************************************)

VAR
  X : INTEGER (* Loop counter *);

BEGIN
  VMS_SET := ['A'..'Z', '0'..'9', ' ', '_']; (* Legal characters in VMS 4.1 extension *)

  FOR X := 1 TO 255 DO ASTERISKS[X] := '*';
  ERR_LIMIT := DEF_LIMIT;
  NUM_SET := ['0'..'9'];
  OLD_CLOCK := CLOCK;
  ERR_FLAG := FALSE;
  TOTAL_VER := 0;
  LAST_REC := -1;
  FILE_NUM := 0;
  X_MODE := Log;
  ABORTED := 0;
END (* Initialize *);

PROCEDURE GET_MODE;

(****************************************************************)
(*								*)
(*  GET_MODE : Does the user want Copy, Log, or Verify?		*)
(*								*)
(*  This procedure sets the global variable X_Mode (Xerox Mode) *)
(*  as the user requests. If 'None' is returned, the user has	*)
(*  typed CTRL-Z.						*)
(*								*)
(****************************************************************)

LABEL 1;

VAR
  TEMP : TEXTLINE;

BEGIN
  X_MODE := None;
  WRITELN;
  WRITELN (LL);
  REPEAT
    WRITELN;
    WRITE ('  Select mode of operation [C/L/V or ?/H = Help, ^Z = Exit]: ');
    RESET (INPUT);
    READ (TEMP, ERROR := CONTINUE);
    IF STATUS (INPUT) = GET_AFTER_EOF THEN GOTO 1 (* ^Z input *);
    STR$UPCASE (TEMP, TEMP);
    WRITELN;
    STR$UPCASE (TEMP, TEMP);
    CASE TEMP[1] OF
      'C' : BEGIN
              X_MODE := Copy;
	      WRITE ('  Would you like automatic Verify after Copy (Y/N) [N] ? ');
	      RESET (INPUT);
	      READ (TEMP, ERROR := CONTINUE);
	      IF STATUS (INPUT) = GET_AFTER_EOF THEN GOTO 1;
	      STR$UPCASE (TEMP, TEMP);
	      IF TEMP[1] = 'Y' THEN X_MODE := Copy_plus;
	    WRITELN;
            END;
      'L' : X_MODE := Log;
      'V' : X_MODE := Verify;
      '?', '/', 'H' : BEGIN
                   WRITELN;
                   WRITELN ('  This program is a tape copier which has 3 modes of operation:');
                   WRITELN ('  C)opy, L)og, and V)erify. This program cannot destroy data,');
                   WRITELN ('  but its use is not recommended for entertainment purposes.');
                   WRITELN;
		   WRITELN ('  Copy   : copies a tape <MT0 to MT1>');
		   WRITELN ('  Log    : gives a description of tape <MT0>');
		   WRITELN ('  Verify : compares two tapes and reports discrepancies');
		   WRITELN;
                   WRITELN ('  Default drive names are given within a pair of < >.');
                 END;
      END (* Case *);
  UNTIL (X_MODE <> None);
1:END (* Get_Mode *);

PROCEDURE GET_OUTPUT;

(****************************************************************)
(*								*)
(*  GET_OUTPUT : get specifications for information output	*)
(*								*)
(*  This procedure determines where the informational output	*)
(*  should go. All of the Writes not concerning the tapes	*)
(*  are directed to file_variable INFO, which has a disk	*)
(*  filename TAPE.LOG.	This is printed if so requested by the	*)
(*  user and deleted.  Sets global variable Log_Flag.		*)
(*								*)
(****************************************************************)

LABEL 1;

VAR
  TEMP : FILENAME (* Temporary string *);

BEGIN
  WRITE ('  Produce hardcopy of TAPECOPY session (Y/N) [N] ? ');
  RESET (INPUT);
  READ (TEMP, ERROR := CONTINUE);
  CAP_VAR (TEMP);
  IF TEMP.LENGTH = 0 THEN GOTO 1;
  LOG_FLAG := (TEMP[1] = 'Y');

1: (* Ready TAPE.LOG for writing *)
  IF LOG_FLAG THEN
    OPEN (FILE_VARIABLE := INFO,
          FILE_NAME     := 'TAPE.LOG',
          HISTORY	:= NEW,
	  DISPOSITION   := PRINT)
  ELSE
    OPEN (FILE_VARIABLE := INFO,      (* Open virtual file *)
	  DISPOSITION	:= DELETE);
  REWRITE (INFO);

END (* Get_Output *);

PROCEDURE GET_FN (PROMPT : FILENAME; VAR FN : FILENAME);

(****************************************************************)
(*								*)
(*  GET_FN : Get a FileName					*)
(*								*)
(*    Prompt : A string written before requesting input		*)
(*    FN : The varying array that the filename is returned to	*)
(*								*)
(*  This is a straight-forward input routine. If "Exit" or	*)
(*  Ctrl-Z is entered, global variable X_Mode is set to "None".	*)
(*  Uses implicit parameter DEF_LOG.				*)
(****************************************************************)

(* X_Mode is set to "None" if a Ctrl-Z or "Exit" has *)
(* been entered in response to the prompt            *)

LABEL 1,2;

VAR
  OLDLEN : INTEGER (* Temporary FN.Length holder *);

BEGIN
  WRITELN;
  WRITELN (LL);
  WRITELN;
2:WRITE (PROMPT,' <', DEF_LOG, '> [^Z = Quit] : ');
  RESET (INPUT);
  READ (FN, ERROR := CONTINUE);
  WRITELN;
  CAP_VAR (FN);
  OLDLEN := FN.LENGTH;
  IF (OLDLEN = 0) AND (STATUS (INPUT) = 0) THEN BEGIN
    FN := DEF_LOG;
    GOTO 1;
    END;
  FN.LENGTH := 4;
  IF (STATUS (INPUT) = GET_AFTER_EOF) OR    (* Is there a better way? *)
     (FN[1]+FN[2]+FN[3]+FN[4] = 'EXIT') THEN BEGIN
       X_MODE := None;
       GOTO 1;
       END (* IF *);
  IF STATUS (INPUT) > 0 THEN WRITELN ('Status(INPUT) = ',STATUS(INPUT):3);
  FN.LENGTH := OLDLEN;
1 : END (* GET_FN *);

PROCEDURE BYE;

(****************************************************************)
(*								*)
(*  BYE : Give farewell message					*)
(*								*)
(****************************************************************)

VAR
  X : INTEGER;
  ET : REAL (* Elapsed time *);

BEGIN
  DATE (TODAYS_DATE);
  TIME (CURRENT_TIME);
  ET := CLOCK - OLD_CLOCK (* Calculate elapsed Cpu time *);
  ET := ET/1000;
  WRITELN;
  WRITELN (LL);
  WRITELN;
  WRITE       ('  TAPECOPY session completed on ',TODAYS_DATE,' at ');
  FOR X := 1 TO 5 DO WRITE (CURRENT_TIME[X]);
  WRITELN;
  WRITE       ('  Mode selected : ');
  CASE X_MODE OF
    Log : WRITELN ('Log');
    Copy : WRITELN ('Copy');
    None : WRITELN ('----');
    Verify : WRITELN ('Verify');
    Copy_plus : WRITELN ('Copy with Verify');
    END (* Case *);
  WRITELN ('  Files aborted : ', ABORTED:1);
  WRITELN ('  Cpu time (s)  : ', ET:1:2);
  WRITE ('  Hardcopy log  : ');
  CASE LOG_FLAG OF
    True : WRITELN ('Enabled');
    False : WRITELN ('Not enabled');
    END (* Case *);
  WRITELN;
  WRITELN (LL);
  WRITELN;

IF LOG_FLAG THEN BEGIN
  WRITELN (INFO);
  WRITELN (INFO, LL);
  WRITELN (INFO);
  WRITE (INFO, '  TAPECOPY session completed on ',TODAYS_DATE,' at ');
  FOR X := 1 TO 5 DO WRITE (INFO, CURRENT_TIME[X]);
  WRITELN (INFO);
  WRITE (INFO, '  Mode selected : ');
  CASE X_MODE OF
    Log : WRITELN (INFO, 'Log');
    Copy : WRITELN (INFO, 'Copy');
    None : WRITELN (INFO, '----');
    Verify : WRITELN (INFO, 'Verify');
    Copy_plus : WRITELN (INFO, 'Copy with Verify');
    END (* Case *);
  WRITELN (INFO, '  Files aborted : ', ABORTED:1);
  WRITELN (INFO, '  Cpu time (s)  : ', ET:1:2);
  WRITE   (INFO, '  Hardcopy log  : ');
  CASE LOG_FLAG OF
    True : WRITELN (INFO, 'Enabled');
    False : WRITELN (INFO, 'Not enabled');
    END (* Case *);
  WRITELN (INFO);
  WRITELN (INFO, LL);
  WRITELN (INFO);
END (* If *);
END;
    
PROCEDURE PHOTOCOPY;

(****************************************************************)
(*								*)
(*  PHOTOCOPY - copy or log a tape file				*)
(*								*)
(*  This procedure could not be parameterized because Pascal,	*)
(*  it appears, will not pass file variables (there may be a	*)
(*  way	around it, but it's not worth finding).			*)
(*								*)
(****************************************************************)

LABEL 1,2;

VAR
  LEN : INTEGER (* Length of record *);
  NUM : INTEGER (* Number of bytes actually written *);
  X   : INTEGER (* Temporary counter *);
  STAT : INTEGER (* IOSTAT result on tape routines *);
  ERROR : INTEGER (* IOSTAT's that are ignored *);
  R_STAT : BOOLEAN (* Replaces EOF function *);

BEGIN
    ERR_FLAG := FALSE;

    STAT := 0;		      (* No error condition *);
    R_STAT := FALSE;	      (* Not at EOF *);
    OLD_LEN := -1             (* No previous length *);
    REC := 0; TEMP_REC := REC (* No records read yet *);
    TEMP_ERR := 0;	      (* No errors this file *);
    CONT_STATUS := 'N'	      (* Don't abort file *);

(****************************************************************)
(*								*)
(*  Main Photocopy loop begins here.				*)
(*								*)
(****************************************************************)

    WHILE NOT R_STAT DO BEGIN
      T$READ (42, ITEM, MAX_LEN, LEN, STAT, 0) (* Get a record *);

      (* Enter error-handling block? *)

      R_STAT := (STAT = 2) OR (STAT = 4) (* R_Stat emulates the EOF function *);
      IF STAT = 6 THEN BEGIN
        ERR_COUNT := ERR_COUNT + 1;
        TEMP_ERR := TEMP_ERR + 1;
        WRITELN       ('      *** Unrecoverable I/O error, number ', STAT:1, ' at record ', REC+1:3, ' ***');
        WRITELN (INFO, '      *** Unrecoverable I/O error, number ', STAT:1, ' at record ', REC+1:3, ' ***');
        IF X_MODE <> Log THEN T$WRITE (43, ASTERISKS, OLD_LEN, NUM, ERROR, 0);

        (* Report error count to user? *)

        IF TEMP_ERR MOD DEF_LIMIT = 0 THEN BEGIN
          WRITE ('      ', TEMP_ERR:1, ' errors so far. Abort this file (Y/N) [N] ? ');
          RESET (INPUT);
          READ (CONT_STATUS);
          WRITELN;
          STR$UPCASE (CONT_STATUS, CONT_STATUS);
          IF CONT_STATUS = 'Y' THEN BEGIN
            IF X_MODE <> Log THEN T$WEOF (43, STAT) (* Mark end of this file *);
            WRITELN (INFO);
            WRITELN (INFO, '  <<< File aborted >>>');
            ABORTED := ABORTED + 1;
            ERR_FLAG := TRUE;
            GOTO 1;
            END;
          END (* If temp_err ... *);

        END

      ELSE BEGIN

      (* No, record read successfully *)      
      (* Determine whether or not new length *)

        REC := REC + 1;
        TEMP_REC := TEMP_REC + 1;
        IF (X_MODE <> Log) AND (NOT R_STAT) THEN BEGIN
          T$WRITE (43, ITEM, LEN, NUM, ERROR, 0);
          if error > 1 then writeln ('**** ERROR : T$WRITE ',ERROR:1);
          END;
        IF (REC = 1) AND (NOT R_STAT) THEN BEGIN (* Yes, this is a file *)
          FILE_NUM := FILE_NUM + 1;
          WRITELN;
          WRITELN ('  File : ',FILE_NUM:1);
          WRITELN;
          WRITELN (INFO);
          WRITELN (INFO, '  File : ',FILE_NUM:1);
          WRITELN (INFO);
	  END;
        IF LEN <> OLD_LEN THEN BEGIN
          IF OLD_LEN > -1 THEN LOG_LINE (TEMP_REC, LEN);

          (* New previous length, no temp_rec's read *)

          OLD_LEN := LEN; TEMP_REC := 0;
          END (* If Len <> Old_Len *);

        END (* Else *);

    END (* While NOT EOF *);

(****************************************************************)
(*								*)
(*  The copying loop ends here.  The remaining code prints	*)
(*  a final report and writes the last EOF.			*)
(*								*)
(****************************************************************)

    (* Print final "xxxx records of xxx bytes" *)

    REC := REC - 1 (* Ignore the EOF record *);
    IF REC = 0 THEN GOTO 2;
    (*LOG_LINE (TEMP_REC, LEN);*)

    (* Print file summary *)
  
    WRITELN       ('     ----');
    WRITELN (INFO, '     ----');
    WRITELN       ('     ', REC:4, ' total records');
    WRITELN (INFO, '     ', REC:4, ' total records');
    IF TEMP_ERR > 0 THEN BEGIN
      WRITE       ('     ', TEMP_ERR:4, ' unrecoverable error');
      WRITE (INFO, '     ', TEMP_ERR:4, ' unrecoverable error');
      IF TEMP_ERR > 1 THEN BEGIN
        WRITELN ('s');
        WRITELN (INFO, 's');
        END
      ELSE BEGIN
        WRITELN;
        WRITELN (INFO);
        END;
      END (* If Temp_Err *);
    IF X_MODE <> Log THEN T$WEOF (43, STAT);
2:  WRITELN       ('  >> EOF <<');
    WRITELN (INFO, '  >> EOF <<');
    LAST_REC := REC (* Will equal zero if EOF reached with no records read *);

1: END (* COPY *);

PROCEDURE GIVE_TOTALS;

(****************************************************************)
(*								*)
(* Give_Totals : give final copy volume results			*)
(*								*)
(****************************************************************)

BEGIN
  WRITELN;
  WRITELN (INFO);
  WRITELN       ('  TOTALS :');
  WRITELN (INFO, '  TOTALS :');
  WRITE       ('     ', FILE_NUM:2, ' file');
  WRITE (INFO, '     ', FILE_NUM:2, ' file');
  IF FILE_NUM <> 1 THEN BEGIN
    WRITE       ('s');
    WRITE (INFO, 's');
    END;
  WRITELN       (' processed');
  WRITELN (INFO, ' processed');
  IF ERR_COUNT > 0 THEN BEGIN
    WRITE       ('     ', ERR_COUNT:2, ' unrecoverable I/O error');
    WRITE (INFO, '     ', ERR_COUNT:2, ' unrecoverable I/O error');
    IF ERR_COUNT > 1 THEN BEGIN
      WRITELN       ('s');
      WRITELN (INFO, 's');
      END
    ELSE BEGIN
      WRITELN;
      WRITELN (INFO);
      END;
  END (* If *);
END (* Give_Totals *);

PROCEDURE PHOTOCOPY_MCP;

(****************************************************************)
(*								*)
(*  PHOTOCOPY_MCP - copy or log a tape volume			*)
(*								*)
(*  This procedure calls Photocopy, counts the files, and	*)
(*  checks for the end of the volume.				*)
(*								*)
(****************************************************************)

LABEL 1;

VAR
  STAT : INTEGER (* Temporary error code holder *);
  NSKIP : INTEGER (* number of files actually skipped *);

  BEGIN
    ERR_FLAG := FALSE;
    STAT := 0;
    T$REWIND (42, STAT, 0);

    IF X_MODE <> Log THEN T$REWIND (43, STAT, 0);
  (*
  (*  All the files needed for the operation have been initialized
  (*  and readied.  Now for a control loop that calls Photocopy.
  (*									*)
  WRITELN;
  WRITELN (INFO);
  WRITELN       ('  Drive name : ', FN);
  WRITELN (INFO, '  Drive name : ', FN);

  WHILE (LAST_REC <> 0) DO BEGIN
    PHOTOCOPY;
    IF (ERR_FLAG = TRUE) AND (CONT_STATUS = 'Y') THEN BEGIN
      T$SKIP (42, 1, NSKIP, STAT);
      IF X_MODE <> Log THEN T$SKIP (43, 1, NSKIP, STAT);
      END;
    END;
  GIVE_TOTALS;

1:END (* PHOTOCOPY_MCP *);

PROCEDURE PHOTOVERIFY;

(****************************************************************)
(*								*)
(*  PHOTOVERIFY - verify two files (FN and FN2)			*)
(*								*)
(*  Since Verify mode is so different from the other two,	*)
(*  I have recopied the Photocopy procedure and altered it	*)
(*  to fit the specifications.					*)
(*								*)
(*  Uses global variables REC, ITEM, ITEM2, ERR_LIMIT,		*)
(*  CONT_STATUS, ERR_COUNT.		*)
(****************************************************************)

LABEL 1;

VAR
  LEN, LEN2 : INTEGER (* Length of record *);
  STAT,
    STAT2 : INTEGER (* IOSTAT results *);
  R_STAT,
    R_STAT2 : BOOLEAN (* Replaces Pascal EOF function *);
  V_STAT    : BOOLEAN (* Verify contents status *);
  REC_LEFT  : INTEGER (* Remaining records on still open file *);
  X         : INTEGER (* Temporary counter *);
  TEMP_E    : INTEGER (* Number of errors this cycle *);
  TEMP      : FILENAME (* Temporary string *);

BEGIN
    ERR_FLAG := FALSE;
    STAT := 0;
    STAT2 := 0;

    REC := 0                  (* No records read yet *);
    ERR_COUNT := 0            (* No errors *);
    TEMP_E := ERR_LIMIT       (* No errors *);
    R_STAT := FALSE;
    R_STAT2 := FALSE;	      (* Not at EOF's yet *)
    CONT_STATUS := 'N';

(****************************************************************)
(*								*)
(*  Main PhotoVerify loop begins here.				*)
(*								*)
(****************************************************************)

    WHILE (NOT R_STAT) AND (NOT R_STAT2) DO BEGIN
      T$READ (42, ITEM, MAX_LEN, LEN,  STAT, 0)  (* Get a pair of records *);
      T$READ (43, ITEM2,MAX_LEN, LEN2, STAT2,0);
      R_STAT := (STAT = 2) OR (STAT = 4);
      R_STAT2 := (STAT2 = 2) OR (STAT = 4);

      (* Enter error-handling block? *)

      IF (STAT = 6) OR (STAT2 = 6) THEN BEGIN (* Keep logic simple, be redundant *)
        IF STAT = 6 THEN BEGIN
          WRITELN       ('  *** Unrecoverable I/O error on input, at record ',REC+1:4, ' ***');
          WRITELN (INFO, '  *** Unrecoverable I/O error on input, at record ',REC+1:4, ' ***');
          ERR_COUNT := ERR_COUNT + 1;
          TEMP_E := TEMP_E - 1;
	  END;
        IF STAT2 = 6 THEN BEGIN
          WRITELN       ('  *** Unrecoverable I/O error on output, at record ',REC+1:4, ' ***');
          WRITELN (INFO, '  *** Unrecoverable I/O error on output, at record ',REC+1:4, ' ***');
          ERR_COUNT := ERR_COUNT + 1;
          TEMP_E := TEMP_E - 1;
          END
        END

      ELSE BEGIN (* Records read OK, check 'em out *)
      
        REC := REC + 1;
        IF (REC = 1) AND ((NOT R_STAT) OR (NOT R_STAT2)) THEN BEGIN
          FILE_NUM := FILE_NUM + 1;
          WRITELN;
          WRITELN (INFO);
          WRITELN       ('  File ',FILE_NUM:3);
          WRITELN (INFO, '  File ',FILE_NUM:3);
          END;

        (* Check records for errors in size, content *)

        IF LEN <> LEN2 THEN BEGIN (* Length of item doesn't match its counterpart *)
          WRITE       ('  *** Record ', REC:4, ' : Non-matching record size.  ');
          WRITE (INFO, '  *** Record ', REC:4, ' : Non-matching record size.  ');
          WRITELN (LEN:3, ' - ', LEN2:3);
          WRITELN (INFO, LEN:3, ' - ', LEN2:3);
	  ERR_COUNT := ERR_COUNT + 1;
          TEMP_E := TEMP_E - 1;
          END;

        IF (LEN = LEN2) THEN BEGIN (* Smart compare *)
          V_STAT := FALSE;
          FOR X := 1 TO LEN DO IF ITEM [X] <> ITEM2 [X] THEN V_STAT := TRUE;
          (* Note: V_Stat must be set only if true *)
          IF V_STAT THEN BEGIN
            WRITELN       ('  *** Record ', REC:4, ' : Non-matching data.');
            WRITELN (INFO, '  *** Record ', REC:4, ' : Non-matching data.');
            ERR_COUNT := ERR_COUNT + 1;
            TEMP_E := TEMP_E - 1;
            END;
          END (* If (Len = Len2)... *);

      END (* ELSE BEGIN *);

      IF TEMP_E <= 0 THEN BEGIN
        WRITE ('      ', ERR_COUNT:1, ' errors so far. Abort this file (Y/N) [N] ? ');
        RESET (INPUT);
        READ (CONT_STATUS);
        WRITELN;
        STR$UPCASE (CONT_STATUS, CONT_STATUS);
        IF CONT_STATUS = 'Y' THEN BEGIN
          ABORTED := ABORTED + 1;
          ERR_FLAG := TRUE;
          GOTO 1;
          END
        ELSE BEGIN
          WRITE ('      How many more errors before re-prompting [', ERR_LIMIT:1, '] ? ');
          RESET (INPUT);
          READ (TEMP, ERROR := CONTINUE);
          IF TEMP.LENGTH > 0 THEN BEGIN
            ERR_LIMIT := 0;
            FOR X := 1 TO TEMP.LENGTH DO IF TEMP[X] IN NUM_SET THEN ERR_LIMIT := ERR_LIMIT + (ORD (TEMP[X]) - 48) * 10 ** (TEMP.LENGTH - X);
            IF ERR_LIMIT <= 0 THEN ERR_LIMIT := DEF_LIMIT;
            END;
          TEMP_E := ERR_LIMIT;
          WRITELN;
          END;
        END (* If Err_Count ... *);

    END (* While NOT EOF *);

(****************************************************************)
(*								*)
(*  Main loop of Photoverify ends here.  Some code that is not  *)
(*  in Photocopy is necessary if an unexpected EOF is found.	*)
(*								*)
(****************************************************************)

  IF R_STAT <> R_STAT2 THEN BEGIN

      (* Oops, records still remaining on a file *)
	
      WRITE       ('  *** Record ', REC:4, ' : Unexpected EOF on ');
      WRITE (INFO, '  *** Record ', REC:4, ' : Unexpected EOF on ');
      ERR_COUNT := ERR_COUNT + 1;
      REC_LEFT := 0;

      IF R_STAT = TRUE THEN BEGIN (* Count records on FN *)
        WRITELN (FN);
        WRITELN (INFO, FN);
	WHILE NOT R_STAT2 DO BEGIN
          T$READ (43, ITEM2, MAX_LEN, LEN2, STAT2, 0);
	  R_STAT2 := (STAT2 = -1);
	  REC_LEFT := REC_LEFT + 1;
	  END (* While *);
        WRITELN       ('                  : ', FN2,' has ', REC_LEFT:4,' more records.');
        WRITELN (INFO, '                  : ', FN2,' has ', REC_LEFT:4,' more records.');
        END

      ELSE IF R_STAT2 = TRUE THEN BEGIN (* Count records on FN2 *)
        WRITELN (FN2);
        WRITELN (INFO, FN2);
        WHILE NOT R_STAT DO BEGIN
	  T$READ (42, ITEM, MAX_LEN, LEN, STAT, 0);
          R_STAT := (STAT = -1);
	  REC_LEFT := REC_LEFT + 1;
	  END (* While *);
        WRITELN       ('                  : ', FN,' has ', REC_LEFT:4,' more records.');
        WRITELN (INFO, '                  : ', FN,' has ', REC_LEFT:4,' more records.');
      END (* ELSE *);
  END (* If *);

  LAST_REC := REC - 1 (* Don't count EOF as record *);
  IF (ERR_COUNT = 0) AND (LAST_REC > 0) THEN BEGIN
    WRITELN       ('  >>> Verified <<<');
    WRITELN (INFO, '  >>> Verified <<<');
    TOTAL_VER := TOTAL_VER + 1;
    END
  ELSE IF LAST_REC > 0 THEN BEGIN
    WRITELN       ('  >>> NOT Verified <<<');
    WRITELN (INFO, '  >>> NOT Verified <<<');
    END;

1: END (* PhotoVerify *);

PROCEDURE PHOTOVERIFY_MCP;

(****************************************************************)
(*								*)
(*  PHOTOVERIFY_MCP - verify a tape volume			*)
(*								*)
(*  This procedure calls PhotoVerify, counts the files, and	*)
(*  checks for the end of the volume.				*)
(*								*)
(*  Uses globals FOR_HIST, ERR_FLAG, FN, FN2, FILE_NUM,		*)
(*  TOTAL_VER							*)
(****************************************************************)

LABEL 1;

VAR
  STAT2 : INTEGER (* IOSTAT result *);
  NSKIP : INTEGER (* number of files actually skipped *);

BEGIN
  ERR_FLAG := FALSE;
  FILE_NUM := 0;
  LAST_REC := -1;

  T$REWIND (42, STAT2, 1) (* Don't wait for this one to rewind *);
  T$REWIND (43, STAT2, 0);

  WRITELN;
  WRITELN (INFO);
  WRITELN       ('  Drives : ', FN, ' --- ', FN2);
  WRITELN (INFO, '  Drives : ', FN, ' --- ', FN2);

  WHILE (LAST_REC <> 0) DO BEGIN
    PHOTOVERIFY;
    IF (ERR_FLAG = TRUE) AND (CONT_STATUS = 'Y') THEN BEGIN
      T$SKIP (42, 1, NSKIP, STAT2);
      T$SKIP (43, 1, NSKIP, STAT2);
      END;
    END;

  WRITELN;
  WRITELN (INFO);
  WRITELN      ('  Total ',TOTAL_VER:1,' out of ',FILE_NUM:1,' files verified.');
  WRITELN (INFO,'  Total ',TOTAL_VER:1,' out of ',FILE_NUM:1,' files verified.');
1:END (* Photoverify_MCP *);

(****************************************************************)
(*								*)
(*  MAIN BLOCK 							*)
(*								*)
(*  Calls all the above procedures. The GOTO 9999's indicate	*)
(*  a jump to halt program execution.				*)
(*								*)
(****************************************************************)

BEGIN
  INITIALIZE;
  IOSTAT := 0;
  DEF_LOG := 'MT0';
  GET_FN ('  Enter source drive name', FN);
    IF X_MODE = None THEN GOTO 9999;
  GET_MODE    (* Which mode of operation? *);
    IF X_MODE = None THEN GOTO 9999;
  GET_OUTPUT  (* Where shall the output go? *);

  CONVERT_FN (FN, FOR_LOG_NAME);
  T$OPEN (42, FOR_LOG_NAME, IOSTAT);
  IF X_MODE <> Log THEN BEGIN
    IF ERR_FLAG = TRUE THEN GOTO 9999;
    WRITELN;
    WRITELN (INFO);
    DEF_LOG := 'MT1';
    GET_FN ('  Enter second drive name', FN2);
    IF X_MODE = None THEN GOTO 9999;
    CONVERT_FN (FN2, FOR_LOG_NAME);
    T$OPEN (43, FOR_LOG_NAME, IOSTAT);
    if iostat > 1 then writeln ('**** ERROR T$OPEN ',iostat:1);
    END;

  WRITELN;
  WRITELN (INFO);
  CASE X_MODE OF
    Copy, Log : PHOTOCOPY_MCP; (* MCP = Master Control Procedure *)
    Verify    : PHOTOVERIFY_MCP;
    Copy_plus : BEGIN
                  PHOTOCOPY_MCP;
                  WRITELN;
                  WRITELN (INFO);
                  WRITELN       ('  >> Beginning Verification Pass <<');
                  WRITELN (INFO, '  >> Beginning Verification Pass <<');
	          PHOTOVERIFY_MCP;
                END;
    END (* CASE *);
9999 : BYE;
       END.