MLSEXEC 
          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 
