From:	ADVAX::"mcnc!CUNYVM.CUNY.EDU!VMSSERV%WKUVX1.BITNET" 25-FEB-1991 13:15:50.54
To:	arisia::everhart
CC:	
Subj:	DISK$WKUPUB2:[VMSSERV.FILES.DCLKEYS]DCLKEYS.01_OF_03;1

Received: by ADVAX.DECnet (utk-mail11 v1.5) ; Mon, 25 Feb 91 13:14:21 EST
Received:  from mcnc by ge-dab.GE.COM (5.61/GE-DAB 1.15) with UUCP
	id AA03671 for ; Mon, 25 Feb 91 12:05:59 -0500
Received: from CUNYVM.CUNY.EDU by mcnc.mcnc.org (5.59/MCNC/6-11-90)
	id AA08878; Mon, 25 Feb 91 10:01:57 -0500
	for arisia.dnet.ge.com!everhart
Message-Id: <9102251501.AA08878@mcnc.mcnc.org>
Received: from WKUVX1.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.2.2MX) with BSMTP id 6891; Mon, 25 Feb 91 10:02:16 EST
Date: Mon, 25 Feb 91 08:58 CST
From: mcnc!CUNYVM.CUNY.EDU!VMSSERV%WKUVX1.BITNET
Subject: DISK$WKUPUB2:[VMSSERV.FILES.DCLKEYS]DCLKEYS.01_OF_03;1
To: arisia::everhart
X-Vms-To: IN%"everhart@arisia.dnet.ge.com"
 
$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On  8-FEB-1991 09:15:16.59   By user GOATHUNTER (Hunter Goatley)
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$!+ THIS PACKAGE DISTRIBUTED IN 3 PARTS, TO KEEP EACH PART
$!  BELOW 30 BLOCKS
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. AAAREADME.TXT;1
$!       2. DCLKEYMACS.MAR;1
$!       3. DEFINE.MAR;1
$!       4. DELETE.MAR;1
$!       5. FIND.MAR;1
$!       6. GETDEF.MAR;1
$!       7. LOGIN.MAR;1
$!       8. STATE.MAR;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X                          DCL Key Definition Routines
X
XThese routines can be called from any VMS language to work with DCL key
Xdefinitions.  There were written to provide a way to perform the DCL
Xcommand DEFINE/KEY from a program, since there is no LIB$DEFINE_KEY
Xroutine.
X
XThese routines accompanied my VAX PROFESSIONAL article entitled
X"DCL Key Definition Routines", published in February 1988.  They
Xappear here courtesy of Hunter Goatley and Professional Press.
X
XThe routines presented here can be assembled and placed in an object
Xlibrary.  The commands to do this are
X
X`09$ DEFINE DCL$KEYLIB disk:`5Bdir`5D
X`09$ LIBRARY/MACRO/CREATE DCLKEY.MLB DCLKEYMACS.MAR
X`09$ MACRO DEFINE,DELETE,STATE,FIND,GETDEF
X`09$ LIBRARY/OBJECT/CREATE DCLKEY.OLB *.OBJ
X
XPrograms that call the routines could then link the object library:
X
X`09$ LINK LOGIN,DCLKEY/LIBRARY
X
XA sample LOGIN.MAR program has been supplied to demonstrate how to define
Xa key from MACRO.
X
XAny comments are appreciated.
X
X=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
V=-=-
XHunter Goatley, VAX Systems Programmer`09`09E-mail:`09GOATHUNTER@WKUVX1.bitn
Vet
XACRS, Western Kentucky University`09`09Voice:`09502-745-5251
X=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
V=-=-
$ CALL UNPACK AAAREADME.TXT;1 2020815658
$ create 'f'
X;===============   DCLKEYMACS.MAR
X;
X; AUTHOR:`09Hunter Goatley
X;`09`09Academic Computing, STH 226
X;`09`09Western Kentucky University
X;`09`09Bowling Green, KY 42101
X;`09`09Voice:`09502-745-5251
X;`09`09E-mail:`09GOATHUNTER@WKUVX1.bitnet
X;`09`09`09GOATHUNTER%wkuvx1@wku.edu
X;
X;`09`09CREATION DATE:`0915-MAY-1987
X
X;
X;  CHECK_ARGS`09- Checks the number of arguments passed to a routine.
X;`09`09  If an invalid number of arguments are given, control
X;`09`09  returns to the user with LIB$_WRONUMARG status.
X;
X`09.MACRO`09CHECK_ARGS`09NUMBER,?LABEL
X`09MOVL`09#LIB$_WRONUMARG,R0`09; Assume error
X`09CMPW`09NUMBER,(AP)`09`09; Were there enough?
X`09BEQLU`09LABEL`09`09`09; Yes - no sweat
X`09RET`09`09`09`09; No - return with error
XLABEL:`09.ENDM`09CHECK_ARGS
X
X;
X;  GET_PRC`09- Places the PRC address in R11.
X;
X`09.MACRO`09GET_PRC
X`09MOVAL`09G`5ECTL$AG_CLIDATA,R11`09; Get address of CLI data
X`09MOVL`09PPD$L_PRC(R11),R11`09; Get address of PRoCess data region
X`09.ENDM`09GET_PRC
$ CALL UNPACK DCLKEYMACS.MAR;1 1918900776
$ create 'f'
X`09.TITLE`09HG$DEFINE_KEY
X`09.IDENT`09"01-001"
X;+
X;  Function:`09HG$DEFINE_KEY
X;
X;  Author:`09Hunter Goatley   15-MAY-1987
X;`09`09Academic Computing, STH 226
X;`09`09Western Kentucky University
X;`09`09Bowling Green, KY 42101
X;`09`09Voice:`09502-745-5251
X;`09`09E-mail:`09GOATHUNTER@WKUVX1.bitnet
X;`09`09`09GOATHUNTER%wkuvx1@wku.edu
X;
X;  Functional description:
X;
X;`09HG$DEFINE_KEY performs the same function as the DCL DEFINE/KEY command.
X;
X;  Inputs:
X;
X;`094(AP)`09- Descriptor pointing to the keyname to define
X;`098(AP)`09- Descriptor pointing to the key's value
X;`0912(AP)`09- Descriptor pointing to /IF_STATE= string
X;`0916(AP)`09- Descriptor pointing to /SET_STATE string (0
X;`09   `09  if the key does not SET_STATE)
X;`0920(AP)`09- Address of longword holding SYM_M_* flags
X;
X;  Outputs:
X;
X;`09Status in R0`09- SS$_NORMAL, LIB$_INSCLIMEM
X;
X;  Effects:
X;
X;`09Defines a DCL key
X;
X;  Calling sequence:
X;
X;    STATUS = HG$DEFINE_KEY ("PF1","SHOW USERS","DEFAULT",,(SYM_M_ECHO) BY R
VEF)
X;-
XVMS4_5 = 1`09;**************************** Remove this line if under VMS 4.1
X
X`09.LIBRARY`09/DCL$KEYLIB:DCLKEY.MLB/
X`09.LINK`09`09/SYS$SYSTEM:SYS.STB/
X`09.LINK`09`09/SYS$SYSTEM:DCLDEF.STB/
X
X`09.PSECT`09_HG$DEFINE_KEY_CODE,EXE,NOWRT,LONG,PIC,SHR
XKEY_NAME`09= 4
XEQUIVALENCE`09= 8
XIF_STATE`09= 12
XSET_STATE`09= 16
XFLAGS`09`09= 20
XWORK_BYTES`09= 512
X`09.ENTRY`09HG$DEFINE_KEY,`5EM<R3,R10,R11>
X`09CHECK_ARGS`09#5`09`09; Make sure 5 arguments are present
X`09SUBL2`09#WORK_BYTES,SP`09`09; Allocate some space on the stack
X`09MOVL`09SP,R10`09`09`09; R10 --> template
X;
X;  Fill in the key template
X;
X`09CLRL`09SYM_L_FL(R10)`09`09; Clear forward link
X`09CLRL`09SYM_L_BL(R10)`09`09; Clear backward link
X
X.IF DEFINED VMS4_5
X`09CLRL`09SYM_L_ORDERED(R10)`09; Clear ORDERED link (not used)
X`09CLRW`09SYM_W_FILELEVEL(R10)`09; Clear file level
X`09MNEGW`09#1,SYM_W_PROCLEVEL(R10)`09; Set no procedure level
X`09CLRL`09SYM_L_PROCSEQ(R10)`09; ...
X`09CLRW`09SYM_W_BLOCKLEVEL(R10)`09; ...
X`09CLRL`09SYM_L_BLOCKSEQ(R10)`09; ...
X.ENDC
X`09CLRW`09SYM_W_SIZE(R10)`09`09; Clear size
X`09MOVB`09#SYM_K_KEYPAD, -`09; Set symbol entry type (KEYPAD symbol)
X`09`09SYM_B_TYPE(R10)`09`09; ...
X`09MOVL`09FLAGS(AP),R0`09`09; Get the flags
X.IF DEFINED VMS4_5
X`09MOVW`09(R0),SYM_W_FLAGS(R10)`09; ...  and set them in the template
X.IF_FALSE
X`09MOVB`09(R0),SYM_B_FLAGS(R10)`09; ...  and set them in the template
X.ENDC
X`09MOVAB`09SYM_T_SYMBOL(R10),R3`09; Get address in template of key name
X`09MOVL`09KEY_NAME(AP),R0`09`09; Get the key name
X`09MOVB`09(R0),(R3)+`09`09; Move its length
X`09MOVC3`09(R0),@4(R0),(R3)`09; Copy the string to the template
X`09MOVW`09@IF_STATE(AP),R0`09; Get sum of lengths of next 3 strings
X`09ADDW2`09@EQUIVALENCE(AP),R0`09; ...
X`09TSTL`09SET_STATE(AP)`09`09; Was a SET_STATE name given?
X`09BEQLU`0910$`09`09`09; No - don't try to move the length
X`09ADDW2`09@SET_STATE(AP),R0`09; ...
X10$:`09ADDW2`09#4,R0`09`09`09; ...  + 4 (the number of length bytes)
X`09MOVW`09R0,(R3)+`09`09; Put sum of lengths of next 3 fields
X`09PUSHL`09R0`09`09`09; Save the length for a minute
X`09MOVL`09IF_STATE(AP),R1`09`09; Get address of IF_STATE
X`09MOVB`09(R1),(R3)+`09`09; Move length of IF_STATE
X`09MOVC3`09(R1),@4(R1),(R3)`09; Move IF_STATE string
X`09MOVL`09EQUIVALENCE(AP),R1`09; Get address of EQUIVALENCE string
X`09MOVW`09(R1),(R3)+`09`09; Move length of EQUIVALENCE
X`09MOVC3`09(R1),@4(R1),(R3)`09; Move EQUIVALENCE string
X`09MOVL`09SET_STATE(AP),R1`09; Get address of SET_STATE
X`09BEQLU`0920$`09`09`09; If the address is 0, no SET_STATE
X`09MOVB`09(R1),(R3)+`09`09; Move length of SET_STATE
X`09MOVC3`09(R1),@4(R1),(R3)`09; Move SET_STATE string
X.IF DEFINED VMS4_5
X`09BISW2`09#SYM_M_STATE, -`09`09; Set STATE bit in FLAGS (just in case
X`09`09SYM_W_FLAGS(R10)`09; ...  the caller did not set it)
X.IF_FALSE
X`09BISB2`09#SYM_M_STATE, -`09`09; Set STATE bit in FLAGS (just in case
X`09`09SYM_B_FLAGS(R10)`09; ...  the caller did not set it)
X.ENDC
X20$:`09CLRB`09(R3)+`09`09`09; Clear last byte of template (could be
X`09`09`09`09`09; ...  taken as length of SET_STATE)
X`09ADDL3`09(SP)+,#SYM_T_SYMBOL+1,R0 ; Calculate the size of the template
X`09ADDB2`09SYM_T_SYMBOL(R10),R0`09; ...
X`09ADDL2`09#2,R0`09`09`09; Include word sum of the 3 lengths
X`09ADDL2`09#7,R0`09`09`09; Truncate to a quadword boundary
X`09BICL2`09#7,R0`09`09`09; Round to next quadword boundary
X`09MOVW`09R0,SYM_W_SIZE(R10)`09; Set the size of the queue entry
X`09$CMEXEC_S -`09`09`09; Go to executive mode to define key
X`09`09ROUTIN=EXEC_KEYDEF`09; ...
X`09ADDL2`09#WORK_BYTES,SP`09`09; Clean up the stack
X`09RET
X;
X;  Executive mode routine to allocate CLI memory and insert the new key
X;  definition into the KEYPAD queue.
X;
X`09.ENTRY`09EXEC_KEYDEF,`5EM<R3,R11>
X`09GET_PRC`09`09`09`09`09; Get address or PRoCess data
X`09MOVAB`09PRC_Q_ALLOCREG(R11),R3`09`09; Addr of free memory
X`09MOVZWL`09SYM_W_SIZE(R10),R1`09`09; Get size of block to allocate
X`09JSB`09@#EXE$ALLOCATE`09`09`09; Allocate some CLI memory
X`09MOVL`09#LIB$_INSCLIMEM,R0`09`09; Assume not enough CLI memory
X`09TSTL`09R2`09`09`09`09; Was there space allocated?
X`09BEQL`0920$`09`09`09`09; No - return the error
X`09PUSHR`09#`5EM<R0,R1,R2,R3,R4,R5>`09`09; Copy the key definition from
X`09MOVC5`09SYM_W_SIZE(R10),(R10),#0, -`09; ...  the template on the
X`09`09R1,(R2)`09`09`09`09; ...  stack to the memory just
X`09POPR`09#`5EM<R0,R1,R2,R3,R4,R5>`09`09; ...  allocated
X`09MOVW`09R1,SYM_W_SIZE(R10)`09`09; Set actual length allocated
X`09BSBW`09FIND_PLACE`09`09`09; Find the queue position for
X`09`09`09`09`09`09; ...  the key definition
X`09INSQUE`09SYM_L_FL(R2),@SYM_L_BL(R0)`09; Insert key def into queue at
X`09`09`09`09`09`09; ...  position returned in R0
X`09`09`09`09`09`09; ...  (by FIND_PLACE)
X`09MOVL`09#SS$_NORMAL,R0`09`09`09; Set successful return status
X20$:`09RET`09`09`09`09`09; Return to caller
X
X;+
X;  For efficiency and special-processing, internal subroutines were used
X;  to find the queue position and delete an existing key definition (instead
X;  of using the CALLable routines HG$FIND_KEY and HG$DELETE_KEY).
X;-
XFIND_PLACE:
X`09PUSHR`09#`5EM<R1,R2,R3,R4,R5,R6,R7,R8,R9>`09; Save registers needed
X`09MOVAB`09SYM_T_SYMBOL+1(R10),R1`09`09; Get addr of key name
X`09MOVZBL`09-1(R1),R0`09`09`09; Get its length
X`09ADDL2`09R0,R1`09`09`09`09; R1 --> word length of rest
X`09INCL`09R1`09`09`09`09; Bump R1 over the word length
X `09INCL`09R1`09`09`09`09; R1 --> IF_STATE string
X`09MOVZBL`09(R1)+,R0`09`09`09; Get the IF_STATE length
X`09PUSHL`09R1`09`09`09`09; Put addr on the stack
X`09PUSHL`09R0`09`09`09`09; Put the length on the stack
X`09MOVZBL`09SYM_T_SYMBOL(R10),R8`09`09; R8 = length of key name
X`09MOVAB`09SYM_T_SYMBOL+1(R10),R9`09`09; R9 --> key name
X`09MOVL`09PRC_Q_KEYPAD(R11),R6`09`09; R6 --> first entry in queue
X`09MOVAB`09PRC_Q_KEYPAD(R11),R7`09`09; R7 --> beginning of queue
X10$:`09CMPL`09R6,R7`09`09`09`09; Reached end of queue?
X`09BEQLU`0920$`09`09`09`09; Yes - found place
X`09`09`09`09`09`09; Check the state name
X`09MOVAB`09SYM_T_SYMBOL+1(R6),R1`09`09; Get addr of key name
X`09MOVZBL`09-1(R1),R0`09`09`09; Get its length
X`09ADDL2`09R0,R1`09`09`09`09; R1 --> word length of rest
X`09INCL`09R1`09`09`09`09; Bump R1 over the word length
X`09INCL`09R1`09`09`09`09; R1 --> IF_STATE string
X`09MOVZBL`09(R1)+,R0`09`09`09; Get the IF_STATE length
X`09CMPC5`09(SP),@4(SP),#`5EA/ /,R0,(R1)`09; Is this the same state?
X`09BLSSU`0920$`09`09`09`09; No - try next entry
X `09BGTRU`0915$`09`09`09`09; If >, no entries for IF_STATE
X`09`09`09`09`09`09; Check the key names
X`09MOVZBL`09SYM_T_SYMBOL(R6),R0`09`09; Get length of key name in que
X`09CMPC5`09R8,(R9),#`5EA/ /,R0,SYM_T_SYMBOL+1(R6)`09; Compare the strings
X`09BLSSU`0920$`09`09`09`09; Found place if KEY < QUEUE KEY
X`09BNEQU`0915$`09`09`09`09; If not the same, go try next
X;
X; Here if key already exists
X;
X`09BSBW`09DELETEKEY`09`09`09; Delete the key
X`09BRB`0920$`09`09`09`09; Return to caller
X15$:`09MOVL`09SYM_L_FL(R6),R6`09`09`09; Get the next keypad entry
X`09BRB`0910$`09`09`09`09; ...  and try again
X20$:`09ADDL2`09#8,SP`09     `09`09`09; Clean up stack
X`09MOVL`09R6,R0`09`09`09`09; Return addr of QUEUE KEY entry
X`09POPR`09#`5EM<R1,R2,R3,R4,R5,R6,R7,R8,R9>`09; ...
X`09RSB`09`09`09`09`09; ...
X
XDELETEKEY:
X`09PUSHL`09R3`09`09`09`09; Save work register
X`09MOVAB`09PRC_Q_ALLOCREG(R11),R3`09`09; Get allocation region listhead
X`09REMQUE`09SYM_L_FL(R6),R0`09`09`09; Remove key def from the queue
X`09MOVL`09SYM_L_FL(R0),R6`09`09`09; Make the Forward Link entry
X`09`09`09`09`09`09; ... new "current" entry
X`09MOVZWL`09SYM_W_SIZE(R0),R1`09`09; Get deleted entry size
X`09JSB`09@#EXE$DEALLOCATE`09`09; Deallocate the memory
X`09MOVL`09(SP)+,R3`09`09`09; Restore register
X`09RSB`09`09`09`09`09; Return to caller
X
X`09.END
$ CALL UNPACK DEFINE.MAR;1 1880113416
$ create 'f'
X`09.TITLE`09HG$DELETE_KEY
X`09.IDENT`09"01-001"
X;+
X;  Function:`09HG$DELETE_KEY
X;
X;  Author:`09Hunter Goatley   15-MAY-1987
X;`09`09Academic Computing, STH 226
X;`09`09Western Kentucky University
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-
