! A DELETE command for EMAS
! Gordon Hughes, September 1982
! The file fitting code from J. Wexler

%const %integer SSPDFILETYPE = 6
%record %format ARF (%string (31) NAME, %integer TYPE %or %string (11) SNAME, %integer SP12, KBYTES,
    %byte %integer ARCH, CODES, CCT, OWNP, EEP, USE, CODES2, SSBYTE, FLAGS, SP29, SP30, SP31)
%record %format PDHF (%integer DATAEND, DATASTART, SIZE, FILETYPE, SUM, DATETIME, ADIR, COUNT)
%record %format RF (%integer CONAD, FILETYPE, DATASTART, DATAEND)
%record %format AFRECF (%string (11) NAME, %integer KBYTES, %string (8) DATE, %string (6) TAPE, %INTEGER CHAPTER, FLAGS)
%system %routine %spec PRINTMESS (%integer M)
%system %integer %fn %spec STOREMATCH (%integer L, A1, A2)
%system %routine %spec MOVE (%integer LENGTH, FROM, TO)
%external %integer %fn %spec DFILENAMES (%string (6) USER,
   %record (AFRECF) %array %name INF, %integer %name FILENUM, MAXREC, NFILES, %integer FSYS, TYPE)
%external %integer %fn %spec DDESTROY (%string (6) USER, %string (11) FILE,
   %string (8) DATE, %integer FSYS, TYPE)
%system %routine %spec SETWORK (%integer %name AD, FLAG)
%system %integer %map %spec COMREG (%integer I)
%system %routine %spec CONNECT (%string (31) FILE, %integer MODE, HOLE, PROT, %record (RF) %name R, %INTEGER %NAME FLAG)
%external %integer %fn %spec UINFI (%integer I)
%external %string (255) %fn %spec UINFS (%integer I)
%external %routine %spec VIEW (%string (255) STR)
%external %routine %spec SSFOFF
%external %routine %spec SSFON
%external %routine %spec PROMPT (%string (63) FILE)
%external %routine %spec DISCONNECT (%string (255) FILE)
%external %routine %spec DESTROY (%string (255) FILE)

%external %routine DELETE (%string (255) A)
   %const %integer TRUE=0, FALSE=-1
   %integer I,PDFILE,FLAG,MARKS,OTHER USER,OFFLINE,DONEDEL, MAX FILE
   %record(arf)%name P
   %record(afrecf)%name PAN
   %string (255) B,C,PDN,USER,TEMP
   %byte %integer %array MARK (1:2)
   %const %integer MAXPF = 128
   %record (arf) %array PF(0 : MAXPF-1)
   %const %integer MAXPA = 1001
   %record(afrecf)%array PA(0 : MAXPA-1)
   %record %format CLEANF (%string (3) EXTRA, %string (11) date, %string (31) file, %integer NUM, %half LEN, KB)
   %half %integer %array CL (0:MAXPA-1)
   %record (cleanf) %array CLA (0:MAXPA-1)
   %record (RF) RR
   %string (255) PATTERN
   %string (15) PATS, PATT, PATU, PATV
   %integer PATTYPE, CLP
   %string (255) PASS2

   %routine FAIL (%string (255) MESSAGE)
      Print string ("DELETE fails - ")
      Print string (MESSAGE)
      NEWLINE
      %stop
   %end

   %routine SORTNAMES(%integer M, N)
      %integer I, MAX, NN
      %if M=0=N %or B="D" %start; ! Only 1 thing, or Date order, so don't swap
          CL (I) = I %for I = M, 1, N
          %return
      %finish
      NN = N
      %cycle
          MAX = 1
          %for I = M, 1, N %cycle
               MAX = I %if CLA(I)_FILE>=CLA(MAX)_FILE
          %repeat
          CL(NN) = MAX
          LENGTH(CLA(MAX)_FILE) = 0
          NN = NN - 1
      %repeat %until NN<0
      LENGTH(CLA(I)_FILE) = CLA(I)_LEN %for I = M, 1, N
   %end

   %integerfn MATCH(%string (15) NAME)
                                        ! RETURNS A BOOLEAN RESULT ON
                                        ! MATCHING A NAME WITH A PATTERN
                                        ! WHICH CONTAINS "*" SYMBOLS
                                        ! TO REPRESENT AN ARBITRARY 
                                        ! NO OF CHARACTERS
   %constinteger TRUE = 1, FALSE = 0
   %integer L
   %switch TYP(1 : 5)
      %if PATTYPE=0 %start;           !FIRST TIME - ANALYSE PATTERN
         %if PATTERN -> PATS.("*").PATT %then %start
            %if       PATS#""            %then PATTYPE = 3 %c
            %else %if PATT=""            %then PATTYPE = 5 %c
            %else %if PATT -> PATS.("*") %then PATTYPE = 1 %c
            %else                              PATTYPE = 2
         %finish %else PATTYPE = 4
      %finish;                          ! FINISHED ANALYSING
      !
      ! 1: *PATS*
      ! 2: *PATT
      ! 3: PATS*PATT
      ! 4: NAME
      ! 5: *
      !
      -> TYP(PATTYPE);                  ! BRANCH ON TYPE
TYP(5):
      PATV = NAME
      %result = TRUE
TYP(4):
      PATV = ""
      %if PATTERN = NAME %then %result = TRUE %else %result = FALSE
TYP(1):
TYP(3):
      %unless NAME->PATU.(PATS).PATV %then %result = FALSE
      %if PATTYPE=1 %then %result = TRUE
      %if PATU#"" %then %result = FALSE
      %if PATT="" %then %result = TRUE
      NAME = PATV
TYP(2):
      L = LENGTH (NAME) - LENGTH (PATT)
      %if   L>=0                                                   %c
      %and  STOREMATCH(LENGTH(PATT),ADDR(PATT)+1,ADDR(NAME)+L+1)#0 %c
      %then %start
         LENGTH (PATV) = L
         MOVE (L,ADDR(NAME)+1,ADDR(PATV)+1)
         %result = TRUE
      %finish %else %result = FALSE
   %end;                                ! OF MATCH

   %integerfn DIRTOSS(%integer FLAG)
      ! Result is subsystem fault number equivalent to the given director
      ! error number.  Comments below assume FLAG is never <0.
      %constinteger MAXDSS = 83
      ! DSS is a translation table of director error numbers to subsystem error
      ! numbers.  To fit the values into single bytes, they are reduced by a constant
      ! value - entries <100 in this table are actually 500 too small, and entries
      ! between 100 and 255 are 100 too small.  The necessary corrections have to
      ! be performed after the table look-up.
      %constbyteintegerarray DSS(1 : MAXDSS) =
          1, 2, 3, 4, 5, 173, 7, 8, 174, 175,
          101, 12, 13, 14, 176, 119, 176, 120, 19, 173,
          21, 22, 23, 24, 178, 26, 27, 162, 162, 30,
          31, 118, 179, 34, 209, 176, 101, 38, 156, 178,
          180, 178, 176, 44, 45, 46, 47, 48, 181, 182,
          183, 52,53,54,55,56,57,58,59,60,
          61,62,63,64,65,66,67,68,69,70,
          71,72,73,74,75,76,77,78,79,80,
          81,82,208
      %if FLAG = 0 %then %result = 0;      !MOST LIKELY RESULT
      %if 1 <= FLAG <= MAXDSS %then %start
         FLAG = DSS(FLAG)
         ! This gives some number in the range 1 to 255 (since 0 never
         ! occurs as an entry in DSS).
         %if FLAG < 100 %then FLAG = FLAG+500 %else FLAG = FLAG+100
         ! This can produce numbers in the ranges 200-355 and 501-599.
      %finish %else FLAG = FLAG+500; ! This can give 501+MAXDSS and upwards.
      %result = FLAG
   %end;                                   !OF DIRTOSS


   %routine PBITS (%string (3) E, %string (11) D, %string (31) S, %integer N, KB)
      S = USER.".".S %and N=N+7 %if OTHER USER#0
!      CLEAN (S."_".PASS2) %and %return %if PASS2#""
      CLA(CLP)_FILE = S
      CLA(CLP)_DATE = D
      CLA(CLP)_EXTRA = E
      CLA(CLP)_NUM = N
      CLA(CLP)_LEN = LENGTH(S)
      CLA(CLP)_KB  = KB
      CLP = CLP + 1
   %end

   %routine PRINTLIST (%record (ARF) %array %name R, %integer FINISH, %routine V (%string (255) Q))
      !PRINTS THE NAMES IN RECORDARRAY R FROM 0 TO FINISH  if they match
      !LENGTH OF EACH NAME ASSUMED <=11 BUT IF GREATER THEN MORE THAN ONE COLUMN
      !ALLOWED FOR PRINTING
      %integer I
      %string (*) %name NAME
      %for I=0,1,FINISH %cycle
         PAN == R(I)
         P == R(I)
         NAME == P_NAME
         %if MATCH(NAME)#0 %then V (NAME)
      %repeat
   %end;                                !OF PRINTLIST

   %routine MF(%string (255) OPTIONS)
      %integer COUNT, MODE
      %integer FILENUM, NFILES
      %routine TPBF (%string (255) NAME)
         %string (3) EXTRA
         %return %if length(name)>=2 %and substring(name,1,2)="T#" %and OPTIONS#"E"
         %if CHARNO(NAME,1)#'#' %and ((OPTIONS#"H" %and P_CODES&16_10#0) %or (OPTIONS#"C" %and P_CODES&16_10=0)) %start
             EXTRA = "   "
             EXTRA = " * " %if P_CODES&16_10#0
             EXTRA = "** " %if P_ARCH&16_80#0
             PBITS (EXTRA, "", NAME, 11, 0)
         %finish
      %end
      %routine TPBA (%string (255) NAME)
         %return %if length(name)>=2 %and substring(name,1,2)="T#" %and OPTIONS#"E"
         %if CHARNO(NAME,1)#'#' %and ((OPTIONS#"H" %and P_CODES&16_10#0) %or (OPTIONS#"C" %and P_CODES&16_10=0)) %start
             PBITS ("   ", PAN_DATE, NAME, 11, PAN_KBYTES)
         %finish
      %end
      FLAG = 0
      FILENUM = 0
      %if OFFLINE # TRUE %start
          MODE = 0
          NFILES = MAX PF
          FLAG = DIRTOSS (DFILENAMES (USER, PF, FILENUM, NFILES, COUNT, -1, MODE))
          %if FLAG=0 %then PRINTLIST (PF,NFILES-1,TPBF)
      %finish %else %start
          MODE = 1
          NFILES = MAX PA
          FLAG = DIRTOSS (DFILENAMES (USER, PA, FILENUM, NFILES, COUNT, -1, MODE))
          %if FLAG=0 %then PRINTLIST (PA,NFILES-1,TPBA)
      %finish
   %end

   %routine MA(%string (255) FILE)
      %integer I, FILETYPE, POINT
      %integer CONAD
      %constinteger MAXR = 6553;              !MAXIMUM VALUE OF R
      %record(arf)%arrayformat RAF(0:MAXR-1)
      %record(arf)%arrayname R
      %record(pdhf)%name H
      %constinteger MAXTYPENAME = 6
      %routine PBN (%string (255) K)
         PBITS ("   ", "",  FILE."_".K, 12+length(FILE), 0)
      %end
      CONNECT(USER.".".FILE,0,0,0,RR,FLAG);         !CONNECT IN READ MODE
      %if FLAG # 0 %then -> ERR
      CONAD = RR_CONAD
      H == RECORD(CONAD)
      FILETYPE = RR_FILETYPE
      %unless 0<=H_FILETYPE<=MAXTYPENAME %then FILETYPE = 0
                                           !OLD OBJECT FILE
      %if FILETYPE=SSPDFILETYPE %and H_COUNT>0 %then %start
                                           !PD FILE
         %if       H_COUNT<=MAXPA %then R==ARRAY(ADDR(PA(0)),RAF) %c
         %else %if H_COUNT<=MAXR %then %start
            I=16_40000
            SETWORK(I,FLAG)
            %if FLAG#0 %then ->ERR
            R==ARRAY(I,RAF)
         %finish %else %start
            FLAG = 300
            -> ERR
         %finish
         POINT = CONAD+H_ADIR+4
         %for I=0,1,H_COUNT-1 %cycle
            R(I)_NAME = STRING(POINT+I*32)
            R(I)_TYPE = 19;                !MEMBER OF A PDFILE
         %repeat
         %if H_COUNT>0 %then PRINTLIST(R,H_COUNT-1,PBN);  !MUST BE SOME MEMBERS
      %finish
ERR:
   %end

   %routine do clean
      %string (63) LINE
      %integer I, DIR, COM, SYM
      %record (CLEANF) %name CP
      %switch SW(0:95)

      %routine read line
         %integer sym
         line = ""
         read symbol (sym) %until sym>' '
         %cycle
            line = line.tostring(sym)
            read symbol (sym)
         %repeat %until sym=nl
      %end

      %routine convert (%string (*) %name s)
         %integer i
         %for I = 1, 1, length(s) %cycle
              charno(s,i) = charno(s,i)+'A'-'a' %if 'a'<=charno(s,i)<='z'
         %repeat
      %end

      %string (63) %fn MAKE PROMPT (%integer CLP)
          %string (31) file
          %integer I
          CP == CLA(CL(CLP))
          FILE = CP_FILE
          %for I = 1, 1, LENGTH(FILE) %cycle
               CHARNO(FILE,I)=CHARNO(FILE,I)-'A'+'a' %IF 'A'<=CHARNO(FILE,I)<='Z'
          %repeat
          FILE = " ".FILE %while LENGTH(FILE)<=CP_NUM
          %result = cp_extra.cp_date.file." "
      %end

      %routine SAY (%string (127) MESS)
         PRINT STRING (MESS)
         NEWLINE
      %end

      %routine FAIL (%string (255) MESS)
        %const %string (15) %array COMS ('A':'Z') =
            "ARCHIVE", "BACKUP", "COPY", "DELETE", "EXIT", "", "", "HELP",
            "INFO", "", "", "LIST", "MEMBERS", "NEWNAME", "ONLINE", "PERMIT",
            "QUIT", "RENAME", "SAVE", "TOP", "", "VOLATILE", "" (*)
         %if 'A'<=COM<='Z' %start
             PRINT STRING (COMS(COM))
             PRINT STRING (" fails - ")
         %finish %else PRINT STRING ("Failure - ")
         SAY (MESS)
      %end

      %on 9 %start
          %return
      %finish

      DIR = 1
      CLP = 0
         prompt (make prompt(clp))
         read symbol (com) %until COM#' '
         %if com#nl %start
             SKIP SYMBOL %while NEXT SYMBOL>' '
             line = ""
             %cycle
                READ SYMBOL (SYM) %until SYM#' '
                %exit %if SYM=NL
                LINE = LINE.TO STRING(SYM)
             %repeat
         %finish
         COM = COM&95 %if 'a'<=COM<='z'
         -> SW (COM)

   SW('D'): ! Delete
            %if CHARNO(CP_EXTRA,1)='o' %then FAIL ("file is being restored") %else %start
                %if CHARNO(CP_EXTRA,1)='*' %then FAIL ("file is marked for archive") %else %start
                    CHARNO(CP_EXTRA,1) = 'd'
                    SAY (CP_FILE." marked for deletion")
                    DONE DEL = TRUE
                %finish
            %finish
            -> SW(NL)
   %end

   CLP = 0
   PAT TYPE = 0
   FLAG = 0
   FAIL ("Batch mode use not allowed") %if UINFI(2)=2
   PASS2 = ""
   B = ""
   C=A %and B = "F" %unless A -> C.(",").B %and B#""
   B = TO STRING (CHARNO(B,1))
   FAIL ("Unknown options parameter """.B."""") %unless "A"<=B<="H" %and B#"B"
   OFFLINE = FALSE
   OFFLINE = TRUE %if B="A" %or B="D"
   %if C -> USER.(".").C %start
       OTHER USER = 1
       FAIL ("Invalid username """.USER."""") %if LENGTH(USER)#6
   %finish %else %start
       USER = UINFS(1)
       OTHER USER = 0
   %finish
   %if C->PDN.("_").PATTERN %then %start
       FAIL ("Options don't apply to PD file members") %if B#"F"
       PDN = "*" %if PDN=""
       PATTERN = "*" %if PATTERN = ""
       %if PDN -> ("*") %start
           PASS2 = PATTERN
           PATTERN = PDN
           PDFILE = FALSE
       %finish %else PDFILE = TRUE
   %finish %else %start
      PATTERN = C
      PDFILE = FALSE
   %finish
   %if PATTERN="" %start
      PATTERN = "*"
      MARK (1) = 0
      MARKS = 1
   %finish %else %start
      MARKS = 0
      I = LENGTH (PATTERN)
      %while I>=1 %and MARKS<2 %cycle
         %if CHARNO (PATTERN,I) = '*' %start
            MARKS = MARKS + 1
            MARK (MARKS) = '*'
         %finish
         I = I - 1
      %repeat
      FAIL ("Too many wildcards given") %if MARKS=2 %and (I>=1 %or CHARNO(PATTERN,LENGTH(PATTERN))#'*')
   %finish
   PATTYPE = 0;                         !INITIALISE
   %if MARKS=0 %and OFFLINE#TRUE %and USER#UINFS(1) %start
       ! Try to connect the one file specified
       CONNECT(A,0,0,0,RR,FLAG);         !CONNECT IN READ MODE
       %if FLAG=0 %start
           PBITS ("   ", "", C, 11, 0)
       %finish
   %finish %else %start
       %if PDFILE#TRUE %then MF (B) %else MA (PDN)
   %finish
END:
   COMREG (24) = FLAG
   %if FLAG#0 %then PRINT STRING ("CLEAN fails -") %and PRINTMESS(FLAG) %else %start
!       FAIL ("no files match the spec") %if CLP=0
       %if CLP>0 %start
           MAX FILE = CLP - 1
           SORT NAMES (0, MAX FILE)
           SSFOFF
           DONE DEL = FALSE
           DO CLEAN
           ! Now delete any files marked for deletion.
           %if DONEDEL=TRUE %start
               %for I = 0, 1, MAX FILE %cycle
                    %if CHARNO(CLA(I)_EXTRA,1)='d' %start
                        %if OFFLINE#TRUE %start   { DESTROY disconnects etc.
                            LENGTH(CLA(I)_FILE) = LENGTH(CLA(I)_FILE) - 1 %if CLA(I)_FILE -> TEMP.("T#") %and TEMP=""
                            DISCONNECT (CLA(I)_FILE)
                            DESTROY (CLA(I)_FILE)
                            FLAG = COMREG(24)
                        %finish %else %start
                            FLAG = DDESTROY (USER, CLA(I)_FILE, CLA(I)_DATE, -1, 1)
                        %finish
                        FLAG = DIRTOSS(FLAG) %and -> END %if FLAG#0
                        CLA(I)_DATE = " ".CLA(I)_DATE %if CLA(I)_DATE#""
                        print string (CLA(I)_FILE.CLA(I)_DATE." deleted")
                        newline
                    %finish
               %repeat
           %finish
           SSFON
       %finish
   %finish
%end

%end %of %file