PROGRAM MODHED
C
C
LOGICAL*1 VOLNAM(12),PASSW(6),P(6),YN,IBYTE(512),IOS(4)
LOGICAL*1 NUMRB(2),FNAME(18),FNAM(18)
LOGICAL CHANGE
INTEGER*4 NBL,ITOT,NBLIND
EQUIVALENCE (NBL,IPARAM(5)),(IOS(1),IOSB(1)),(ITO(1),ITOT)
EQUIVALENCE (VOLNAM(1),IBUF(8)),(IBUF(1),IBYTE(1))
EQUIVALENCE (NUMR,NUMRB(1))
DIMENSION IBUF(256),IPARAM(6),IOSB(2),ITO(2),IPARM(6)
DATA P/'J','O','I','S','T','R'/
C
WRITE(5,1)
1 FORMAT(/' *** WARNING *** THE PURPOSE OF THIS PROGRAM IS TO
$ MODIFY FILE HEADERS.'/17X,'THIS IS A VERY DANGEROUS OPERATION AND
$ THEREFORE...'/17X,'IF YOUR SYSTEM MANAGER THINKS YOU ARE CLEVER
$ ENOUGH TO'/17X,'DO THIS, HE''LL GIVE YOU THE PASSWORD TO
$ PROCEED.'/)
C
C
C THE PROGRAM ASKS FOR A PASSWORD AND PERFORMS A QIO WITH
C NO ECHO. TO LET THE CODING PROCEED AFTER THIS QIO, THE TASK
C MUST BE NON-CHECKPOINTABLE AND FOR SOME REASON THE TASK
C SHOULD DISABLE AST RECOGNITION. NOW WE CAN TEST FOR TIME-OUT.
C
C
WRITE(5,2)
2 FORMAT(' *** PASSWORD?')
CALL GETADR(IPARM(1),PASSW(1))
IPARM(2)=6
CALL DSASTR
CALL DISCKP
CALL MARK(2,10,2)
CALL QIO("1020,5,1,,IOSB,IPARM)
CALL WFLOR(1,2)
CALL READEF(2,IDS)
IF(IDS.EQ.2) GO TO 500
C
C
C IF WRONG PASSWORD, STOP
C
C
DO 3 I=1,6
3 IF(PASSW(I).NE.P(I)-I) STOP 'WRONG PASSWORD'
C
C
C ASK TO CONTINUE OR NOT
C
C
WRITE(5,4)
4 FORMAT(/' *** LOGICAL UNIT NUMBER #1 IS USED FOR LOGICAL READ
$/WRITE ON DM1:'/' *** IF YOU WANT TO CHANGE THIS, YOU HAVE TO
$ INSTALL "MODHED" FIRST'/' *** AND THEN PERFORM A REASSIGNMENT.
$ [E.G. REA MODHED 1 DM0:]'//'$*** CONTINUE? [Y/N]: ')
READ(5,44) YN
44 FORMAT(A1)
IF(YN.NE.'Y') GO TO 100
C
C
C TRY TO ATTACH DEVICE ON LUN #1
C IF IT FAILS... STOP
C
C
CALL WTQIO("1400,1,1,,IOSB)
IF(IOS(1).EQ.1) GO TO 10
WRITE(5,5) IOS
5 FORMAT(/' *** FATAL *** FAILED TO ATTACH DEVICE -- STATUS: ',4O5/)
GO TO 100
C
C
C START PROCEDURE TO READ THE HOME BLOCK.
C THE HOME BLOCK IS POSITIONED ON LOGICAL BLOCK #1 OR ON
C LOGICAL BLOCK #MULTIPLE OF 256.
C THE PROGRAM CHECKS THE VALIDITY OF THE HOME BLOCK ON ITS
C TWO CHECKSUMS ON LOCATION 30 AND 256, AND ON ITS HAVING SET
C AT LEAST 1 BIT. AFTER 200 TRIES (LOG.BL. #52100) THE PROGRAM
C STOPS WITH ERROR.
C
C
10 CALL GETADR(IPARAM(1),IBUF(1))
IPARAM(2)=512
NBL=1
NHOM=0
11 CALL WTQIO("1000,1,1,,IOSB,IPARAM)
IF(IOSB(1).EQ.1) GO TO 12
13 WRITE(5,15) IOS
15 FORMAT(/' *** FATAL *** READ ERROR -- STATUS: ',4O5/)
GO TO 100
12 ITOT=0
DO 16 I=1,29
16 ITOT=ITOT+IBUF(I)
IF(ITO(1).EQ.IBUF(30).AND.ITOT.NE.0) GO TO 17
NHOM=NHOM+1
IF(NHOM.GE.200) STOP 'HOME BLOCK READ ERROR'
NBL=NHOM*256
GO TO 11
17 ITOT=0
DO 18 I=1,255
18 ITOT=ITOT+IBUF(I)
IF(ITO(1).EQ.IBUF(256).AND.ITOT.NE.0) GO TO 19
NHOM=NHOM+1
IF(NHOM.GE.200) STOP 'HOME BLOCK READ ERROR'
NBL=NHOM*256
GO TO 11
C
C
C START TRYING TO READ THE INDEX FILE HEADER.
C ITS POSITION IS FOUND BY ADDING ITEMS 1 AND 3 OF THE HOME BLOCK.
C IF THE FILE ID OF THE INDEX FILE HEADER .NE. 1,1.... STOP
C
C
19 NOFF=2+IBUF(1)
MAXFIL=IBUF(4)
WRITE(5,21) VOLNAM
21 FORMAT(/' ***** VOLUME LABEL: ',12A1,' *****'/)
NBL=IBUF(1)+IBUF(3)
NBLIND=NBL
23 NBL=NBLIND
CALL WTQIO("1000,1,1,,IOSB,IPARAM)
IF(IOSB(1).NE.1) GO TO 13
IF(IBUF(2).NE.1.OR.IBUF(3).NE.1) STOP 'INDEXFILE FILE-ID NOT 1,1'
C
C
C ASK FOR THE FILE'S FILE ID.
C IF THE NUMBER OF RETRIEVAL POINTERS IN THE INDEXFILE .GT. 102...
C ... STOP. (NO MULTI HEADER FOR THE INDEXFILE SUPPORTED).
C
C
WRITE(5,25)
25 FORMAT('$ENTER FILE ID [2O8,^Z =READY]: ')
READ(5,30,END=100,ERR=23) IBL1,IBL2
30 FORMAT(2O8)
IF(IBL1.LE.0.OR.IBL1.GT.MAXFIL) STOP 'FILE ID OUT OF RANGE'
NRTRP=IBYTE(101)
IF(NRTRP.GT.102) STOP 'TOO MANY RETRIEVAL POINTERS'
IVBLN=2
IRTRP=6
IOF=112
C
C
C FIND THE CLUSTER IN WHICH THE FILE WANTED IS POSITIONED.
C
C
31 NUMRB(1)=IBYTE(IOF)
IF(IBL1+3.LE.IVBLN+NUMR+1) GO TO 32
IF(IRTRP.GE.NRTRP.OR.IRTRP.GT.204) STOP 'EXCEEDED MAX NUMBER
$ OF RETRIEVAL POINTERS'
IRTRP=IRTRP+2
IVBLN=IVBLN+NUMR+1
IOF=IOF+4
GO TO 31
C
C
C NOW CALCULATE THE LOGICAL BLOCK NUMBER OF THE FILE HEADER WANTED
C AND READ THIS BLOCK.
C IF FILE ID .EQ. FILE ID IN THIS BLOCK (LOCATION 2,3)... THIS IS
C THE FILE HEADER WANTED!!!!!!
C
C
32 IOF1=IOF/2+1
NBL=IBUF(IOF1)+NOFF+IBL1-IVBLN-1
CALL WTQIO("1000,1,1,,IOSB,IPARAM)
IF(IOS(1).NE.1) GO TO 13
IF(IBL1.EQ.IBUF(2).AND.IBL2.EQ.IBUF(3)) GO TO 35
WRITE(5,33) IBUF(2),IBUF(3),IPARAM(5)
33 FORMAT(/' *** FATAL *** FILE ID MISMATCH [',O6,',',O6,']',
$/15X,'LOGICAL BLOCK NUMBER [OCTAL]:',O7//)
GO TO 23
C
C
C WRITE ON TERMINAL THE FILENAME AND THE CONTENTS OF THE HEADER.
C
C
35 FNAME(10)='.'
FNAME(14)=';'
CALL R50ASC(9,IBUF(24),FNAME(1))
CALL R50ASC(3,IBUF(27),FNAME(11))
ENCODE(3,37,FNAME(15)) IBUF(28)
37 FORMAT(I3)
NF=0
DO 38 I=1,18
IF(FNAME(I).EQ.32) GO TO 38
NF=NF+1
FNAM(NF)=FNAME(I)
38 CONTINUE
WRITE(5,36) (FNAM(I),I=1,NF)
36 FORMAT(/' ***** FILE HEADER OF FILE ',<NF>A1,' *****'//)
WRITE(5,40) IBUF
40 FORMAT(32(1X,8O8/))
C
C
C ASK FOR ITEM TO CHANGE, PRINT THE CONTENTS AND ASK FOR NEW ONE.
C THE CONTENTS WILL NOT CHANGE IF JUST A <CR> WAS ENTERED.
C KEEP LOOPING UNTIL ALL CHANGES ARE MADE.
C
C
CHANGE=.FALSE.
45 WRITE(5,50)
50 FORMAT('$ENTER ITEM TO CHANGE [DECIMAL,<CR>=READY]: ')
READ(5,55) IT
55 FORMAT(I5)
IF(IT.LE.0) GO TO 70
IF(IT.GT.256) GO TO 45
57 CALL CLOSE(5)
CALL ASSIGN(5,'TI:')
WRITE(5,60) IBUF(IT)
60 FORMAT('$CONTENTS OLD: ',O8,' NEW [OCTAL, <CR>=DON''T]: ')
READ(5,65,END=57,ERR=57) NC,NEWIT
65 FORMAT(Q,O8)
IF(NC.LE.0) GO TO 45
IBUF(IT)=NEWIT
CHANGE=.TRUE.
GO TO 45
C
C
C CALCULATE NEW CHECKSUM AND WRITE NEW FILE HEADER TO DISK.
C IF NO CHANGES WERE MADE, DON'T WRITE.
C IF ANY WRITE ERROR, SAY SO AND EXIT.
C
C
70 IF(.NOT.CHANGE) GO TO 23
ITOT=0
DO 80 I=1,255
80 ITOT=ITOT+IBUF(I)
IBUF(256)=ITO(1)
WRITE(5,85) IBUF(256)
85 FORMAT(/' ***** NEW CHECKSUM WILL BE: ',O6' *****'/)
CALL WTQIO("400,1,1,,IOSB,IPARAM)
IF(IOS(1).EQ.1) GO TO 23
WRITE(5,90) IOS
90 FORMAT(/' *** FATAL *** WRITE ERROR -- STATUS: ',4O5/)
100 STOP
C
C
C HERE, IF NO PASSWORD WAS ENTERED WITHIN 10 SECONDS.
C BECAUSE A READ FROM TERMINAL IS OUTSTANDING, A WRITE
C HAS TO WAIT BEFORE ITS COMPLETION. THEREFORE, A QIO WITH
C A FUNCTION CODE IO.KIL HAS TO BE SENT TO CLEAR THE TERMINAL
C I/O QUEUE. AFTER THAT SOMETHING CAN BE WRITTEN TO THE TERMINAL
C AGAIN.
C
C
500 CALL QIO("12,5)
STOP 'TIME-OUT COUNT EXCEEDED'
END