.title BLOCKING - ISAM record lock finder .ident 'V1.2-1' .library 'always' .library 'sys$share:lib' .ISALPHA .IF NDF,ALPHA .link 'sys$system:rmsdef.stb'/selective_search .link 'sys$system:sys.stb'/selective_search .IFF .DISABLE FLAGGING .ENDC ; ; Program: BLOCKING.MAR ; ; Author: David G. North, CCP ; 2000 N. Central Expressway, Suite 214 ; Plano, Texas 75074 ; (214) 881.1553 ; d_north@tditx.com ; ; Date: 94.01.08 ; ; Revisions: ; Who Date Ver Description ; D.North 940108 1.0 Internet release ; D.North 940207 1.1 Added rq/gr modes ; D.North 950603 1.2 Alpha port ; H.Goatley 960606 1.2-1 CLI changes so SET COMMAND isn't used ; ; License: ; Ownership of and rights to these programs is retained by the author(s). ; Limited license to use and distribute the software in this library is ; hereby granted under the following conditions: ; 1. Any and all authorship, ownership, copyright or licensing ; information is preserved within any source copies at all times. ; 2. Under absolutely *NO* circumstances may any of this code be used ; in any form for commercial profit without a written licensing ; agreement from the author(s). This does not imply that such ; a written agreement could not be obtained. ; 3. Except by written agreement under condition 2, source shall ; be freely provided with all binaries. ; 4. Library contents may be transferred or copied in any form so ; long as conditions 1, 2, and 3 are met. Nominal charges may ; be assessed for media and transferral labor without such charges ; being considered 'commercial profit' thereby violating condition 2. ; ; Warranty: ; These programs are distributed in the hopes that they will be useful, but ; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY ; or FITNESS FOR A PARTICULAR PURPOSE. ; .default displacement,word MAX_REC = 8192 ;Set this to max recordsize to retrieve with CWPS = 1 ;Define this if cluster-wide process services exist $chfdef ;Condition handling facility definitions $jpidef ;system information definitions $lckdef ;lock structure definitions $lkidef ;lock information definitions $pcbdef ;process control block definitions $phddef ;process header definitions $psldef ;process status longword definitions $rmsalldef ;all RMS definitions $ssdef ;system service message definitions $syidef ;system information definitions .IF DF,ALPHA $impdef ;RMS impure area definitions .ENDC .psect blocking$data,rd,wrt,noshr,noexe,long mi_fab: $fab fac = ,- ; only minimum required access shr = ; share anything mi_rab: $rab fab = mi_fab,- ; address of fab ubf = tstrec,- ; address of record buffer usz = TST_DATA_SIZE,- ; size of record buffer rbf = tstrec,- ; address of record buffer rsz = TST_DATA_SIZE ; size of record buffer tstrec: .blkb MAX_REC TST_DATA_SIZE = .-tstrec gotrecord: .blkl 1 dbuffer: .blkb 68 ;CLD interface names cliken: .ascid /KEY/ .ALIGN LONG clifin: .ascid /FILE/ .ALIGN LONG clihex: .ascid /HEXADECIMAL/ .ALIGN LONG clilen: .ascid /LENGTH/ .ALIGN LONG clifil: .ascid /FILL/ .ALIGN LONG clihol: .ascid /HOLD/ .ALIGN LONG ;CLD retrieved data areas keydsc: .udesc ;Key data fildsc: .udesc ;Filename data lendsc: .udesc ;Length text flldsc: .udesc ;Fill text cmddsc: .udesc ;The DCL command line verb: .ASCID /BLOCKING / .ALIGN LONG hexflg: .long 0 ;Hex is enabled flag holflg: .long 0 ;Hold record lock if obtained immediately length: .long 0 ;Length in binary fillch: .long 0 ;Fill character (0 if hex string, else spaces) .psect blocking$code,exe,shr,nowrt,rd ;++ ; OPEN_FILE - Open the requested input file ; Input is implicit descriptor at fildsc... this is the NAME of the ; file to open. ; Output is return status in r0, r1 trashed, file open & connected if ; r0 lbs. ;-- .entry open_file, 0 movb fildsc,mi_fab+fab$b_fns movab @fildsc+4,mi_fab+fab$l_fna $open - fab = mi_fab blbc r0,10$ ; go on if ok $connect - rab = mi_rab ; connect an access stream 10$: ret ;++ ; GETAST - Indicate that the record retrieval operation has completed ; Input - none in particular ; Output is gotrecord set to -1.l, $wake if necessary ;-- .entry getast, ^xffc tstl gotrecord beql 10$ $wake_s 10$: movl #-1,gotrecord ret ;++ ; READ_FILE - Initiate a TIMED read on the file ; Inputs: ; @4(AP) is descriptor to read key ; Output differs according to record status: ; 1) Record not found ; 2) Record found, but not locked by another stream ; 3) Record found & locked locally ; Notes: ; The timed read is required so we can forget about the read if the ; record was locked. There doesn't seem to be a way to 'cancel' the ; read attempt otherwise. ;-- .entry read_file, ^m moval mi_rab,r6 ; point to rab movb #rab$c_key,rab$b_rac(r6) ; type of get - sequential clrl rab$l_rop(r6) ; clear before setting bits bisl #,rab$l_rop(r6) movq @4(AP),r0 movb r0,rab$b_ksz(r6) movl r1,rab$l_kbf(r6) movb #10,rab$b_tmo(r6) ;wait only 10 sec $get - rab = mi_rab,- suc = getast,- err = getast cmpl r0,#RMS$_SYNCH bneq 10$ $dclast_s - ;corrects the RMS$_SYNCH astadr = getast ; misbehaviour 10$: ;There... now the $GET is queued, in-progress, or completed. ret ;++ ; REFLECT - reflect a signalled condition back to the caller of the ; signalling routine - effectively LIB$SIG_TO_RET ;-- .IF NDF,ALPHA .entry reflect, ^m movl CHF$L_SIGARGLST(AP),r4 ;signal argument list cmpl CHF$L_SIG_NAME(r4),#SS$_UNWIND ;is this an unwind??? beql 10$ ;yep... keep on unwinding movl CHF$L_MCHARGLST(AP),r5 ;get mechanism list address movl CHF$L_SIG_NAME(r4),CHF$L_MCH_SAVR0(r5) ;copy signal name $UNWIND_S ;Wipe out gracefully movl #SS$_CONTINUE,r0 ;Continue from exception 10$: ret ;return to caller of excepted procedure .ENDC ;++ ; GET_RMS_LKI - Go get the RMS lock information ; Notes: ; The irab lookup here is somewhat simplified from the normal form that ; RMS uses. It makes an assumption that the RAB being retrieved is one ; of only a few that are being used by the calling process. Therefore, ; embedding this routine in a larger program may cause this routine to fail. ;-- .entry get_rms_lki, ^xffc .IF NDF,ALPHA movaw reflect,(FP) ;set up a cond handler to trap screwups .ENDC movzwl mi_rab+rab$w_isi,r2 ;get blocked isi moval @#PIO$GW_IIOIMPA,r3 ;get addr of rms impure area moval @IMP$L_IRABTBL(r3),r3 ;vector to IRAB table portion movl (r3)[r2],r2 ;r2 now points to appropos IRAB moval IRB$L_RLB_BLINK(r2),r4 ;tail marker movl IRB$L_RLB_FLINK(r2),r3 ;head 10$: cmpl r3,r4 ;are we at tail? bneq 20$ ;nooop - keep examining movl #SS$_ABORT,r0 ret ;go scram 20$: cmpb RLB$B_ACTUAL(r3),- RLB$B_RQST(r3) ;see if lock modes are mismatched bneq 30$ movl RLB$L_FLINK(r3),r3 ;forward an rlb brw 10$ 30$: movl RLB$L_LKSB_LOCK_ID(r3),-(SP) ;now we got the lock ID clrl -(SP) moval (SP),r6 ;fake an LKSB clrq -(SP) moval (SP),r7 60$: ;we did not get the EX mode lock - go do getlki moval dbuffer,r5 ;point to buffer address space clrl -(SP) ;make itmlst terminator pushal (r5) ;return length area pushab 4(r5) ;return data area pushl #!64 ;itmcode,length moval (SP),r4 ;point to itmlst $getlkiw_s - ;go try to initiate block lookup efn = #2,- lkidadr = b^4(r6),- itmlst = (r4),- iosb = (r7) blbs r0,70$ ret ;poof if we get here - error 70$: ret ;scramola ;++ ; DEHEX_KEY - Convert keydata from hex text to binary data ; Notes: ; smashes r0-r3,r6-r9 ;-- dehex_key: .IF DF,ALPHA .jsb_entry input=,- output= .ENDC movaq keydsc,r0 brw dehex ;++ ; DEHEX - Convert keydata from hex text to binary data ; Input: r0 is descriptor address to be rewritten ; Notes: ; smashes r0-r3,r6-r9 ;-- dehex: .IF DF,ALPHA .jsb_entry input=,- output= .ENDC movq (r0),r6 ;get original descriptor movzwl r6,r6 ;clean up the descriptor length movq r6,r8 ;copy descr incl r8 ;benefit of doubt [implied 0] ashl #-1,r8,r8 ;div2 for hex convert movq r8,(r0) ;resulting descriptor pre-write clrl r1 ;assume result 0 blbs r6,20$ ;input length was odd... prefix a 0 10$: movzbl (r7)+,r2 ;pick up the high-order nybbler decl r6 ;count the used-up byte bsbb tobyte ;convert r2 to a byte ashl #4,r2,r3 ;put high nybbler in r3 20$: movzbl (r7)+,r2 ;pick up a low-order nybbler decl r6 ;count the used-up byte bsbb tobyte ;convert r2 to a byte bisb3 r2,r3,(r9)+ ;construct an output byte sobgtr r8,10$ ;go convert all bytes rsb ;we're done! tobyte: .IF DF,ALPHA .jsb_entry input=,- output= .ENDC locc r2,#32,tb10$ ;see if we can convert the char beql 20$ ;ie search string exhausted movab tb10$,r0 subl3 r0,r1,r2 bicb #^x10,r2 rsb 20$: PRINTF movzwl #SS$_ABORT,r0 ;The program goes 'Bzzt!' and disappears ret ; in a smelly puff of brown smoke .psect blocking$data tb10$: .ascii /0123456789ABCDEF0123456789abcdef/ .psect blocking$code ;++ ; CLI_INTERFACE - JSB routine to retrieve, check, convert, and load all ; CLD-specified parameters ;-- cli_interface: .IF DF,ALPHA .jsb_entry input=,- output= .ENDC PUSHAQ CMDDSC ;Get the foreign command line CALLS #1,G^LIB$GET_FOREIGN ;... RETLBC ;Return if low bit clear [r0] PUSHAQ CMDDSC ;Concatenate the command line to PUSHAQ VERB ;... the command verb so it can PUSHAQ CMDDSC ;... be parsed CALLS #3,G^STR$CONCAT ;... PUSHAL G^LIB$GET_INPUT ;Now go parse the command line PUSHAB BLOCKING_CLD ;... PUSHAQ CMDDSC ;... CALLS #3,G^CLI$DCL_PARSE ;... BLBS R0,5$ ;Branch if successful BISL2 #STS$M_INHIB_MSG,R0 ;If error, it's already been signalled RET ;... so inhibit message and return 5$: pushaw fildsc ;REQUIRED P1 is FILEname pushaq fildsc pushaq clifin calls #3,G^CLI$GET_VALUE ;get filename to open RETLBC ;Return if low bit clear [r0] pushaw keydsc ;REQUIRED qualifier is KEY data pushaq keydsc pushaq cliken calls #3,G^CLI$GET_VALUE ;get key to use RETLBC ;Return if low bit clear [r0] tstw keydsc ;is keylen nzero? bneq 35$ brw err_keylen 35$: pushaq clihex calls #1,G^CLI$PRESENT clrl hexflg movl #^a/ /,fillch ;default to space fillch blbc r0,20$ cmpl r0,#CLI$_PRESENT beql 10$ cmpl r0,#CLI$_DEFAULTED bneq 20$ 10$: incl hexflg clrl fillch ;default to binzero fill 20$: tstl hexflg ;see if spec'd keydata is hex... beql 30$ ;Nuup... skip the conversion bsbw dehex_key ;Go dehexify the key data [may RET] 30$: movzwl keydsc,length ;Get key data length as default len pushaq clilen calls #1,g^CLI$PRESENT ;see if length override spec'd blbc r0,50$ cmpl r0,#CLI$_PRESENT beql 40$ cmpl r0,#CLI$_DEFAULTED bneq 50$ 40$: pushaw lendsc ;qualifier is LENGTH data pushaq lendsc pushaq clilen calls #3,G^CLI$GET_VALUE ;get LENGTH RETLBC ;Return if low bit clear [r0] pushal length pushaq lendsc calls #2,g^OTS$CVT_TU_L ;convert text to long RETLBC ;Return if low bit clear [r0] 50$: pushaq clifil calls #1,G^CLI$PRESENT blbc r0,70$ cmpl r0,#CLI$_PRESENT beql 60$ cmpl r0,#CLI$_DEFAULTED bneq 70$ 60$: pushaw flldsc ;qualifier is FILLCH data pushaq flldsc pushaq clifil calls #3,G^CLI$GET_VALUE ;get FILLCH RETLBC ;Return if low bit clear [r0] pushal fillch pushaq flldsc calls #2,g^OTS$CVT_TU_L ;convert text to long RETLBC ;Return if low bit clear [r0] 70$: pushaq clihol ;should we hold record if we get it? calls #1,G^CLI$PRESENT clrl holflg ;default no of course cmpl r0,#CLI$_PRESENT bneq 90$ 80$: incl holflg ;Hold record if we get it 90$: ;Now go build appropos key to locate... bicl #^c^xff,length ;make length small enough movc5 keydsc,@keydsc+4,fillch,length,@keydsc+4 movw length,keydsc ;set new filled length movzwl #SS$_NORMAL,r0 rsb err_keylen: PRINTF movzwl #SS$_ABORT,r0 ;The program goes 'Poof!' and disappears ret ; in a small puff of reddish-blue smoke ;++ ; WAIT2 - Wait 2 seconds ;-- ;wait2: ;.IF DF,ALPHA ;.jsb_entry input=,- ; output= ;.ENDC .entry wait2, ^m ; moval (SP),r8 ;get rsb address address emul #-1000*100*100,#2,#0,-(sp) clrl -(sp) pushab 4(sp) clrq -(sp) calls #4,g^SYS$SCHDWK blbc r0,10$ calls #0,g^SYS$HIBER 10$: ; moval (r8),SP ;clean the stack ; rsb ret ;++ ; MAIN - Program main ;-- .entry main, ^m<> bsbw cli_interface ;Go get/convert all CLD interface params RETLBC calls #0,open_file RETLBC ;Return if low bit clear [r0] clrl gotrecord ;mark record not gotten to start with pushaq keydsc calls #1,read_file RETLBC ;Return if low bit clear [r0] ; bsbw wait2 ;now wait 2 seconds calls #0,wait2 cmpl gotrecord,#-1 ;did the record retrieval complete? beql 10$ brw grab 10$: movl mi_rab+RAB$L_STS,r0 ;get sts cmpl r0,#RMS$_RNF ;was record not there? bneq 20$ PRINTF ret ;just return the error 20$: cmpl r0,#RMS$_KSZ ;was keysize in error bneq 25$ PRINTF ret ;just return the error 25$: cmpl r0,#RMS$_RAC ;was keysize in error bneq 30$ PRINTF ret ;just return the error 30$: blbs r0,40$ PRINTF ,- mi_rab+RAB$L_STS,mi_rab+RAB$L_STV movl mi_rab+RAB$L_STS,r0 ;get sts ret 40$: PRINTF <%Specified record was not locked> tstl holflg ;are we supposed to hold it? bneq 50$ ;go hold record $close - fab = mi_fab ; RETLBC ;Return if low bit clear [r0] ret 50$: PRINTF <%Holding record... use ^Y, $ EXIT to release record> $hiber_s ret grab: PRINTF <%Record does appear to be locked - attempting trace> $cmexec_s - routin = get_rms_lki RETLBC ;Return if low bit clear [r0] moval dbuffer,r8 ;point to lock info buf movl (r8)+,r7 ;get lock info description movl r7,r6 movzwl r7,r7 ;get lo order (total size) ashl #-16,r6,r6 ;get high order (sizeof) addl r6,r7 ;add another for correct fenceposting 20$: subl r6,r7 beql 30$ ; bsbw prtlki ;This CAN return an error! calls #0,prtlki addl r6,r8 ;bump pointer brb 20$ 30$: cmpl gotrecord,#-1 incl gotrecord beql 40$ PRINTF <%Waiting for recordlock to timeout> $hiber_s 40$: ret ;prtlki: ;Print out retrieved lock information ;.IF DF,ALPHA ;.jsb_entry input=,- ; output= ;.ENDC .entry prtlki, ^m ; pushr #^xffc moval (SP),r7 clrq -(SP) ;iosb to use moval (SP),r9 ;iosb pointer subl #32,SP ;space for nodename moval (SP),-(SP) clrl -(SP) moval (SP),r6 clrl -(SP) pushal (r6) ;return length pushal @4(r6) ;return data pushl #!32 ;itmcode moval (SP),r5 $getsyiw_s - csidadr = LKI$L_CSID(r8),- itmlst = (r5),- iosb = (r9) movaq (r6),r2 ;nodename blbc r0,10$ movzwl (r9),r0 blbc r0,10$ brw 15$ 10$: movw #32,(r6) ;reset descr SPRINTF (r6),<[Error!XL]>,r0 15$: subl #32,SP ;space for nodename moval (SP),-(SP) clrl -(SP) moval (SP),r6 clrl -(SP) pushal (r6) ;return length pushal @4(r6) ;return data pushl #!32 ;itmcode moval (SP),r5 $getsyiw_s - csidadr = LKI$L_MSTCSID(r8),- itmlst = (r5),- iosb = (r9) movaq (r6),r3 ;_REAL_ nodename blbc r0,20$ movzwl (r9),r0 blbc r0,20$ brw 25$ 20$: movw #32,(r6) ;reset descr SPRINTF (r6),<[Error!XL]>,r0 25$: movzbl LKI$B_RQMODE(r8),r10 bsbw idlckmode movl r10,r11 movzbl LKI$B_GRMODE(r8),r10 bsbw idlckmode .if DF,CWPS subl #32,SP ;space for processname moval (SP),-(SP) clrl -(SP) moval (SP),r6 clrl -(SP) pushal (r6) ;return length pushal @4(r6) ;return data pushl #!32 ;itmcode moval (SP),r5 $getjpiw_s - pidadr = LKI$L_PID(r8),- itmlst = (r5),- iosb = (r9) movaq (r6),r4 ;processname blbc r0,30$ movzwl (r9),r0 blbc r0,30$ brw 35$ 30$: movw #32,(r6) ;reset descr SPRINTF (r6),<[Error!XL]>,r0 35$: cmpl LKI$L_MSTCSID(r8),LKI$L_CSID(r8) bneq 40$ PRINTF <%Blocking lock: !AS::"!AS", PID !XL, !AS/!AS>,- r2,r4,LKI$L_PID(r8),r10,r11 brw 99$ 40$: PRINTF <%Blocking lock: !AS::"!AS", PID !XL, !AS/!AS!/!_Lock mastered on !AS::>,- r2,r4,LKI$L_PID(r8),r10,r11,r3 brw 99$ .iff PRINTF <%Blocking lock held by !AS::!XL, !AS/!AS, mastered on !AS::>,- r2,LKI$L_PID(r8),r10,r11,r3 cmpl LKI$L_MSTCSID(r8),LKI$L_CSID(r8) bneq 50$ PRINTF <%Blocking lock: !AS::!XL, !AS/!AS>,- r2,LKI$L_PID(r8),r10,r11 brw 99$ 50$: PRINTF <%Blocking lock: !AS::!XL, !AS/!AS!/!_Lock mastered on !AS::>,- r2,LKI$L_PID(r8),r10,r11,r3 brw 99$ .endc 99$: moval (r7),SP ; popr #^xffc ; rsb ret ;r10-in = mode to name ;r10-out = mode name ascid address .psect blocking$data idlcktab: .long LCK$K_NLMODE .address idl10$ .long LCK$K_CRMODE .address idl20$ .long LCK$K_CWMODE .address idl30$ .long LCK$K_PRMODE .address idl40$ .long LCK$K_PWMODE .address idl50$ .long LCK$K_EXMODE .address idl60$ .address idl70$ .long 0 idl10$: .ascid /Nl/ idl20$: .ascid /Cr/ idl30$: .ascid /Cw/ idl40$: .ascid /Pr/ idl50$: .ascid /Pw/ idl60$: .ascid /Ex/ idl70$: .ascid /??/ .psect blocking$code idlckmode: .IF DF,ALPHA .jsb_entry input=,- output= .ENDC pushr #^xf ;r0-3 movaq w^idlcktab,r0 ;point at lookup table clrl r1 10$: movq (r0)[r1],r2 tstl r3 ;see if address pointer is there beql 20$ ;end of table cmpl r2,r10 ;see if mode matches beql 30$ ;matched aoblss #20,r1,10$ 20$: movl r2,r3 ;move the address 30$: movl r3,r10 ;return address popr #^xf rsb .end main