C C ********************* C * [311,77]EMPLY.FTN * C ********************* C C------- "EMP" COMMAND C C------- THE FOLLOWING SWITCHES ARE ALLOWED: C C /ADD[/PRIV] employee number "employee name" C ADDS AN EMPLOYEE (/PRIV SETS EMPLOYEE TO PRIVILAGED C I.E. HE CAN USE UIC .LT. 100) C C /DEL employee number C DELETE AN EMPLOYEE C C /LIST[:filespec][/PRIV] [employee number] C LIST VALID EMPLOYEES (/PRIV LIST PRIVILAGED ONLY) C C /COMP C COMPRESS THE NAME FILE C DIMENSION IDATA(16) C BYTE LINE(80) C C------- CHECK IF PRIVILAGED CALL GETTSK(IDATA) IF (IDATA(16) .EQ. "401) GO TO 30 TYPE 10 10 FORMAT(' You do not have the privilage to use this command') CALL EXIT C C------- SET TO TERMINAL INPUT 30 IN = 5 C C------- OPEN THE NAME FILES CALL NOPEN C C------- GET COMMAND LINE CALL MCRGET (LINE,NNC) NC = NNC C C------- GO PARSE COMMAND IF (NNC .GT. 0) GO TO 200 C C------- PROMPT FOR A COMMAND 100 IF (IN .EQ. 5) TYPE 110 110 FORMAT('$EMP> ') READ (IN,120,END=7000) NC,LINE 120 FORMAT(Q,80A1) C C------- PARSE COMMAND 200 CONTINUE IF (LINE(1) .EQ. '/') GO TO 300 C C------- CHECK FOR INDIRECT COMMAND FILE IF (LINE(1) .NE. '@') GO TO 205 C C------- PROCESS INDIRECT COMMAND FILE CALL IND (LINE,NC,IN) GO TO 230 C C------- ERROR NO COMMAND 205 IF (IN .NE. 5) TYPE 210,(LINE(I),I=1,NC) 210 FORMAT(1X,80A1) TYPE 220 220 FORMAT(' ABOVE COMMAND HAS NO SWITCHES -- IGNORED') C C------- IF NO SWITCHES ENTERED OR INDIRECT GO DO MORE 230 IF (NNC .EQ. 0 .OR. IN .NE. 5) GO TO 100 CALL EXIT C C------- CHECK FOR ADD 300 IF (LINE(2) .NE. 'A') GO TO 400 C C------- ADD C C------- OPEN THE PASSWORD BIT MAPS CALL POPEN CALL ADD (LINE,NC) C C------- CLOSE THE BIT MAPS CALL PCLOS GO TO 230 C C------- CHECK FOR DELETE 400 IF (LINE(2) .NE. 'D') GO TO 500 C C------- OPEN THE PASSWORD BIT MAPS CALL POPEN CALL DEL (LINE,NC) C C------- CLOSE THE BIT MAPS CALL PCLOS GO TO 230 C C------- CHECK FOR LIST 500 IF (LINE(2) .NE. 'L') GO TO 600 C C------- OPEN THE PASSWORD BIT MAPS CALL POPEN CALL LIST (LINE,NC) C C------- CLOSE THE BIT MAPS CALL PCLOS GO TO 230 C C------- CHECK FOR COMPRESS 600 IF (LINE(2) .NE. 'C') GO TO 205 CALL COMP GO TO 230 C C------- END OF FILE 7000 CLOSE (UNIT=IN) IF (IN .EQ. 5) CALL EXIT IN = 5 GO TO 230 C END SUBROUTINE NOPEN C C------- OPEN THE EMPLOYEE NAME FILES: C C LB0:[70,24]EMPLPTR.DAT - EMPLOYEE NUMBER NAME POINTERS (3) C C LB0:[70,24]EMPLNAM.DAT - EMPLOYEE NAMES (4) C C C-------- POINTER FILE SUPPORT SAME NUMBER OF EMPLOYEES AS BIT MAPS DEFINE FILE 3 (12289,1,U,I) C C-------- NAME FILE SUPPORTS 32 CHARACTER NAMES OPEN (UNIT=4,NAME='LB0:[70,24]EMPLNAM.DAT',TYPE='OLD', 1 ACCESS='DIRECT',RECORDSIZE=8,SHARED) C CALL ASSIGN (3,'LB0:[70,24]EMPLPTR.DAT') C CALL FDBSET (3,'OLD','SHARED') C RETURN C END SUBROUTINE POPEN C C------- OPEN THE PASSWORD FILES C C LB0:[1,100]PDSPAS.PAS - EMPLOYEE NUMBER BIT MAP (1) C C LB0:[1,100]PDSPRIV.PAS - PRIVILAGED BIT MAP (2) C C-------- BIT MAPS EACH 3 BLOCK LONG DEFINE FILE 1 (768,1,U,I) DEFINE FILE 2 (768,1,U,I) C CALL ASSIGN (1,'LB0:[1,100]PDSPAS.PAS') CALL ASSIGN (2,'LB0:[1,100]PDSPRIV.PAS') C CALL FDBSET (1,'OLD') CALL FDBSET (2,'OLD') C RETURN C C END SUBROUTINE PCLOS C C------- CLOSE THE PASSWORD FILES C CLOSE (UNIT=1) CLOSE(UNIT=2) C RETURN C END SUBROUTINE COMP C C------- COMPRESS THE EMPLOYEE NAME FILE C BYTE NAME(30) C C------- CLOSE THE BIT MAP FILE CLOSE (UNIT=1) C C------- GET THE LAST RECORD READ (3'12289) NEXT NREC = NEXT - 1 NEXT = NREC C C------- LOOP THRU FILE BACKWARDS DO 1000 I=NREC,1,-1 C READ (4'I) INUM,NAME C C------- IF NON ZERO THE USED IF (INUM .GT. 0) GO TO 1000 C C------- THIS RECORD IS FREE MOVE THE LAST UP C C------- NO MOVE IF THIS IS LAST RECORD IF (I .EQ. NEXT) GO TO 600 C DO 500 J=I+1,NEXT READ (4'J) INUM,NAME WRITE(3'INUM) J-1 WRITE(4'J-1) INUM,NAME 500 CONTINUE C C------- UPDATE NEXT AVAILABLE 600 WRITE(3'12289) NEXT NEXT = NEXT - 1 C 1000 CONTINUE C CALL EXIT C END SUBROUTINE IND (LINE,NC,IN) C C------- OPEN AN INDIRECT COMMAND FILE C BYTE LINE (NC),FNAME(34) C C------- MOVE FILE NAME OVER DO 10 I=2,NC FNAME(I-1) = LINE(I) 10 CONTINUE C C------- CHECK FOR FILE TYPE NF = NC - 1 DO 20 I=1,NF IF (FNAME(I) .EQ. '.') GO TO 50 20 CONTINUE C C------- ADD FILE TYPE FNAME(NF+1) = '.' FNAME(NF+2) = 'C' FNAME(NF+3) = 'M' FNAME(NF+4) = 'D' NF = NF + 4 C 50 FNAME(NF+1) = 0 C C------- OPEN THE FILE IN = 6 OPEN (UNIT=IN,NAME=FNAME,TYPE='OLD') C RETURN C END SUBROUTINE ADD (LINE,NC) C C------- ADD AN EMPLOYEE C BYTE LINE(NC),NAME(30) C LOGICAL*1 ERROR C C------- PARSE THE COMMAND STRING CALL PARSE (LINE,NC,NUME,NAME,ERROR) IF (ERROR) RETURN C C------- UPDATE THE BIT MAP IREC = NUME / 16 + 1 READ (1'IREC) IPASS IS = NUME .AND. "17 IBIT = 1 IBIT = ISHFT (IBIT,IS) C C------- CHECK IF ALREADY EXISTS ITEST = IPASS .AND. IBIT IF (ITEST .EQ. 0) GO TO 5 C C------- ERROR EMPLOYEE ALREADY EXITS READ (3'NUME) IREC READ (4'IREC) INUM,NAME TYPE 3,(LINE(II),II=1,NC),INUM,NAME 3 FORMAT(1X,A1,/,' Employee already exists:',I6,1X,30A1) RETURN C 5 IPASS = IPASS .OR. IBIT WRITE(1'IREC) IPASS C C------- CHECK IF PRIVILAGED DO 10 I=1,NC IF (LINE(I) .NE. '/') GO TO 10 IF (LINE(I+1) .NE. 'P') GO TO 10 IF (LINE(I+2) .NE. 'R') GO TO 10 C C------- ADD TO PRIVILAGED LIST READ (2'IREC) IPASS IPASS = IPASS .OR. IBIT WRITE(2'IREC) IPASS GO TO 100 C 10 CONTINUE C C------- GET NEXT AVAILABLE RECORD 100 READ (3'12289) NEXT C C------- WRITE THE NAME WRITE(4'NEXT) NUME,NAME WRITE(3'NUME) NEXT C C------- UPDATE NEXT AVAILABLE RECORD NEXT = NEXT + 1 WRITE(3'12289) NEXT C TYPE 200,NUME,NAME 200 FORMAT(' Employee added:',I6,1X,30A1) C RETURN C END SUBROUTINE PARSE (LINE,NC,NUME,NAME,ERROR) C C------- PARSE THE COMMAND TO GET EMPLOYEE NUMBER AND NAME C BYTE LINE(NC),NAME(30) C LOGICAL*1 ERROR C ERROR = .TRUE. C C------- FIND FIRST BLANK DO 100 I=1,NC IF (LINE(I) .NE. ' ') GO TO 100 C C------- FIND NEXT NON BLANK DO 50 J=I,NC IF (LINE(J) .EQ. ' ') GO TO 50 C C------- J IS BEGINNING OF NUMBER FIND NEXT BLANK DO 30 K=J,NC IF (LINE(K) .NE. ' ') GO TO 30 C C------- DECODE THE EMPLOYEE NUMBER DECODE (K-J,10,LINE(J),ERR=9000) NUME 10 FORMAT(I10) IF (NUME .GT. 0 .AND. NUME .LT. 12288) GO TO 200 TYPE 20,NUME 20 FORMAT(' ILLEGAL EMPLOYEE NUMBER:',I8) RETURN 30 CONTINUE C C------- END OF LINE IS DELIMITER DECODE (NC+1-J,10,LINE(J),ERR=9000) NUME GO TO 200 C C------- MISSING EMPLOYEE NUMBER 40 TYPE 45,(LINE(II),II=1,NC) 45 FORMAT(1X,80A1) TYPE 47 47 FORMAT(' MISSING EMPLOYEE NUMBER') RETURN C 50 CONTINUE GO TO 40 C 100 CONTINUE GO TO 40 C C------- FIND EMPLOYEE NAME C C------- FIND NEXT '"' 200 DO 500 I=1,NC IF (LINE(I) .NE. '"') GO TO 500 C C------- BLANK OUT NAME DO 250 J=1,30 NAME(J) = ' ' 250 CONTINUE C C------- STORE NAME K = I + 1 DO 300 L=1,30 IF (LINE(K) .EQ. '"') GO TO 1000 NAME(L) = LINE(K) K = K + 1 300 CONTINUE GO TO 700 C 500 CONTINUE c C------- MISSING " TYPE 45,(LINE(II),II=1,NC) TYPE 510 510 FORMAT(' MISSING " NAME ASSUMED BLANK') C 700 CONTINUE C 1000 ERROR = .FALSE. C 9000 RETURN C END SUBROUTINE DEL (LINE,NC) C C------- DELETE AN EMPLOYEE C BYTE LINE(NC),NAME(32) C LOGICAL*1 ERROR C C------- GET THE EMPLOYEE NUMBER CALL PARSE (LINE,NC,NUME,NAME,ERROR) IF (ERROR) RETURN C C------- UPDATE THE BIT MAPS IREC = NUME / 16 + 1 READ (1'IREC) IPASS IS = NUME .AND. "17 IBIT = 1 IBIT = ISHFT (IBIT,IS) C C------- CHECK THAT EMPLOYEE EXISTS ITEST = IPASS .AND. IBIT IF (ITEST .NE. 0) GO TO 100 C C------- CAN'T DELETE SOMEONE WHO DOEN'T EXIST TYPE 10,(LINE(II),II=1,NC) 10 FORMAT(1X,A1,/,' No such employee') RETURN C 100 IBIT = .NOT. IBIT IPASS = IPASS .AND. IBIT WRITE (1'IREC) IPASS READ (2'IREC) IPASS IPASS = IPASS .AND. IBIT WRITE(2'IREC) IPASS C C------- BLANK OUT NAME READ (3'NUME) IREC C C------- CHECK FOR ZERO IREC IF (IREC .LE. 0) GO TO 1000 READ (4'IREC) NAME TYPE 200,NUME,(NAME(I),I=3,32) 200 FORMAT(' Employee deleted:',I6,1X,30A1) DO 300 I=1,32 NAME(I) = 0 300 CONTINUE C WRITE(4'IREC) NAME IREC = 0 WRITE(3'NUME) IREC C RETURN C 1000 TYPE 1100 1100 FORMAT(' ZERO POINTER') TYPE 200,NUME RETURN C END SUBROUTINE LIST (LINE,NC) C C------- LIST VALID EMPLOYEES C LOGICAL*1 PRIV C BYTE NAME(30),LINE(NC),FNAME(34) C C------- CHECK FOR /PR PRIV = .FALSE. DO 20 I=1,NC IF (LINE(I) .NE. '/') GO TO 20 IF (LINE(I+1) .NE. 'P') GO TO 20 IF (LINE(I+2) .NE. 'R') GO TO 20 PRIV = .TRUE. GO TO 25 20 CONTINUE C C------- CHECK FOR FILE SPEC 25 DO 30 I=1,NC IF (LINE(I) .NE. ':') GO TO 30 C C------- FILE SPEC FOUND K = 0 DO 27 J=I+1,NC IF (LINE(J) .EQ. '/') GO TO 50 K = K + 1 FNAME(K) = LINE(J) 27 CONTINUE GO TO 50 30 CONTINUE IP = 5 GO TO 60 C C------- OPEN FILE 50 IP = 7 C C------- CHECK FOR FILE TYPE DO 55 I=1,K IF (FNAME(I) .EQ. '.') GO TO 58 55 CONTINUE C FNAME(K+1) = '.' FNAME(K+2) = 'L' FNAME(K+3) = 'S' FNAME(K+4) = 'T' K = K + 4 58 FNAME(K+1) = 0 OPEN(UNIT=IP,NAME=FNAME,TYPE='NEW') C C------- CHECK FOR EMPLOYEE NUMBER SPECIIFED 60 DO 100 I=1,NC IF(LINE(I) .EQ. ' ') GO TO 200 100 CONTINUE C C------- NO BALNK FOUND -- ASSUME NO EMPLOYEE NUMBER GO TO 700 C C------- FIND NUMBER 200 DO 300 J=I,NC IF (LINE(J) .NE. ' ') GO TO 400 300 CONTINUE C C------- NO NUMBER FOUND GO TO 700 C C------- EXTRACT THE NUMBER 400 DECODE (NC-J+1,500,LINE(J),ERR=700) IEMP 500 FORMAT(I10) READ(3'IEMP) IREC IF (IREC .EQ. 0) GO TO 600 READ(4'IREC) MM,NAME WRITE(IP,1000) IEMP,NAME RETURN 600 TYPE 610,IEMP 610 FORMAT(' NO SUCH EMPLOYEE',I6) RETURN 700 DO 2000 I=1,768 C C------- READ BIT MAPS READ (1'I) IPASS READ (2'I) IPASSP IF (IPASS .EQ. 0) GO TO 2000 C C------- COMPUTE BASE OF EMPLOYEE NUMBER IB = (I - 1) * 16 - 1 C C------- LOOP THRU BITS DO 1500 J=1,16 C C------- COMPUTE EMPLOYEE NUMBER IB = IB + 1 C C------- MASK OFF HIGH ORDER BITS ITEST = IPASS .AND. "1 IPRIV = IPASSP .AND. "1 C C------- IF /PRIV SWITCH AND NOT PRIV SKIP IF (PRIV .AND. IPRIV .EQ. 0) GO TO 1450 IF (ITEST .EQ. 0) GO TO 1450 READ(3'IB) IREC D WRITE(IP,900) IB,IREC D900 FORMAT(' IB,IREC',2I10) IF(IREC .GT. 0) GO TO 990 C C------- ERROR IN BIT MAPS READ(1'I) IREG READ(2'I) IPRI WRITE(IP,950) IB,IREG,IPRI 950 FORMAT(' ERROR IN BIT MAPS EMPL NO',I6, 1 ' REG MAP',O8,' PRIV MAP',O8) TYPE 950,IB,IREG,IPRI GO TO 1450 990 CONTINUE READ(4'IREC) MM,NAME IF (IPRIV .EQ. 0) WRITE(IP,1000) IB,NAME 1000 FORMAT(I8,1X,30A1) IF (IPRIV .EQ. 1) WRITE(IP,1100) IB,NAME 1100 FORMAT(I8,1X,30A1,'/PRIVILEGED') C C------- SHIFT TO NEXT BIT 1450 IPASS = ISHFT(IPASS,-1) IPASSP = ISHFT(IPASSP,-1) C 1500 CONTINUE C 2000 CONTINUE C RETURN C END SUBROUTINE MCRGET(STRING,NCHR) C C----- SUBROUTINE TO GET THE PORTION OF THE C MCR COMMAND LINE WHICH FOLLOWS C THE FIRST STRING OF BLANKS C C STRING = 80-BYTE ARRAY INTO WHICH THE LINE IS PLACED C C NCHR = NUMBER OF SIGNIFICANT CHARACTERS IN STRING C C C NOTE: THE TRAILING END OF STRING WILL BE FILLED WITH C BLANKS ("040) C BYTE STRING(80) C C----- GET THE MCR LINE CALL GETMCR(STRING,MCHR) C C----- LOOK FOR THE FIRST BLANK NCHR = 0 DO 100 I = 1, MCHR IMIN = I IF(STRING(I) .EQ. ' ')GO TO 110 100 CONTINUE C C----- NO BLANK FOUND GO TO 150 C C----- FIRST BLANK FOUND LOOK FOR FIRST NON BLANK 110 IMIN = IMIN + 1 IF(IMIN .GT. MCHR) GO TO 150 DO 120 I = IMIN, MCHR IIMIN = I IF(STRING(I) .NE. ' ')GO TO 130 120 CONTINUE C C----- NO STRING FOUND GO TO 150 C C----- A SIGNIFICANT STRING WAS FOUND - SHIFT IT LEFT 130 DO 140 I = IIMIN, MCHR NCHR = NCHR + 1 140 STRING(NCHR) = STRING(I) C C----- BLANK FILL THE TRAILING END 150 IF(NCHR .GE. 80) RETURN DO 160 I = NCHR + 1, 80 160 STRING(I) = ' ' C RETURN C END