FTN4,L C C PROGRAM: SCB C C WRITTEN BY: CARL E. DAVIDSON - 110278 C HEWLETT-PACKARD C DATA SYSTEMS DIVISION C CUPERTINO, CALIFORNIA C C MODIFIED 2-13-79, TO NOT PRINTOUT PASSWORD C C C C DESCRIPTION C ----------- C C THIS PROGRAM DUMPS THE SESSION CONTROL BLOCK (SCB) CONTENTS C FOR A SPECIFIED SESSION TO THE SESSION CONSOLE OR OTHER C DESIGNATED LIST DEVICE. C C C INSTRUCTIONS C ------------ C C SCB IS SCHEDULED AS FOLLOWS: C C RU,SCB[,LIST[,SESID]] C C WHERE: C C LIST = DESTINATION LOGICAL UNIT FOR SCB LISTING C (DEFAULT IS SESSION CONSOLE) C C SESID = SESSION IDENTIFIER FOR DESIRED SCB C (DEFAULT IS CURRENT SESSION) C C C ENVIRONMENT AND RESOURE REQUIREMENTS C ------------------------------------ C C SCB OPERATES ONLY IN THE RTE-IV SESSION MONITOR ENVIRONMENT C AND REQUIRES THE FOLLOWING EXTERNAL SUBROUTINES/FUNCTIONS: C C NAME DESCRIPTION C ---- ----------- C C IGETB BYTE GET UTILITY C MOVCA BYTE MOVE UTILITY C BLANC FILLS WORDS W BLANKS C JASC BINARY TO ASCII C GTSAD GETS SCB ADDRESS C C C PROGRAM SCB(3,75),24999-16247 REV.1938 790213 IMPLICIT INTEGER(A-Z) INTEGER BUFR(200),PARM(5),FRMT(50),DCB(144),ARECD(128) INTEGER USER(5),GROUP(5),PASS(5) LOGICAL SHALF CALL RMPAR(PARM) LIST=PARM(1) IF(LIST.EQ.0) LIST=LOGLU(DMY) LOG=LOGLU(DMY) C C IF REQUESTED SCB IS FOR OTHER THAN THE CURRENT SESSION, C GET SCB ADDRESS. C SESID=PARM(2) IF(SESID.EQ.0) GO TO 1 CALL GTSAD(SESID,ADRES) IF(ADRES.EQ.-1) WRITE(LOG,100) IF(ADRES.EQ.-1) GO TO 8000 IF(ADRES.EQ.0) WRITE(LOG,400)PARM(2) 400 FORMAT(/,X,"SYSTEM LU#",I3," NOT LOGGED ON") IF(ADRES.EQ.0) GO TO 9001 ADRES=ADRES+15 C C GET CONTENTS OF SESSION CONTROL BLOCK. C 1 CALL GTSCB(BUFR,200,LEN,ADRES) IF(LEN.EQ.-1) WRITE(LOG,100) IF(LEN.EQ.-1) GO TO 8000 100 FORMAT(/,X,"** SCB RUNS UNDER SESSION ONLY **") C C OPEN ACCOUNTS FILE. C CALL OPEN(DCB,ERROR,6H+@CCT!,1,-31178) IF(ERROR.LT.0) WRITE(LOG,500)ERROR 500 FORMAT(/,X,"FMP ERROR ",I4," IN SCB WHILE OPENING ACCOUNTS FILE") IF(ERROR.LT.0) GO TO 8000 C C COMPUTE ACCOUNT FILE RECORD NUMBER FOR RECORD CONTAINING C DIRECTORY ENTRY FOR SESSION'S ACCOUNT. C CALL READF(DCB,ERROR,ARECD,128,LTH,1) IF(ERROR.LT.0) WRITE(LOG,600)ERROR 600 FORMAT(/,X,"FMP ERROR ",I4," IN SCB WHILE READING FROM ACCOUNTS" C" FILE") IF(ERROR.LT.0) GO TO 8000 BASE=ARECD(5) ORDNL=BUFR(2)+1 REC=BASE+(ORDNL/8)-1 IF(MOD(ORDNL,8).NE.0) REC=BASE+(ORDNL/8) C C GET RECORD CONTAINING DIRECTORY ENTRY FOR SESSION'S ACCOUNT. C CALL READF(DCB,ERROR,ARECD,128,LTH,REC) IF(ERROR.LT.0) WRITE(LOG,600)ERROR IF(ERROR.LT.0) GO TO 8000 C C COMPUTE ENTRY NUMBER (1-8) IN CURRENT RECORD CONTAINING 16-WORD C DIRECTORY ENTRY FOR SESSION'S ACCOUNT. C ENTRY=MOD(ORDNL,8) IF(MOD(ORDNL,8).EQ.0) ENTRY=8 C C MOVE 16-WORD DIRECTORY ENTRY INTO FIRST 16 WORDS OF ARRAY "ARECD". C CALL MOVCA(ARECD(16*ENTRY-15),1,ARECD(1),1,32) C C GET USER AND GROUP NAMES FOR SESSION'S ACCOUNT. C NUSR=IGETB(ARECD(1),1) CALL BLANC(USER(1),5) CALL MOVCA(ARECD(2),1,USER(1),1,NUSR) NGRP=IGETB(ARECD(1),2) CALL BLANC(GROUP(1),5) CALL MOVCA(ARECD(7),1,GROUP(1),1,NGRP) C C GET PASSWORD FROM SESSION'S USER ACCOUNT ENTRY. C SHALF=.FALSE. IF(ARECD(15).LT.0) SHALF=.TRUE. IF(ARECD(15).LT.0) ARECD(15)=IAND(ARECD(15),77777B) CALL READF(DCB,ERROR,ARECD,128,LTH,ARECD(15)) IF(ERROR.LT.0) WRITE(LOG,600)ERROR IF(ERROR.LT.0) GO TO 8000 IF(SHALF) CALL MOVCA(ARECD(65),1,ARECD(1),1,128) NPAS=IGETB(ARECD(1),2) CALL BLANC(PASS(1),5) IF(NPAS.NE.0) CALL MOVCA(ARECD(2),1,PASS(1),1,NPAS) IF(NPAS.EQ.0) NPAS=2 C C DUMP USER NAME, GROUP NAME AND PASSWORD TO LIST DEVICE. C CALL EXEC(3,1100B+LIST,-1) WRITE(LIST,700)USER,GROUP,BUFR(1) 700 FORMAT(3X,"USER: ",5A2,X,"GROUP: ",5A2 C/,3X,"CURRENTLY LOGGED ONTO SYSTEM LU#",I3) C C DUMP SCB LIST HEADER TO LIST DEVICE. C WRITE(LIST,200) 200 FORMAT(/,3X,"-SCB-",11X,"-----DECIMAL------",/, C3X,"INDEX OCTAL UPPER LOWER WORD ASCII",9X, C"DESCRIPTION",/, C3X,"----- ------- ----- ----- ------ -----",2X,25("-")) C C INITIALIZE FORMAT SPECIFICATIONS ARRAY. C CALL CODE WRITE(FRMT,300) 300 FORMAT("(5X,I2,3X,@6,4X,I3,3X,I3,X,I6,4X,A2,2X,") C C DUMP SCB CONTENTS TO LIST DEVICE. C DO 150 I=1,LEN INDEX=I+2 UPPER=IGETB(BUFR(I),1) LOWER=IGETB(BUFR(I),2) ASCII=BUFR(I) C C IF UPPER OR LOWER BYTE CONTAINS NON-PRINTING ASCII CHARACTERS C REPLACE WITH A BLANK BEFORE OUTPUT. C IF((UPPER.LT.40B).OR.(UPPER.GT.176B)) C ASCII=IAND(ASCII,377B)+20000B IF((LOWER.LT.40B).OR.(LOWER.GT.176B)) C ASCII=IAND(ASCII,177400B)+40B C C MASK DESCRIPTION INFORMATION FOR CURRENT SCB ENTRY INTO C FORMAT SPECIFICATIONS ARRAY. C DO 5 J=21,50 5 FRMT(J)=2H IF(INDEX.NE.3) GO TO 15 CALL MOVCA(24H5X,"SESSION IDENTIFIER"),1,FRMT(20),2,24) GO TO 99 15 IF(INDEX.NE.4) GO TO 20 CALL MOVCA(29H3X,"ACCT. DIRECTORY ENTRY #"),1,FRMT(20),2,29) GO TO 99 20 IF(INDEX.NE.5) GO TO 25 CALL MOVCA(22H6X,"CAPABILITY LEVEL"),1,FRMT(20),2,22) GO TO 99 25 IF((INDEX.LT.6).OR.(INDEX.GT.9)) GO TO 30 CALL MOVCA(20H7X,"ERROR MNEMONIC"),1,FRMT(20),2,20) GO TO 99 30 IF((INDEX.LT.10).OR.(INDEX.GT.11)) GO TO 35 CALL MOVCA(15H9X,"CPU USAGE"),1,FRMT(20),2,15) GO TO 99 35 IF(INDEX.NE.12) GO TO 40 CALL MOVCA(14H10X,"USER ID"),1,FRMT(20),2,14) GO TO 99 40 IF(INDEX.NE.13) GO TO 45 CALL MOVCA(15H10X,"GROUP ID"),1,FRMT(20),2,15) GO TO 99 45 IF(INDEX.NE.14) GO TO 50 CALL MOVCA(16H9X,"DISC LIMIT"),1,FRMT(20),2,16) GO TO 99 50 IF(INDEX.NE.15) GO TO 55 CALL MOVCA(18H8X,"- SST LENGTH"),1,FRMT(20),2,18) GO TO 99 55 IF((INDEX.LT.16).OR.(INDEX.GT.-BUFR(13)+15)) GO TO 65 IF(BUFR(I).NE.-1) GO TO 60 CALL MOVCA(15H9X,"SST SPARE"),1,FRMT(20),2,15) GO TO 99 60 CALL MOVCA(29H2X,"SYS LU# / SES LU# "),1,FRMT(20),2,29) CALL JASC(UPPER+1,FRMT,51,3) CALL JASC(LOWER+1,FRMT,64,3) GO TO 99 65 IF(INDEX.NE.-BUFR(13)+16) GO TO 70 CALL MOVCA(21H6X,"- DISC CAPACITY"),1,FRMT(20),2,21) GO TO 99 70 IF(BUFR(I).NE.0) GO TO 75 CALL MOVCA(16H9X,"DISC SPARE"),1,FRMT(20),2,16) GO TO 99 75 CALL MOVCA(30H2X," / / LU# "),1,FRMT(20),2,30) IF(IAND(BUFR(I),40000B).NE.40000B) GO TO 80 CALL MOVCA(5HGROUP,1,FRMT(27),1,5) GO TO 85 80 CALL MOVCA(7HPRIVATE,1,FRMT(26),2,7) 85 IF(IAND(BUFR(I),100000B).NE.100000B) GO TO 90 CALL MOVCA(5HADDED,1,FRMT(22),2,5) GO TO 95 90 CALL MOVCA(5HEXIST,1,FRMT(22),2,5) 95 DLU=IAND(BUFR(I),377B) CALL JASC(DLU,FRMT,65,3) 99 WRITE(LIST,FRMT)INDEX,BUFR(I),UPPER,LOWER,BUFR(I),ASCII 150 CONTINUE GO TO 9000 8000 WRITE(LOG,800) 800 FORMAT(/,X,"SCB ABORTED") GO TO 9001 9000 CALL EXEC(3,1100B+LIST,-1) CALL EXEC(3,1100B+LIST,-1) 9001 WRITE(LOG,900) 900 FORMAT(X,"$END SCB") END END$ ASMB HED ** S/P IGETB (21MX ONLY) F. GAULLIER 07/SEP/77 NAM IGETB,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18020 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT IGETB * * THIS PROGRAM GETS A BYTE IN A STRING, RIGHT JUSTIFIED * THE RETURNED WORD : - RIGHT : THIS BYTE * - LEFT : ALL ZERO * DM1 DEC -1 * .BUFF NOP BUFFER ADDRESS .N NOP REL. ADDR. OF BYTE * IGETB NOP JSB .ENTR DEF .BUFF LDB .BUFF CLE,ELB ADB DM1 ADB .N,I LBT JMP IGETB,I * END ASMB HED ** S/P MOVCA (21MX ONLY) F. GAULLIER 07/SEP/77 NAM MOVCA,7 . 92903-16001 REV.1805 760907 * * SOURCE 92903-18040 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT MOVCA SUP * * THIS PROGRAM MOVES A STRING * 21MX INSTRUCTIONS ARE USED * DM1 DEC -1 * .BUF1 NOP .N1 NOP .BUF2 NOP .N2 NOP .NC NOP * MOVCA NOP JSB .ENTR DEF .BUF1 * LDA .BUF1 CLE,ELA ADA DM1 ADA .N1,I LDB .BUF2 CLE,ELB ADB DM1 ADB .N2,I MBT .NC,I JMP MOVCA,I END ASMB HED S/P BLANC (21MX ONLY) PS 24/08/77 NAM BLANC,7 . 92903-16001 REV.1805 770824 * * SOURCE 92903-18006 * SPC 2 ************************************************************** * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * ************************************************************** SPC 2 EXT .ENTR ENT BLANC * * THIS ROUTINE BLANKS A BUFFER * BUF NOP NMOT NOP * BLANC NOP JSB .ENTR DEF BUF CCA ADA NMOT,I SSA JMP BLANC,I STA NMOT LDB BL STB BUF,I INIT. FIRST WORD SZA,RSS JMP BLANC,I LDA BUF STA 1 INB MVW NMOT JMP BLANC,I * BL OCT 20040 END FTN4 SUBROUTINE JASC(IVAL,IBUF,JBYT .,NBYTE),. 92903-16001 REV.1805 770721 C C SOURCE 92903-18031 C C C C ************************************************************** C * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1978. ALL RIGHTS * C * RESERVED. NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED, RE- * C * PRODUCED, OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITH- * C * OUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY. * C ************************************************************** C C C********************************************************************* C* * C* THIS SUBROUTINE IS USED TO CONVERT ANY INTEGER * C* NUMBER (POSITIVE OR NEGATIVE) IN AN ASCII STRING . * C* * C* PARAMETERS : * C* * C* IVAL : INTEGER VALUE * C* IBUF : BUFFER TO STORE ASCII STRING * C* IBYT : FIRST BYTE # TO STORE STRING * C* IF IBYT IS NEGATIVE LEADING BLANKS IN * C* STRING ARE CHANGED TO ZEROS * C* NBYTE : # OF BYTES OF THE STRING * C* * C********************************************************************* C C DIMENSION IBUF(1),ITEMP(3) C IBYT=JBYT IF(JBYT.LT.0) IBYT=-JBYT IF((IBYT.LT.1).OR.(NBYTE.LT.1)) RETURN CALL BLAN(IBUF,IBYT,NBYTE) JVAL=IVAL IF(IVAL.LT.0) JVAL=-IVAL CALL CNUMD(JVAL,ITEMP) DO 100 I=1,6 IF(IGET1(ITEMP,I).NE.1H ) GO TO 200 100 CONTINUE 200 IF(IVAL.GE.0) GO TO 300 I=I-1 CALL PUTCA(ITEMP,1H-,I) 300 IF(7-I.GT.NBYTE) RETURN CALL MOVCA(ITEMP,I,IBUF,IBYT+NBYTE-7+I,7-I) IF(JBYT.GT.0) RETURN DO 350 K=IBYT,IBYT+NBYTE-1 IF(IGET1(IBUF,K).EQ.1H ) CALL PUTCA(IBUF,1H0,K) 350 CONTINUE RETURN END END$ ASMB,L * * UTILITY SUBROUTINE: GTSAD * * WRITTEN BY: CARL E. DAVIDSON - 112978 * * * DESCRIPTION * ----------- * * GTSAD IS A FORTRAN CALLABLE SUBROUTINE WHICH RETURNS THE SCB * STARTING ADDRESS ASSOCIATED WITH THE SESSION IDENTIFIER PASSED * BY THE CALLER. * * * CALLING SEQUENCE * ---------------- * * CALL GTSAD(SESID,ADDR) * * WHERE: * * SESID = SESSION IDENTIFIER * * ADDR = SCB ADDRESS RETURNED HERE * (SET TO: 0 IF SESID NOT LOGGED ON, * -1 IF NOT IN SESSION) * * NAM GTSAD,7 GET SCB ADDRESS UTILITY - 112978 ENT GTSAD EXT $SHED,.ENTR,$SMVE PARAM BSS 2 GTSAD NOP JSB .ENTR GET CALLER'S PARAMETER ADDRESSES DEF PARAM LDA PARAM,I GET SESSION IDENTIFIER STA SESID LDA PARAM+1 GET CALLER'S ADDRESS ADDRESS STA SCBAD CLA CLEAR CALLER'S ADDRESS PARAMETER STA SCBAD,I LDA $SHED GET SCB LIST HEAD ADDRESS STA NXADR SZA ARE WE IN SESSION? JMP NXSCB YES, ALL'S WELL CCA NO, SET CALLER'S ADDRESS PARAMETER STA SCBAD,I TO -1 JMP GTSAD,I AND EXIT. NXSCB JSB $SMVE GET FIRST FOUR WORDS DEF RETRN OF NEXT SCB. DEF READ (READ) DEF NXADR (NEXT SCB ADDRESS) DEF OFFST (BEGINNING WITH FIRST WORD) DEF SCB (INTO BUFFER "SCB") DEF NWRDS (4 WORDS) RETRN LDA SCB+3 GET SESSION ID FOR THIS SCB CPA SESID IS THIS THE ONE WE'RE LOOKING FOR? JMP GTCHA YES LDA SCB NO, GET NEXT SCB'S ADDRESS STA NXADR SZA IS THIS THE END OF THE LIST? JMP NXSCB NO, GET NEXT SCB JMP GTSAD,I YES, THAT'S ALL FOLKS! GTCHA LDA NXADR RETURN SCB ADDRESS TO CALLER STA SCBAD,I AND JMP GTSAD,I EXIT. * * PROGRAM CONSTANTS * SESID BSS 1 CALLER'S SESSION IDENTIFIER SCBAD BSS 1 CALLER'S ADDRESS PARM. ADDRESS NXADR BSS 1 ADDRESS OF NEXT SCB IN LIST READ DEC 1 $SMBE OP CODE (1=READ, 2=WRITE) OFFST DEC 0 $SMVE BUFFER OFFSET SCB BSS 4 $SMVE BUFFER NWRDS DEC 4 $SMVE NUMBER OF WORDS TO MOVE END GTSAD