Retro1.org codex

          IDENT  MLSEXEC,MLSEXEC 
          ABS
          SST
          SYSCOM B1
          ENTRY  SETFAL
          ENTRY  SETJAL
          ENTRY  SETPFAC
          ENTRY  SETPFAL
          ENTRY  RFL=
          ENTRY  SDM=
          ENTRY  SSJ=
          TITLE  MLSEXEC - SECURITY COMMAND PROCESSOR.
*COMMENT  MLSEXEC - SECURITY COMMAND PROCESSOR.
          COMMENT  COPYRIGHT CONTROL DATA SYSTEMS INC.  1992.
          SPACE  4,10
***       MLSEXEC - SECURITY COMMAND PROCESSOR.
*         M. S. PESCHMAN.    82/08/20.
*         P. J. ENGLE.       82/10/01.
          SPACE  4,10
***       MLSEXEC PROCESSES MULTI-LEVEL SECURITY COMMANDS FOR ALTERING
*         A JOB OR FILE ACCESS LEVELS AND CATEGORIES.
*
*         COMMAND            DESCRIPTION
*
*         SETFAL             SET FILE ACCESS LEVEL.
*         SETJAL             SET JOB ACCESS LEVEL.
*         SETPFAC            SET PERMANENT FILE ACCESS CATEGORIES.
*         SETPFAL            SET PERMANENT FILE ACCESS LEVEL.
 SETFAL   SPACE  4,10
***       SETFAL COMMAND CALL.
*
*         SETFAL,LFN,AL=LEVEL.
*
*         LFN = LOCAL FILE NAME.
*
*         LEVEL = ACCESS LEVEL.  VALID ACCESS LEVEL NAMES
*              ARE DEFINED IN *COMSMLS*.
 SETJAL   SPACE  4,10
***       SETJAL COMMAND CALL.
*
*         SETJAL,AL=LEVEL.
*
*         LEVEL = ACCESS LEVEL.  VALID ACCESS LEVEL NAMES
*              ARE DEFINED IN *COMSMLS*.
 SETPFAC  SPACE  4,30
***       SETPFAC COMMAND CALL.
*
*         SETPFAC,PFN,AC=CAT1,CAT2,...,CATN/PN=PACKNAM,R=DEVICE,NA,WB.
*
*         PFN = PERMANENT FILE NAME.
*
*         CATX = ACCESS CATEGORIES.  VALID ACCESS CATEGORIES NAMES
*              ARE DEFINED IN *COMSMLS*.  WHEN THE CATEGORY NAME
*              IS PREFACED BY A MINUS (-) THE CATEGORY IS DELETED
*              FROM THE FILE.  IF THE CATEGORY NAME IS PREFACED
*              BY A PLUS (+) THE CATEGORY IS ADDED TO THE FILE.
*              IF THE FIRST CATEGORY SPECIFIED IS *0* ALL CATEGORIES
*              WILL INITIALLY BE CLEARED.
*
*         PACKNAM = OPTIONAL AUXILIARY PACK NAME.
*
*         DEVICE = DEVICE TYPE OF AUXILIARY PACK.
*
*         NA = NO ABORT OPTION.  IF SET PROGRAM WILL NOT
*              ABORT.  IF THE FILE IS BUSY THE JOB
*              WILL BE SUSPENDED UNTIL THE FILE IS
*              AVAILABLE.  FOR ALL OTHER CONDITIONS,
*              THE ERROR MESSAGE WILL BE ISSUED AND
*              THE PROGRAM WILL CONTINUE.  *NA* CANNOT BE
*              SPECIFIED TOGETHER WITH *WB*.
*
*         WB = WAIT BUSY OPTION.  IF SET, PROGRAM WILL
*              WAIT FOR BUSY FILES AND PACK MOUNTS, BUT
*              ALL OTHER ERRORS WILL CAUSE ABORTS.  *WB*
*              CANNOT BE SPECIFIED TOGETHER WITH *NA*.
 SETPFAL  SPACE  4,40
***       SETPFAL COMMAND CALL.
*
*         SETPFAL,PFN,AL=LEVEL/PN=PACKNAM,R=DEVICE,NA,WB.
*
*         PFN = PERMANENT FILE NAME.
*
*         LEVEL = ACCESS LEVEL.  VALID ACCESS LEVEL NAMES ARE
*              DEFINED IN *COMSMLS*.
*
*         PACKNAM = OPTIONAL AUXILARY PACK NAME.
*
*         DEVICE = DEVICE TYPE OF AUXILIARY PACK.
*
*         NA = NO ABORT OPTION.  IF SET PROGRAM WILL NOT
*              ABORT.  IF THE FILE IS BUSY THE JOB
*              WILL BE SUSPENDED UNTIL THE FILE IS
*              AVAILABLE.  FOR ALL OTHER CONDITIONS,
*              THE ERROR MESSAGE WILL BE ISSUED AND
*              THE PROGRAM WILL CONTINUE.  *NA* CANNOT BE
*              SPECIFIED TOGETHER WITH *WB*.
*
*         WB = WAIT BUSY OPTION.  IF SET, PROGRAM WILL
*              WAIT FOR BUSY FILES AND PACK MOUNTS, BUT
*              ALL OTHER ERRORS WILL CAUSE ABORTS.  *WB*
*              CANNOT BE SPECIFIED TOGETHER WITH *NA*.
          SPACE  4,15
***       DAYFILE MESSAGES.
*
*         * UNKNOWN ACCESS CATEGORY NAME.* = THE COMMAND
*                CONTAINS AN UNKNOWN ACCESS CATEGORY NAME.
*
*         * UNKNOWN ACCESS LEVEL NAME.* = THE COMMAND
*                CONTAINS AN UNKNOWN ACCESS LEVEL NAME.
*
*         * INCORRECT ARGUMENT.* = THE COMMAND CONTAINS
*                AN INCORRECT ARGUMENT.
          SPACE  4,10
*         COMMON DECKS.
 
*CALL     COMCMAC
*CALL     COMSMLS
*CALL     COMSPFM
*CALL     COMSSSJ
          SPACE  4,10
****      ASSEMBLY CONSTANTS.
 
 
 FBUFL    EQU    201B        FILE BUFFER LENGTH
****
          SPACE  4,10
 SDM=     EQU    0           SUPPRESS DAYFILE MESSAGE
 SSJ=     EQU    0           SPECIAL SYSTEM JOB (*SETPFAC* ONLY)
          TITLE  FETS AND RESERVED LOCATIONS.
          ORG    120B
 MLSEXEC  BSS    0
          SPACE  4,10
*         FETS.
 
 
 F        FILEB  FBUF,FBUFL,FET=CFLM  FET FOR *LFM* AND *PFM* REQUESTS
 .F       BSS    0
          ORG    F+1
          VFD    13/0,1/1,22/0,6/CFLM-5,18/FBUF
          ORG    .F
          SPACE  4,10
*         RESERVED LOCATIONS.
 
 
 ACAT     CON    0           ACCESS CATEGORIES
 ALVL     CON    0           ACCESS LEVEL
 FNAM     CON    0           FILE NAME
 NABT     CON    0           NO ABORT FLAG
 NONZ     CON    1           NON-ZERO WORD
 PKNM     CON    0           PACK NAME
 RESD     CON    0           RESIDENCE OF FILE
 SCFL     CON    0           SET/CLEAR FLAG
 WBSY     CON    0           WAIT WHILE BUSY FLAG
 ZERO     CON    0           ZERO WORD FOR *ARG* DEFAULT
          TITLE  SETFAL -  SET FILE ACCESS LEVEL.
**        SETFAL,LFN,AL=LEVEL.
*
*         SET THE SECURITY ACCESS LEVEL OF FILE *LFN* TO LEVEL *AL*.
 
 
 SETFAL   BSS    0           ENTRY
          SB1    1
          DISSJ              DISABLE *SSJ=*
          RJ     IDM         ISSUE DAYFILE MESSAGE
          SB2    B0+         SET FIRST PARAMETER NOT TO BE EQUIVALENCED
          SB5    TARG+5      SET ARGUMENT TABLE ADDRESS
          RJ     PRP         PROCESS PARAMETERS
          SB2    B0+
          SA1    ALVL
          RJ     VLC         VALIDATE ACCESS LEVEL
          SX5    ALER
          NG     X2,ABT      IF UNKNOWN ACCESS LEVEL NAME
          BX6    X2
          SA6    ALVL        SAVE ACCESS LEVEL
          SETFAL F,ALVL      SET FILE ACCESS LEVEL
          ENDRUN
          TITLE  SETJAL - SET JOB ACCESS LEVEL.
**        SETJAL,AL=LEVEL.
*
*         SET THE SECURITY ACCESS LEVEL OF THE JOB TO LEVEL *AL*.
 
 
 SETJAL   BSS    0           ENTRY
          SB1    1
          DISSJ              DISABLE *SSJ=*
          RJ     IDM         ISSUE DAYFILE MESSAGE
          SB2    1           SET FIRST PARAMETER TO BE EQUIVALENCED
          SB5    TARG+5      SET ARGUMENT TABLE ADDRESS
          RJ     PRP         PROCESS PARAMETERS
          SB2    B0+
          SA1    ALVL        ACCESS LEVEL TO VALIDATE
          RJ     VLC         VALIDATE ACCESS LEVEL
          SX5    ALER
          NG     X2,ABT      IF UNKNOWN ACCESS LEVEL NAME
          BX6    X2
          SA6    ALVL        SAVE ACCESS LEVEL
          SETJAL ALVL        SET JOB ACCESS LEVEL
          ENDRUN
          TITLE  SETPFAC - SET PERMANENT FILE ACCESS CATEGORY.
**        SETPFAC,PFN,AC=CAT1,CAT2,...,CATN/PN=PACKNAM,R=DEVICE,NA,WB.
*
*         CHANGE THE ACCESS CATEGORIES OF THE PERMANENT FILE *PFN*.
*
*                PFN = PERMANENT FILE NAME.
*                AC = ACCESS CATEGORIES.
*                PN = OPTIONAL AUXILIARY PACK NAME.
*                R =  DEVICE TYPE OF AUXILIARY PACK.
*                NA = THE NO ABORT OPTION.
*                WB = THE WAIT-IF-BUSY OPTION.
 
 
 SETPFAC  BSS    0           ENTRY
          SB1    1
          RJ     IDM         ISSUE DAYFILE MESSAGE
 
*         SAVE FILE NAME.
 
          SA1    ARGR        GET FIRST ARGUMENT
          SX5    IAER
          ZR     X1,ABT      IF NO ARGUMENTS
          MX0    42          SAVE FILE NAME
          BX6    X0*X1
          SA6    FNAM
          SX2    3           SET FET COMPLETE
          BX6    X2+X6
          SA6    F
          BX2    -X0*X1
          NZ     X2,ABT      IF ILLEGAL SEPARATOR
 
*         CHECK THAT *AC* PARAMETER IS SPECIFIED.
 
          SA2    SACA
          SA1    A1+B1
          BX2    X2-X1
          NZ     X2,ABT      IF INCORRECT ARGUMENT
 
*         CHECK IF ANY OPTIONAL PARAMETERS SPECIFIED.
 
 SAC1     SA1    A1+1        SEARCH FOR DELIMITER */*
          ZR     X1,SAC2     IF END OF ARGUMENTS
          SX2    X1-1R/
          NZ     X2,SAC1     IF NOT */*
          SA2    ACTR        GET ARGUMENT COUNT
          SX3    A1-ARGR+1
          IX3    X2-X3
          SB4    X3          SET ARGUMENT COUNT
          SA4    A1+1        SET FIRST ARGUMENT
          SB5    TARG        SET ARGUMENT TABLE
          RJ     ARG         PROCESS ARGUMENTS
          SX5    IAER
          NZ     X1,ABT      IF INCORRECT ARGUMENT
          SA1    A1          SIGNAL END OF CATEGORIES TO CHECK
          MX0    42
          BX6    X0*X1
          SA6    A1
          SX6    B0+
          SA6    A1+1
          RJ     PNA         PROCESS *NA* AND *WB* OPTIONS
 
*         GET CURRENT ACCESS CATEGORIES.
 
 SAC2     CATLIST  F,FNAM,,,PKNM,RESD
          DISSJ              DISABLE *SSJ=*
          SA1    F+1         GET ADDRESS OF BUFFER
          SA1    X1+FCFC     GET ACCESS CATEGORIES
          MX0    -32
          BX6    -X0*X1
          SA6    ACAT        STORE ACCESS CATEGORIES
 
*         CHECK IF CLEAR ALL CATEGORIES.
 
          SA1    ARGR+2
          SA2    =1L0
          BX6    X2-X1
          NZ     X6,SAC3     IF NOT *0*
          SA6    ACAT
          SA1    A1+1        GET FIRST CATEGORY
          ZR     X1,SAC8     IF NO CATEGORIES
 
*         CHECK SPECIFIED CATEGORIES.
 
 SAC3     MX0    42
          BX2    X0*X1
          NZ     X2,SAC6     IF CATEGORY NAME
 
*         CHECK IF CATEGORY TO BE SET OR CLEARED.
 
          BX3    -X0*X1      ISOLATE SEPARATOR
          SX4    X3-1R-
          NZ     X4,SAC4     IF NOT *-*
          SX6    -1          SIGNAL CATEGORY CLEAR
          SA6    SCFL
          EQ     SAC5        CLEAR CATEGORY
 
 SAC4     SX4    X3-1R+
          ZR     X4,SAC5     IF *+*
          SX5    IAER
          EQ     ABT         PROCESS ILLEGAL SEPARATOR
 
*         VALIDATE ACCESS CATEGORY.
 
 SAC5     SA1    A1+1        POSITION TO CATEGORY NAME
 SAC6     BX3    -X0*X1
          SB2    B1          SIGNAL VALIDATE ACCESS CATEGORY
          SX5    IAER
          NZ     X3,ABT      IF ILLEGAL SEPARATOR
          RJ     VLC         VALIDATE ACCESS CATEGORY
          SX5    ACER
          NG     X2,ABT      IF UNKNOWN ACCESS CATEGORY
          SX0    1
          SB2    X2
          LX2    X0,B2
          SA3    ACAT        GET CURRENT ACCESS CATEGORIES
          SA4    SCFL        GET SET/CLEAR FLAG
          BX6    -X2*X3      CLEAR ACCESS CATEGORY
          NG     X4,SAC7     IF CLEAR ACCESS CATEGORY
          BX6    X6+X2       SET ACCESS CATEGORY
 SAC7     SA6    ACAT
 
*         CHECK IF MORE CATEGORIES TO PROCESS
 
 
          SX6    B0+         RESET SET/CLEAR FLAG
          SA6    SCFL
          SA1    A1+1        GET NEXT CATEGORY
          NZ     X1,SAC3     IF MORE CATEGORIES
 
*         SET PERMANENT FILE ACCESS CATEGORY.
 
 SAC8     SETPFAC  F,,ACAT,PKNM,RESD  SET FILE ACCESS CATEGORIES
          RJ     CES         CHECK ERROR STATUS
          ZR     X6,SAC9     IF FILE BUSY
          ENDRUN
 
 SAC9     ROLLOUT  ZERO      ROLL OUT UNTIL FILE AVAILABLE
          EQ     SAC8        RETRY AFTER ROLLED IN
 
 
 SACA     VFD    12/2LAC,42/0,6/1L=
          TITLE  SETPFAL - SET PERMANENT FILE ACCESS LEVEL.
**        SETPFAL,PFN,AL=LEVEL/PN=PACKNAME,R=TYPE,NA,WB.
*
*         CHANGE THE ACCESS LEVEL OF THE PERMANENT FILE *PFN*.
*
*                PFN = PERMANENT FILE NAME.
*                AL = ACCESS LEVEL.
*                PN = OPTIONAL AUXILIARY PACK NAME.
*                R = DEVICE TYPE.
*                NA = THE NO ABORT OPTION.
*                WB = THE WAIT-IF-BUSY OPTION.
 
 
 SETPFAL  BSS    0           ENTRY
          SB1    1
          DISSJ              DISABLE *SSJ=*
          RJ     IDM         ISSUE DAYFILE MESSAGE
          SB2    B0+         SET FIRST PARAMETER NOT TO BE EQUIVALENCED
          SB5    TARG        SET ARGUMENT TABLE
          RJ     PRP         PROCESS PARAMETERS
          RJ     PNA         PROCESS *NA* AND *WB* OPTIONS
          SB2    B0+
          SA1    ALVL        ACCESS LEVEL TO CHECK
          RJ     VLC         VALIDATE ACCESS LEVEL
          SX5    ALER
          NG     X2,ABT      IF UNKNOWN ACCESS LEVEL NAME
          BX6    X2
          SA6    ALVL
 SAL1     SETPFAL  F,,ALVL,PKNM,RESD  SET PERMANENT FILE ACCESS LEVEL
          RJ     CES         CHECK ERROR STATUS
          ZR     X6,SAL2     IF FILE BUSY
          ENDRUN
 
 SAL2     ROLLOUT  ZERO      ROLL OUT UNTIL FILE AVAILABLE
          EQ     SAL1        RETRY AFTER ROLLED IN
          TITLE  SUBROUTINES.
 ABT      SPACE  4,10
**        ABT - ABORT JOB.
*
*         ISSUE DAYFILE MESSAGE THEN ABORT.
*
*         ENTRY  (X5) = ADDRESS OF ERROR MESSAGE.
*
*         MACROS ABORT, MESSAGE.
 
 
 ABT      BSS    0           ENTRY
          MESSAGE  X5        ISSUE DAYFILE MESSAGE
          ABORT              ABORT JOB
 
 
 ACER     DATA   C* UNKNOWN ACCESS CATEGORY NAME.*
 ALER     DATA   C* UNKNOWN ACCESS LEVEL NAME.*
 IAER     DATA   C* INCORRECT ARGUMENT.*
 CES      SPACE  4,15
**        CES - CHECK ERROR STATUS.
*
*         ABORT IF *WAIT BUSY* WAS SPECIFIED, AND AN ERROR
*         OTHER THAN *FILE BUSY* IS DETECTED.
*
*         ENTRY  (X2) = FET ADDRESS.
*
*         EXIT   (X6) = 0 IF *FILE BUSY* ERROR.
*
*         USES   X - 1, 6.
*                A - 1, 6.
*
*         MACROS ABORT.
 
 
 CES      SUBR               ENTRY/EXIT
          MX6    -8          CHECK ERROR STATUS FIELD
          SA1    X2
          AX1    10
          BX1    -X6*X1
          ZR     X1,CESX     IF NO ERROR
          SX6    X1-/ERRMSG/FBS
          ZR     X6,CESX     IF *FILE BUSY* STATUS
          SA1    WBSY
          ZR     X1,CESX     IF *NA* RATHER THAN *WB*
          ABORT              ABORT (ERROR MESSAGE ISSUED BY *PFM*)
 IDM      SPACE  4,20
**        IDM - ISSUE SECURED DAYFILE MESSAGE.
*
*         REMOVE SECURITY ACCESS LEVEL VALUE FROM THE COMMAND
*         AND ISSUE THE COMMAND TO THE JOB AND TO THE
*         SYSTEM DAYFILE.
*
*         EXIT   COMMAND ISSUED TO DAYFILE.
*
*         USES   X - 4, 5.
*                A - 4, 5.
*                B - 2, 6.
*
*         CALLS  RSP.
*
*         MACROS MESSAGE.
 
 
 IDM      SUBR               ENTRY/EXIT
 
*         FORMAT PARAMETER REGISTERS FOR *RSP*.
 
          SA4    TARG        SET ARGUMENT TABLE
          SA5    CCDR        CONTROL CARD FWA
          SB2    B0+         NO PARAMETERS TO SKIP
          SB6    IDMA        PARAMETER TO BE REMOVED
 
*         REMOVE PARAMETER AND ISSUE DAYFILE MESSAGE.
 
          RJ     RSP         REMOVE SECURITY PARAMETER
          MESSAGE  CCDR,0,R  ISSUE DAYFILE MESSAGE
          EQ     IDMX        RETURN
 
 
 IDMA     CON    0LAL        PARAMETER TO BE REMOVED BY *RSP*
          CON    0           END OF ARGUMENT TABLE
 PNA      SPACE  4,10
**        PNA - PROCESS *NO ABORT* AND *WAIT BUSY* OPTIONS.
*
*         ENTRY  (NABT) = 1 IF *NO ABORT* SPECIFIED.
*                (WBSY) = 1 IF *WAIT BUSY* REQUESTED.
*
*         EXIT   ERROR PROCESSING BIT SET IF REQUIRED.
*                TO *ABT* IF BOTH *NA* AND *WB* SPECIFIED.
*
*         USES   X - 1, 2, 5, 6.
*                A - 1, 2, 6.
 
 
 PNA      SUBR               ENTRY/EXIT
          SA1    NABT
          SA2    WBSY
          IX1    X1+X2
          ZR     X1,PNAX     IF NEITHER *NA* OR *WB* SPECIFIED
          SX1    X1-2
          SX5    IAER
          ZR     X1,ABT      IF BOTH *NA* AND *WB* SPECIFIED
          SA1    F+1         SET ERROR PROCESSING BIT
          SX6    B1
          LX6    44
          BX6    X1+X6
          SA6    A1
          EQ     PNAX        RETURN
 PRP      SPACE  4,15
**        PRP -  PROCESS CONTROL CARD PARAMETERS.
*
*         ENTRY  (B2).NE.0 IF FIRST PARAMETER TO BE EQUIVALENCED.
*                (B5) = ADDRESS OF ARGUMENT TABLE IN *ARG* FORMAT.
*
*         EXIT   CONTROL CARD PARAMETERS PROCESSED.
*                TO *ABT* IF ERROR.
*
*         USES   X - 0, 1, 2, 4, 5, 6, 7.
*                A - 1, 4, 6.
*                B - 4.
*
*         CALLS  ARG.
 
 
 PRP      SUBR               ENTRY/EXIT
          SA1    ACTR
          SB4    X1
          R=     A4,ARGR
          SX5    IAER
          ZR     B4,ABT      IF NO ARGUMENTS
          SX7    X4-1R=
          ZR     X7,PRP1     IF FIRST PARAMETER IS EQUIVALENCED
          NZ     B2,ABT      IF FIRST PARAMETER SHOULD BE EQUIVALENCED
          MX0    42
          BX6    X0*X4       SET FIRST PARAMETER AS FILE NAME
          SX2    3
          BX6    X2+X6       SET FET COMPLETE
          SA6    F
          SA4    A4+B1
          SB4    B4-B1
          ZR     X4,ABT      IF NO MORE PARAMETERS
          EQ     PRP2        PROCESS REMAINING ARGUMENTS
 
 PRP1     ZR     B2,ABT      IF FIRST PARAMETER SHOULD BE UNEQUIVALENCED
 PRP2     RJ     ARG         PROCESS EQUIVALENCED PARAMETERS
          NZ     X1,ABT      IF INCORRECT ARGUMENT
          EQ     PRPX        RETURN
 
 
 TARG     BSS    0           ARGUMENT TABLE
 PN       ARG    ZERO,PKNM
 R        ARG    ZERO,RESD
 NA       ARG    -NONZ,NABT
 WB       ARG    -NONZ,WBSY
 AC       ARG    ZERO,ACAT,400B
 AL       ARG    ZERO,ALVL,400B
          ARG                END OF TABLE
          SPACE  4,10
*         COMMON DECKS.
 
*CALL     COMCARG
*CALL     COMCCPM
*CALL     COMCLFM
*CALL     COMCPFM
*CALL     COMCRSP
*CALL     COMCSYS
*CALL     COMCVLC
          SPACE  4,10
          USE    LITERALS
 FBUF     EQU    *           FILE BUFFER
 RFL=     EQU    FBUF+FBUFL
          END