IDENTIFICATION DIVISION. PROGRAM-ID. TRANS_ID. ENVIRONMENT DIVISION. DATA DIVISION. WORKING-STORAGE SECTION. 01 RESULT PIC 9(9) COMP VALUE ZERO. 01 E-RESULT PIC 9(9) COMP VALUE ZERO. 01 ATTRIBUTES PIC 9(9) COMP VALUE ZERO. 01 CONTEXT PIC 9(9) COMP VALUE ZERO. 01 RIGHTS_ID PIC 9(9) COMP VALUE ZERO. 01 IDENTIFIER PIC 9(9) COMP VALUE ZERO. 01 USER_NAME_CODE_QUAD. 02 USER_NAME_CODE PIC 9(9) COMP VALUE ZERO. 02 FILLER PIC 9(9) COMP VALUE ZERO. 01 ID_MSG PIC X(256) VALUE SPACES. 01 ID_MSG_LEN PIC 9(9) COMP VALUE ZERO. 01 IDENT_CHECK_BIT PIC 9(9) COMP VALUE 30. 01 FOUND_BIT_POS PIC 9(9) COMP VALUE 0. 01 WS-SIZE PIC 9(4) COMP VALUE 2. 01 REDEFINES WS-SIZE. 03 SIZE_BYTE PIC X. 03 FILLER PIC X. 01 UIC_FORMAT PIC X(13) VALUE "!%U --> !-!%I". 01 WS-DISPLAY-FLAG PIC X. 88 DISPLAY_FLAG VALUE "Y". 88 NO_DISPLAY_FLAG VALUE "N". 01 SYSTEM_DEFINES. 02 SS$_NORMAL PIC 9(9) COMP VALUE EXTERNAL SS$_NORMAL. 02 SS$_NOSUCHID PIC 9(9) COMP VALUE EXTERNAL SS$_NOSUCHID. 02 LIB$_NOTFOU PIC 9(9) COMP VALUE EXTERNAL LIB$_NOTFOU. 02 KGB$M_DYNAMIC PIC 9(9) COMP VALUE EXTERNAL KGB$M_DYNAMIC. 02 KGB$M_RESOURCE PIC 9(9) COMP VALUE EXTERNAL KGB$M_RESOURCE. * * These are used by the BP___GET_INPUT routine * 01 ACTION PIC X VALUE SPACE. 01 ACTION_STRING PIC X(46) VALUE "Action [(F)ind Holders, Find (H)eld, (E)xit]: ". 01 ACTION_LEN PIC 9(9) COMP VALUE ZERO. 01 USER_NAME PIC X(15) VALUE SPACES. 01 USER_NAME_STRING PIC X(10) VALUE "Username: ". 01 USER_NAME_LEN PIC 9(9) COMP VALUE ZERO. 01 RIGHTS_NAME PIC X(32) VALUE SPACES. 01 RIGHTS_NAME_STRING PIC X(12) VALUE "Identifier: ". 01 RIGHTS_NAME_LEN PIC 9(9) COMP VALUE ZERO. PROCEDURE DIVISION. P0000_MAIN. * * Do the main loop till the user asks to get out * PERFORM UNTIL (ACTION = "E" OR "e") * * This is my version of H. Goatley's version of LIB$GET_INPUT. * Thanks Hunter! * CALL "BP___GET_INPUT" USING BY DESCRIPTOR ACTION, BY DESCRIPTOR ACTION_STRING, BY REFERENCE ACTION_LEN GIVING RESULT IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE END-IF * * decide what to do with the user's input * IF (ACTION = "H" OR "h") THEN PERFORM P1000_FIND_HELD ELSE IF (ACTION = "F" OR "f") THEN PERFORM P2000_FIND_HOLDER ELSE * * bad code, try again * IF NOT (ACTION = "E" OR "e") THEN DISPLAY "INVALID ACTION -- TRY AGAIN" BOLD END-IF END-IF END-IF DISPLAY SPACE END-PERFORM. STOP RUN. P1000_FIND_HELD. ************************************************************************ * The purpose of this paragraph is to obtain a username from the user * * and to find all the rights identifiers associated with it. * ************************************************************************ * * get the username and the length of the username * CALL "BP___GET_INPUT" USING BY DESCRIPTOR USER_NAME, BY DESCRIPTOR USER_NAME_STRING, BY REFERENCE USER_NAME_LEN GIVING RESULT. IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE END-IF. * * get the identifier value associated with the user name * CALL "SYS$ASCTOID" USING BY DESCRIPTOR USER_NAME(1:USER_NAME_LEN), BY REFERENCE USER_NAME_CODE, BY REFERENCE ATTRIBUTES GIVING RESULT. IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE ELSE * * print the UIC of the user we are locating identifiers for * MOVE USER_NAME_CODE TO IDENTIFIER PERFORM P3000_TRANSLATE_IDENTIFIER DISPLAY SPACE DISPLAY "For: ", ID_MSG(1:ID_MSG_LEN) DISPLAY SPACE * * this loop will run until we have found all the Rights Identifiers in the * rights database that are tied to the username we accepted and translated * above. * SET NO_DISPLAY_FLAG TO TRUE MOVE SS$_NORMAL TO RESULT PERFORM UNTIL (RESULT NOT = SS$_NORMAL) * * Use $FIND_HELD to locate the next rights identifier * CALL "SYS$FIND_HELD" USING BY REFERENCE USER_NAME_CODE_QUAD BY REFERENCE IDENTIFIER BY REFERENCE ATTRIBUTES BY REFERENCE CONTEXT GIVING RESULT * * if we error out, we must clean up after ourselves * IF (RESULT NOT = SS$_NORMAL) THEN IF NOT (DISPLAY_FLAG AND (RESULT = SS$_NOSUCHID)) THEN PERFORM P9999_ERROR_ROUTINE CALL "SYS$FINISH_RDB" USING BY REFERENCE CONTEXT GIVING RESULT IF (RESULT NOT = SS$_NORMAL) THEN PERFORM P9999_ERROR_ROUTINE END-IF END-IF ELSE * * translate the numeric rights id we obtained from $FIND_HELD into an * alphanumeric name. * PERFORM P3000_TRANSLATE_IDENTIFIER * * at this point we have a valid alphanumeric name for the rights identifier * we obtained above. Print out that name, and whether the identifier is * a dynamic id, or a resource id. * do a logical AND with the attributes field to see if we have a dynamic id * then print the results. * DISPLAY ID_MSG (1:ID_MSG_LEN) NO SET DISPLAY_FLAG TO TRUE CALL "MTH$JIAND" USING BY REFERENCE KGB$M_DYNAMIC BY REFERENCE ATTRIBUTES GIVING RESULT IF RESULT = 0 THEN DISPLAY " " NO ELSE DISPLAY " Dynamic " NO END-IF * * do the logical AND to see if we have a resource id, and print accordingly. * CALL "MTH$JIAND" USING BY REFERENCE KGB$M_RESOURCE BY REFERENCE ATTRIBUTES GIVING RESULT IF RESULT = 0 THEN DISPLAY " " NO ELSE DISPLAY " Resource " NO END-IF DISPLAY SPACE MOVE SS$_NORMAL TO RESULT END-IF END-PERFORM END-IF. P2000_FIND_HOLDER. ***************************************************************************** * This paragraph will accept as input a rights identifier in alphanumeric * * format. It will then run that identifier thru the rights database to find* * all the users which hold that identifier. * ***************************************************************************** * * get the alphanumeric rights identifier, clean it up, and translate it to * its numeric value. * CALL "BP___GET_INPUT" USING BY DESCRIPTOR RIGHTS_NAME, BY DESCRIPTOR RIGHTS_NAME_STRING, BY REFERENCE RIGHTS_NAME_LEN GIVING RESULT. IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE END-IF. CALL "SYS$ASCTOID" USING BY DESCRIPTOR RIGHTS_NAME(1:RIGHTS_NAME_LEN), BY REFERENCE RIGHTS_ID, BY REFERENCE ATTRIBUTES GIVING RESULT. IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE ELSE * * loop until we have found all the holders of the translated rights id. * SET NO_DISPLAY_FLAG TO TRUE MOVE SS$_NORMAL TO RESULT PERFORM UNTIL (RESULT NOT = SS$_NORMAL) CALL "SYS$FIND_HOLDER" USING BY VALUE RIGHTS_ID BY REFERENCE USER_NAME_CODE_QUAD BY REFERENCE ATTRIBUTES BY REFERENCE CONTEXT GIVING RESULT * * we must clean up after ourselves if we error out * IF (RESULT NOT = SS$_NORMAL) THEN IF NOT (DISPLAY_FLAG AND (RESULT = SS$_NOSUCHID)) THEN PERFORM P9999_ERROR_ROUTINE CALL "SYS$FINISH_RDB" USING BY REFERENCE CONTEXT GIVING RESULT IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE END-IF END-IF ELSE * * ok, now we have a numeric username. lets translate it to alphanumerics * and print it out. * MOVE USER_NAME_CODE TO IDENTIFIER PERFORM P3000_TRANSLATE_IDENTIFIER SET DISPLAY_FLAG TO TRUE DISPLAY ID_MSG (1:ID_MSG_LEN) MOVE SS$_NORMAL TO RESULT END-IF END-PERFORM END-IF. P3000_TRANSLATE_IDENTIFIER. * * A UIC as an identifier has the following format: * * +--+--------------+----------------+ * |00| group | member | * +--+--------------+----------------+ * ^^ * +----serves to identify this identifier as a UIC * * On your standard UIC of [USER,RUVOLO], the following might be true: * * USER ----> 0040FFFF * RUVOLO ----> 00400067 * * As you can see, the longword for RUVOLO includes the info which identifies * him with the group USER in the first half of the longword. * * An Id as an identifier has the following format: * * +--+--+----------------------------+ * |10|00| identifier | * +--+--+----------------------------+ * ^^ ^^ * | +-reserved to DIGITAL * +----serves to identify this identifier as an ID * MOVE 0 TO FOUND_BIT_POS. CALL "LIB$FFS" USING BY REFERENCE IDENT_CHECK_BIT, BY REFERENCE SIZE_BYTE, BY REFERENCE IDENTIFIER, BY REFERENCE FOUND_BIT_POS GIVING RESULT. IF NOT (RESULT = SS$_NORMAL OR LIB$_NOTFOU) THEN PERFORM P9999_ERROR_ROUTINE ELSE IF (FOUND_BIT_POS = 31) THEN * * we have an ID-format identifier * CALL "SYS$IDTOASC" USING BY VALUE IDENTIFIER, BY REFERENCE ID_MSG_LEN, BY DESCRIPTOR ID_MSG, OMITTED, OMITTED, OMITTED GIVING RESULT IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE MOVE SPACES TO ID_MSG MOVE 1 TO ID_MSG_LEN END-IF ELSE * * we must have a UIC-format identifier * CALL "SYS$FAO" USING BY DESCRIPTOR UIC_FORMAT, BY REFERENCE ID_MSG_LEN, BY DESCRIPTOR ID_MSG, BY VALUE IDENTIFIER GIVING RESULT IF RESULT NOT = SS$_NORMAL THEN PERFORM P9999_ERROR_ROUTINE END-IF END-IF END-IF. P9999_ERROR_ROUTINE. CALL "SYS$GETMSG" USING BY VALUE RESULT, BY REFERENCE ID_MSG_LEN, BY DESCRIPTOR ID_MSG, OMITTED, OMITTED GIVING E-RESULT. IF E-RESULT NOT = SS$_NORMAL THEN DISPLAY "**ERROR** trying to obtain error message..." BOLD DISPLAY "**ERROR** aborting..." BOLD STOP RUN END-IF. DISPLAY ID_MSG (1:ID_MSG_LEN) BOLD. .TITLE KGBDEF $KGBDEF GLOBAL .END .TITLE BP___GET_INPUT .IDENT /01-002/ ; ;++ ; ; Routine: BP___GET_INPUT (was HG$GET_INPUT) ; ; Author : Hunter Goatley ; Date : July 11, 1988 ; ; Functional Description: ; ; This routine implements an easy-to-call interface to the SMG$ ; routines to provide command recal when reading from SYS$INPUT. ; It takes the same arguments as LIB$GET_NPUT and may be substituted ; directly in any call to LIB$GET_INPUT. ; ; Example: ; ; CALL LIB$GET_INPUT (buffer, prompt, buffer) ; - to - ; CALL BP___GET_INPUT (buffer, prompt, buffer) ; ; To assemble and use: ; $ MACRO BP___GET_INPUT ; $ LINK your_program, BP___GET_INPUT ; $ RUN your_program ; ; Modified by: ; ; 01-001 Hunter Goatley 11-JUL-1988 Original Version ; 01-002 J. P. Ruvolo 25-JUL-1989 Redone for BP ; ;-- ; ; ;++ ; ; BP___GET_INPUT get-string [,prompt-str] [,out-len] ; ; Inputs: ; ; 4(AP) - String which is read from SYS$INPUT. ; Address of string descriptor. Write only. ; 8(AP) - Prompt message that is displayed (optional). ; Address of string descriptor. Read only. ; 12(AP) - Number of bytes written into @4(AP) (optional). ; Address of word. Write only. ; ; ; Returns: ; ; String in 4(AP) and status in R0. ; ; Effects: ; ; On first call, a key table and a virtual keyboard are created. ; ;-- BUFFER = 1 * 4 ; 1st arg is receiving buffer PROMPT = 2 * 4 ; 2nd arg is prompt RETLEN = 3 * 4 ; 3rd arg is receiving length $RMSDEF ; Include RMS symbols $SSDEF ; System service status symbols $SMGDEF ; INclude SMG$ symbols .PSECT _BP___GET_INPUT_DATA,NOEXE,WRT,LONG KEY_TABLE_ID:: .LONG 0 ; ID of key table created KEYBOARD_ID:: .LONG 0 ; ID of virtual keyboard .PSECT _BP___GET_INPUT_CODE,EXE,NOWRT,LONG,PIC,SHR .ENTRY BP___GET_INPUT,^M<> TSTL KEY_TABLE_ID ; Have we been called yet? ; ... (KEY_TABLE_ID <> 0) BNEQU 10$ ; Yes, skip initialization PUSHAL KEY_TABLE_ID ; Create a key table by CALLS #1,G^SMG$CREATE_KEY_TABLE ; ... calling SMG$ routine BLBC R0,40$ ; Return on error PUSHAL KEYBOARD_ID ; Create a virtual keyboard CALLS #1,G^SMG$CREATE_VIRTUAL_KEYBOARD BLBC R0,40$ ; Return on error ; ; Pass our parameters on to SMG$READ_COMPOSED_LINE. ; 10$: MOVL #3,R0 ; At least 3 args for SMG$READ CMPW #2,(AP) ; How many parms did we get? BEQL 20$ ; If 2, go handle it BGTR 30$ ; If 1, go handle it ; We got 3 if we hit here. PUSHAW @RETLEN(AP) ; Push address of length word INCL R0 ; Bump up SMG$READ args count 20$: PUSHAQ @PROMPT(AP) ; Push prompt desc. address INCL R0 ; Bump up SMG$READ args count 30$: PUSHAQ @BUFFER(AP) ; Push address of rcv. buffer PUSHAL KEY_TABLE_ID ; Push the key table id PUSHAL KEYBOARD_ID ; Push the keyboard id CALLS R0,G^SMG$READ_COMPOSED_LINE ; Call SMG$ rtn. to read line CMPL #SMG$_EOF,R0 ; Was ^Z entered? BNEQU 40$ ; NO - go on and return MOVL #RMS$_EOF,R0 ; Make status RMS$_EOF ; ...like LIB$ routine. 40$: RET ; Return to the caller .END