HARD$DISK$BACKUP:  do;

/************************************************************************/
/*																		*/
/*     'Copyright 1981,1983 Intel Corporation'.  All rights reserved.	*/
/*      No part of this program or publication may be reproduced,		*/
/*      transmitted, transcribed, stored in a retrievel system, or		*/
/*      translated into any language or computer language, in any		*/
/*      form or by any means, electronic, mechanical, magnetic,			*/
/*      optical, chemical, manual or otherwise, without the prior		*/
/*      written permission of Intel Corporation, 3065 Bowers			*/
/*      Avenue, Santa Clara, California, 95051, Attn: Software			*/
/*      License Administration.											*/
/*																		*/
/************************************************************************/

$IF XVERSION
DECLARE PROPRIETARY(*) BYTE DATA ('INTEL PROPRIETARY SOFTWARE');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=X222',0);
$ELSE
DECLARE COPYRIGHT (*) BYTE DATA  ('COPYRIGHT 1981,1983 INTEL ');
DECLARE PROGRAM$VERSION$NUMBER$STRING (*) BYTE DATA
    ('program_version_number=V2.3',0);
$ENDIF

    


/**********************************************************************
 *                                                                    *
 * This program is designed to be used in backing up a hard disk      *
 * platter to floppy disks.  It allows wildcard filenames as well     *
 * as the additional selection based on the file attributes.          *
 * Invocation is as follows:                                          *
 *                                                                    *
 *    [:F#:]BACKUP filename [{W{0|1} I{0|1} S{0|1}}] [C] [DELETE]     *
 *        where:  filename ::= pathname | device                      *
 *                device ::= :Fn:                                     *
 *                                                                    *
 * The interpretation when an attribute is used is to backup the file *
 * only if there is a filename match and the attribute is set(reset)  *
 * By not specifying the attribute, the all of the attributes will    *
 * be ignored (except for the Format attribute).                      *
 * Files with the Format attribute will never be copied.              *
 *                                                                    *
 * The files are always transfered to drive 5 first, then drive 4,... *
 *                                                                    *
 * If the C switch is used, then the attributes of the target files   *
 * are retained in the backup files.                                  *
 *                                                                    *
 * if the DELETE switch is used, then all files without the format    *
 * attribute on the target disk will be deleted                       *
 *                                                                    *
 **********************************************************************/


/* The following literally declarations are used to map PLM80 into
   PLM86 code
*/

declare word literally 'address';
declare integer literally 'address';
declare pointer literally 'address';


declare as literally 'literally';
declare dcl as 'declare';

dcl boolean as 'byte';
dcl true as '0FFH';
dcl false as '0';
dcl ptr as 'word';
dcl nil as '0';
dcl character as 'byte';
dcl char2 as 'word';
dcl varying as '1';

dcl for as 'do';
dcl endfor as 'end';
dcl thenn as 'then do;';
dcl elseif as 'end; else if';
dcl elsee as 'end; else do;';
dcl endif as 'end';
dcl whilee as 'do while';
dcl endwhile as 'end';
dcl endproc as 'end';
dcl endmod as 'end';
dcl enddo as 'end';


dcl COMMA as ''',''';
dcl CR as '0DH';
dcl LF as '0AH';
dcl ESC as '1BH';
dcl AMPERSAND as '''&''';

$IF XVERSION
dcl VERSION(4) character initial('X222');
$ELSE
dcl VERSION(4) character initial('V2.3');
$ENDIF
dcl COMMAND$LINE(128) character;
dcl COMMAND$PTR ptr;
dcl COMMAND$LINE$LENGTH word;
dcl BACKUP$PARM$BLOCK structure(
    DEVICE(4) character,
    FILENAME(11) character,
    W$ATTR boolean,
    S$ATTR boolean,
    I$ATTR boolean,
    CHANGE$W byte,
    CHANGE$S byte,
    CHANGE$I byte,
    OUTPUT$LIST$ELEMENTS byte,
    OUTPUT$LIST(4) character);
dcl (ACTUAL, STATUS) word;
dcl SELECTED$DEVICE(10) boolean initial(
     false,false,false,false,false,false,false,false,false,false);

dcl DELETE$OPTION boolean public initial(false); /*default-- nodelete*/
DCL keep$attribs BOOLEAN PUBLIC INITIAL(FALSE);

EXIT: procedure external;
end EXIT;

READ: procedure(AFTN, BUF$PTR, LEN, ACTUAL$PTR, STATUS$PTR) external;
   dcl (AFTN,LEN) word;
   dcl (BUF$PTR, ACTUAL$PTR, STATUS$PTR) pointer;
end READ;

WRITE: procedure(AFTN, BUF$PTR, LEN, STATUS$PTR) external;
   dcl (AFTN, LEN) word;
   dcl (BUF$PTR, STATUS$PTR) pointer;
end WRITE;


write$co: PROCEDURE(buf$ptr,len) PUBLIC;
  DCL buf$ptr POINTER, len WORD;
  CALL write(0,buf$ptr,len,.status);
END write$co;

write$co$crlf: PROCEDURE PUBLIC;
  CALL write(0,.(CR,LF),2,.status);
END write$co$crlf;


ERROR: procedure(STRING$PTR, PTR1);
   dcl (STRING$PTR, PTR1) pointer;
   dcl STRING based STRING$PTR (varying) character;
   dcl I word;

   call write$co(.('ERROR, NEAR #, ',CR,LF),17);
   call write$co(.COMMAND$LINE, PTR1 - .COMMAND$LINE);
   call write$co(.('#'),1);
   call write$co(.COMMAND$LINE(PTR1 - .COMMAND$LINE),
                   COMMAND$LINE$LENGTH - (PTR1 - .COMMAND$LINE));
   call write$co$crlf;
   
   I = 0;
   whilee STRING(I) <> 0;
      I = I + 1;
   endwhile;
   if I <> 0 thenn
      call write$co(STRING$PTR,I);
      call write$co$crlf;
   endif;
   call EXIT;
end ERROR;


SIGN$ON: procedure(VERSION$PTR);
   dcl VERSION$PTR pointer;

   call write$co(.(CR,LF,'ISIS-II HARD-DISK BACKUP PROGRAM, '),36);
   call write$co(VERSION$PTR,4);
   call write$co$crlf;
end SIGN$ON;

DEBLANK: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;

   do while (CHAR1 = ' ') OR (char1 = 09H); /* HT */
      PTR1 = PTR1 + 1;
   enddo;
   return PTR1;
endproc DEBLANK;

GET$DEVICE: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;
   dcl DEFAULT$DEVICE(*) character data(':F0:');

   if CHAR1 = ':' thenn
      call move(length(BACKUP$PARM$BLOCK.DEVICE), PTR1, .BACKUP$PARM$BLOCK.DEVICE);
      PTR1 = PTR1 + 2;
      if CHAR1 >= '0' and CHAR1 <= '9' thenn
         SELECTED$DEVICE(CHAR1 - '0') = true;
      endif;
      PTR1 = PTR1 + 2;
   elsee
      call move(length(DEFAULT$DEVICE), .DEFAULT$DEVICE, .BACKUP$PARM$BLOCK.DEVICE);
      SELECTED$DEVICE(0) = true;
   endif;
   return PTR1;
endproc GET$DEVICE;

GET$FILENAME: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;
   dcl NULLS(*) character data(0,0,0,0,0,0,0,0,0,0,0,0);
   dcl INDEX byte;
   dcl DEFAULT$FILES(*) character data('*.*',0);
   
   call move(length(BACKUP$PARM$BLOCK.FILENAME), .NULLS,
                   .BACKUP$PARM$BLOCK.FILENAME);
   INDEX = 0;
   whilee true;
      if (CHAR1 >= 'A' and CHAR1 <= 'Z') or
         (CHAR1 >= '0' and CHAR1 <= '9') or
         CHAR1 = '*' or CHAR1 = '.' or CHAR1 = '?' thenn
         BACKUP$PARM$BLOCK.FILENAME(INDEX) = CHAR1;
      elsee
         if INDEX = 0 thenn /* no files specified, use *.* */
            call move(length(DEFAULT$FILES), .DEFAULT$FILES,
                        .BACKUP$PARM$BLOCK.FILENAME);
         endif;
         return PTR1;
      endif;
      PTR1 = PTR1 + 1;
      INDEX = INDEX + 1;
   endwhile;
   return PTR1;
endproc GET$FILENAME;

COLLECT$ATTRIBUTES: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;

   BACKUP$PARM$BLOCK.W$ATTR, BACKUP$PARM$BLOCK.S$ATTR,
        BACKUP$PARM$BLOCK.I$ATTR, BACKUP$PARM$BLOCK.CHANGE$W,
        BACKUP$PARM$BLOCK.CHANGE$S, BACKUP$PARM$BLOCK.CHANGE$I = 0;
   PTR1 = DEBLANK(PTR1);
   whilee true;
      if CHAR1 = 'W' thenn
         if BACKUP$PARM$BLOCK.W$ATTR <> 0 thenn
            call ERROR(.('ERROR -- W ATTRIBUTE ALREADY SPECIFIED',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '1' thenn
            BACKUP$PARM$BLOCK.W$ATTR = true;
         elseif CHAR1 = '0' thenn
            BACKUP$PARM$BLOCK.W$ATTR = 80H;
         elseif CHAR1 = '?' or CHAR1 = '*' thenn
            BACKUP$PARM$BLOCK.W$ATTR = 0;
         elsee
            call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '=' thenn  /* attribute reset */
            PTR1 = DEBLANK(PTR1 + 1);
            if CHAR1 = '1' thenn
               BACKUP$PARM$BLOCK.CHANGE$W = true;
            elseif CHAR1 = '0' thenn
               BACKUP$PARM$BLOCK.CHANGE$W = 80H;
            elsee
               BACKUP$PARM$BLOCK.CHANGE$W = 0;
               call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
            endif;
            PTR1 = DEBLANK(PTR1 + 1);
         elsee
            BACKUP$PARM$BLOCK.CHANGE$W = 0;
         endif;
      elseif CHAR1 = 'S' thenn
         if BACKUP$PARM$BLOCK.S$ATTR <> 0 thenn
            call ERROR(.('ERROR -- S ATTRIBUTE ALREADY SPECIFIED',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '1' thenn
            BACKUP$PARM$BLOCK.S$ATTR = true;
         elseif CHAR1 = '0' thenn
            BACKUP$PARM$BLOCK.S$ATTR = 80H;
         elseif CHAR1 = '?' or CHAR1 =  '*' thenn
            BACKUP$PARM$BLOCK.S$ATTR = 0;
         elsee
            call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '=' thenn  /* attribute reset */
            PTR1 = DEBLANK(PTR1 + 1);
            if CHAR1 = '1' thenn
               BACKUP$PARM$BLOCK.CHANGE$S = true;
            elseif CHAR1 = '0' thenn
               BACKUP$PARM$BLOCK.CHANGE$S = 80H;
            elsee
               BACKUP$PARM$BLOCK.CHANGE$S = 0;
               call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
            endif;
            PTR1 = DEBLANK(PTR1 + 1);
         elsee
            BACKUP$PARM$BLOCK.CHANGE$S = 0;
         endif;
      elseif CHAR1 = 'I' thenn
         if BACKUP$PARM$BLOCK.I$ATTR <> 0 thenn
            call ERROR(.('ERROR -- I ATTRIBUTE ALREADY SPECIFIED',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '1' thenn
            BACKUP$PARM$BLOCK.I$ATTR = true;
         elseif CHAR1 = '0' thenn
            BACKUP$PARM$BLOCK.I$ATTR = 80H;
         elseif CHAR1 = '?' or CHAR1 = '*' thenn
            BACKUP$PARM$BLOCK.I$ATTR = 0;
         elsee
            call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
         endif;
         PTR1 = DEBLANK(PTR1 + 1);
         if CHAR1 = '=' thenn  /* attribute reset */
            PTR1 = DEBLANK(PTR1 + 1);
            if CHAR1 = '1' thenn
               BACKUP$PARM$BLOCK.CHANGE$I = true;
            elseif CHAR1 = '0' thenn
               BACKUP$PARM$BLOCK.CHANGE$I = 80H;
            elsee
               BACKUP$PARM$BLOCK.CHANGE$I = 0;
               call ERROR(.('ERROR -- INVALID ATTRIBUTE VALUE',0), PTR1);
            endif;
            PTR1 = DEBLANK(PTR1 + 1);
         elsee
            BACKUP$PARM$BLOCK.CHANGE$I = 0;
         endif;
      elsee
         return PTR1;
      endif;
   endwhile;
endproc COLLECT$ATTRIBUTES;

COLLECT$OUTPUT$LIST: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;
   dcl OUTPUT$LIST$INDEX byte;

   if CHAR1 = 'T' thenn
      PTR1 = PTR1 + 1;
      if CHAR1 = 'O' thenn
         PTR1 = DEBLANK(PTR1 + 1);
         if not(CHAR1 >= '0' and CHAR1 <= '9') thenn
             call ERROR(.('DEVICE DIGIT EXPECTED',0), PTR1);
         endif;
         OUTPUT$LIST$INDEX = 0;
         whilee CHAR1 >= '0' and CHAR1 <= '9';
            if SELECTED$DEVICE(CHAR1 - '0') thenn
               call ERROR(.('DEVICE ALREADY SELECTED',0), PTR1);
            elsee
               SELECTED$DEVICE(CHAR1 - '0') = true;
               if OUTPUT$LIST$INDEX > last(BACKUP$PARM$BLOCK.OUTPUT$LIST) thenn
                  call ERROR(.('MAXIMUM OF 4 OUTPUT DEVICES EXCEEDED',0), PTR1);
               elsee
                  BACKUP$PARM$BLOCK.OUTPUT$LIST(OUTPUT$LIST$INDEX) = CHAR1;
                  BACKUP$PARM$BLOCK.OUTPUT$LIST$ELEMENTS = OUTPUT$LIST$INDEX;
                  OUTPUT$LIST$INDEX = OUTPUT$LIST$INDEX + 1;
               endif;
            endif;
            PTR1 = DEBLANK(PTR1 + 1);
            if CHAR1 = ',' thenn
               PTR1 = DEBLANK(PTR1 + 1);
            endif;
         endwhile;
      elsee
         call ERROR(.('"TO" EXPECTED',0), PTR1);
      endif;
   elsee
      BACKUP$PARM$BLOCK.OUTPUT$LIST$ELEMENTS = 0;
      BACKUP$PARM$BLOCK.OUTPUT$LIST(0) = '5';
   endif;
   return PTR1;
endproc COLLECT$OUTPUT$LIST;

collect$attrib$switch: PROCEDURE(ptr1) POINTER;
  DCL ptr1 POINTER;
  DCL char BASED ptr1 CHARACTER;

  ptr1 = deblank(ptr1);
  IF char = 'C' THEN
    DO;
      ptr1 = ptr1 + 1;
      keep$attribs = TRUE;
    END;
  RETURN ptr1;
END collect$attrib$switch;

COLLECT$DELETE$OPTION: procedure(PTR1) pointer;
   dcl PTR1 pointer;
   dcl PTR2 pointer;
   dcl CHAR based PTR2 character;
   dcl D$STRING(*) character data('DELETE');
   dcl I byte;

   DELETE$OPTION = false;
   PTR2 = DEBLANK(PTR1);
   for I = 0 to length(D$STRING)-1;
      if D$STRING(I) = CHAR thenn
         PTR2 = PTR2 + 1;
      elsee
         return PTR1;
      endif;
   endfor;
   DELETE$OPTION = true;
   return PTR2;
end COLLECT$DELETE$OPTION;

VERIFY$END$OF$LINE: procedure(PTR1);
   dcl PTR1 pointer;
   dcl CHAR1 based PTR1 character;

   PTR1 = DEBLANK(PTR1);
   if (CHAR1 <> CR) and (CHAR1 <> LF) and (CHAR1 <> ESC) thenn
      call ERROR(.('BAD SYNTAX',0), PTR1);
   endif;
endproc VERIFY$END$OF$LINE;

UPPER$CASE: procedure(PTR1);
   dcl PTR1 pointer;
   dcl CHAR based PTR1 character;

   char = char AND 7FH;
   do while not ((CHAR = CR) or (CHAR = ESC) or (CHAR = LF));
      if (CHAR >= 'a') and (CHAR <= 'z') thenn
         CHAR = CHAR - 20H;
      endif;
      PTR1 = PTR1 + 1;
      char = char AND 7FH;
   enddo;

end UPPER$CASE;

BACKUP$FILES: procedure(COMMAND$PTR) external;
   dcl COMMAND$PTR pointer;
end BACKUP$FILES;

call SIGN$ON(.VERSION);
call READ(1,.COMMAND$LINE, length(COMMAND$LINE), .COMMAND$LINE$LENGTH, .STATUS);
call UPPER$CASE(.COMMAND$LINE);
COMMAND$PTR = DEBLANK(.COMMAND$LINE);
COMMAND$PTR = GET$DEVICE(COMMAND$PTR);
COMMAND$PTR = GET$FILENAME(COMMAND$PTR);
COMMAND$PTR = DEBLANK(COMMAND$PTR);
COMMAND$PTR = COLLECT$ATTRIBUTES(COMMAND$PTR);
COMMAND$PTR = COLLECT$OUTPUT$LIST(COMMAND$PTR);
command$ptr = collect$attrib$switch(command$ptr);
COMMAND$PTR = COLLECT$DELETE$OPTION(COMMAND$PTR);
call VERIFY$END$OF$LINE(COMMAND$PTR);
call BACKUP$FILES(.BACKUP$PARM$BLOCK);
call write$co$crlf;
call EXIT;

end HARD$DISK$BACKUP;