.title mbox get contents of mailbox ; ; Copyright (C) 1993 Neill Clift (neill@macro.demon.co.uk). ; ; This program comes without any warranty. The author does not accept any ; responsibility for any damage caused by the use of this program. This ; program is not in the public domain but may be copied freely so long as this ; copyright notice remains. ; ; Please send any modifications to the author. ; ; This program allows a privileged user to view the contents, pending I/O and ; attention ASTs on almost any mailbox in the system. ; ; Edit history: ; ; V01-001 Neill Clift 19-FEB-1994 ; Added support for the /group qualifier so that you can display mailboxs ; owned by processes within a particular group. Needed this as we run a ; number of test systems as work on a single machine separated by group. ; V01-002 Neill Clift 23-FEB-1994 ; Always put a colon on the end of the mailbox name so people can click ; on it with their mouse. ; V01-003 Neill Clift 18-JUN-1994 ; Fix bug were astprm and astadr were wrong for a pending read ; V01-004 Neill Clift 20-JUN-1994 ; Get it to work on the AXP. ; ; .disable global ; $psldef .if ndf psl$m_z AXP = 1 .endc ; .library /sys$library:lib.mlb/ .link /sys$system:sys.stb//selective_search ; .if df AXP .disable flagging .endc ; $acbdef ; AST control block defs $ccbdef ; Channel control block defs $climsgdef ; CLI$... routines $dcdef ; Device classes $devdef ; Device attributes $dvidef ; $GETDVI constants $dvsdef ; Device scan definitions $ipldef ; Define IPL values $irpdef ; I/O request packet offsets $jpidef ; $GETJPI constants $kgbdef ; Rights ID stuff $lnmstrdef ; Logical name block defs $namdef ; Name block defs $pcbdef ; Process control block offsets $phddef ; Process header offsets $rsndef ; System resource definitions $ssdef ; System service definitions $statedef ; Process state definitions $strdef ; String return codes $stsdef ; Completion status bitfields $ucbdef ; Unit control block defs ; ; Define new read queue for V5.5 ; .if df AXP .if_false .if ndf ucb$l_mb_readqfl ucb$l_mb_readqfl = ucb$l_mb_rast .if_false assume ucb$l_mb_rast eq ucb$l_mb_readqfl .endc .endc ; ; External routines. ; .external lib$get_foreign, - ; Get command line lib$scopy_dxdx, - ; Copy string descriptor lib$signal ; Signal error condition .external lib$wait .external str$match_wild, - ; Match wildcard string str$upcase ; Uppercase a string .external cli$get_value, - ; Get value from command line cli$dcl_parse, - ; Parse the command line cli$present ; Item on command line? .external ots$cvt_to_l ; Convert octal text to binary ; ; External JSBs. ; .if df AXP .external exe$cvt_ipid_to_epid ; Conv pid from intrn to extrn .if_false .external exe$ipid_to_epid ; Conv pid from intrn to extrn .endc .external exe$probew_dsc ; Probe a descriptor for write .external ioc$verifychan ; Verify channel number .external lnm$lockr, - ; lock logical name tables lnm$unlock ; Unlock logical name tables ; ; External data. ; .external ctl$gl_pcb ; Address of current PCB .external vms$gl_license_version ; Current binary VMS version .external sch$gl_maxpix ; Maximum process index .external sch$gl_pcbvec ; PCB vector array ; ; Define the command table. ; .external mbox_clitable ; ; Define error messages. ; .external mbox__errcon, - ; Error connecting to file mbox__errcre, - ; Error creating file mbox__errput, - ; Error during put mbox__erroctal ; Error with group ; .macro startlock ?l1 jmp l1 .save_psect .psect mbox_code_locked rd exe pic shr l1: .if df AXP .linkage_psect mbox_linkage_locked .endc .endm startlock ; .macro endlock ?l1 jmp l1 .restore_psect l1: .if df axp .linkage_psect $linkage .endc .endm endlock ; ; Define mailbox structures. These structures are linked onto the ucb$l_fqfl ; and ucb$l_fqbl as a queue. Prior to version 5.5 they had the structure of ; mbx4 and after mbx5 ; ; Define the constant region ; $defini mbx $def mbx_l_flink .long ; Forward link $def mbx_l_blink .long ; Backward link $def mbx_w_size .word ; Size of block $def mbx_b_type .byte ; Type of block $def mbx_b_func .byte ; I/O function code $equ mbx_k_fixed . ; Size of fixed portion $defend mbx ; ; Now define structure up to V5.4-3 ; $defini mbx4 $def mbx4_r_fixed .blkb mbx_k_fixed ; Fixed portion $def mbx4_w_msgsiz .word ; Message size $def mbx4_l_irpadr .long ; Address of IRP $def mbx4_l_pid .long ; Process id of writer $equ mbx4_r_msg . ; Start of message $defini mbx4 ; ; Now define structure as of 5.5 ; $defini mbx5 $def mbx5_r_fixed .blkb mbx_k_fixed ; Fixed portion $def mbx5_l_irpadr .long ; Address of IRP $def mbx5_l_pid .long ; Process id of writer $def mbx5_r_unk1 .blkl 3 ; God knows what! $def mbx5_w_msgsiz .word ; Message size $def mbx5_w_unk2 .blkw ; God knows what! $equ mbx5_r_msg . ; Start of message $defend mbx5 ; ; Define symbols ; offset_size = 4 ; Size of offset into buffer in bytes default_line_length = 80 ; Size of line by default ; .psect mbox_rdata nowrt rd noexe shr ; dvilst: .word 4, dvi$_devbufsiz .address mbxdevbufsiz .long 0 .word 4, dvi$_devdepend .address mbxdevdepend .long 0 .word devnam_len, dvi$_devnam .address devnam_b, devnam .word 4, dvi$_opcnt .address mbxopcnt .long 0 .word 4, dvi$_refcnt .address mbxrefcnt .long 0 .word 4, dvi$_ownuic .address mbxownuic .long 0 .long 0 ; ; Item list to get device buffer size. ; trmdvilst: .word 4, dvi$_devbufsiz .address line_length .long 0 .long 0 ; jpilst: .word mbxprocnam_len, jpi$_prcnam .address mbxprocnam_b, mbxprocnam .long 0 ; ; Item list to get the current processes UIC so the user can say just /GROUP to ; get his/her own group. ; jpigrp: .word 2, jpi$_grp .address match_group .long 0 .long 0 ; dvslst: .word 4, dvs$_devclass .address devclass .long 0 .word 4, dvs$_devtype .address devtype .long 0 devclass: .long dc$_mailbox devtype: .long dt$_mbx ; ; Produce a table to convert a radix into a number of digits to represent a ; given data size. ; radix: .long 0 ; 0 .long 0 ; 1 .long 0 ; 2 .long 0 ; 3 .long 0 ; 4 .long 0 ; 5 .long 0 ; 6 .long 0 ; 7 .address octsize .long 0 ; 9 .address decsize .long 0 ; 11 .long 0 ; 12 .long 0 ; 13 .long 0 ; 14 .long 0 ; 15 .address hexsize ; decsize: .byte 0, 3, 5, 8, 10 hexsize: .byte 0, 2, 4, 6, 8 octsize: .byte 0, 3, 6, 8, 11 ; hdrctrstr1: .ascid \!/Device: !AS: (!AS), Channels: !UL, Operations: !UL\ hdrctrstr2: .ascid \!/ Total size: !UL, Remaining: !UL, \- \Message size: !UL, Msgs: !UW\ ; attnctrstr: .ascid \!/ !AS, PID: !XL (!AF), Mode: !AF, ADR: !XL, PRM: !XL\ ; rwmbxctrstr: .ascid \!/ RWMBX, PID: !XL (!AF)\ ; msgctrstr: .ascid \!/ Message number: !UL, !UW byte!%S, Written by: !XL \- \(!AF)!AS!/\ ; hextab: .ascii /0123456789ABCDEF/ ; ; Strings to describe if the current mailbox message being displayed has a ; process waiting for the message to be read by another process. ; waitchars: .address notwaiting, - waiting ; 0 = Not waiting, 1 = Wait for reader notwaiting: .ascid // waiting: .ascid / Waiting/ ; attn: .address readattn, wrtattn, readio ; readattn: .ascid /READATTN/ wrtattn: .ascid /WRTATTN/ readio: .ascid /READIO/ ; modes: .ascii /KESU/ ; unavailable: .ascid /Nonexistent/ ; none: .ascid /None/ ; ; To start the ball rolling we prime CLI$DCL_PARSE with just the verb ; verb: .ascid /MBOX/ ; Verb name ; output_qual: .ascid /OUTPUT/ ; /OUTPUT ; mailbox_qual: .ascid /MAILBOX/ ; P1 ; byte_qual: .ascid /BYTE/ ; word_qual: .ascid /WORD/ ; longword_qual: .ascid /LONGWORD/ ; decimal_qual: .ascid /DECIMAL/ ; hexadecimal_qual: .ascid /HEXADECIMAL/ ; octal_qual: .ascid /OCTAL/ ; rwmbx_qual: .ascid /RWMBX/ ; Only display RWMBX procs ; read_qual: .ascid /READ_ATTENTION/ ; Only display read attentions ; write_qual: .ascid /WRITE_ATTENTION/ ; Only display write attentions ; pending_qual: .ascid /PENDING_READS/ ; Only display pending reads ; messages_qual: .ascid /MESSAGES/ ; Only display contents ; headers_qual: .ascid /HEADERS/ ; Display all headers ; group_qual: .ascid /GROUP/ ; Display only in this group ; .psect mbox_wdata wrt rd noexe noshr quad ; outfab: $fab dnm = , - ; Default file name fac = put, - ; Only doing puts fop = , - ; Deferred writes, sequential nam = outnam, - ; Use name block org = seq, - ; Sequential file rat = cr, - ; Carriage control = return rfm = var, - ; Variable length records shr = shrget ; Allow other readers ; outrab: $rab fab = outfab, - ; Use with this fab rac = seq, - ; Sequential access rbf = outbuf_b, - ; Output buffer address rop = wbh ; Write behind ; outnam: $nam esa = ess_b, - ; Expanded name buffer ess = ess_len, - ; Expanded name size rsa = rss_b, - ; Resultant name buffer rss = rss_len ; Resultant name size ; mbxprocnam_len = 15 ; Size of a process name mbxprocnam: .word mbxprocnam_len, 0 .address mbxprocnam_b ; mbxlognam_len = 20 ; Size of mailbox logical mbxlognam: .word mbxlognam_len, 0 .address mbxlognam_b ; ; Large buffer to contain any message ; mbxbuf_len = 65535 mbxbuf: .word mbxbuf_len, 0 .address mbxbuf_b ; devnam_len = 64 ; Name of mailbox devnam: .word devnam_len, 0 .address devnam_b ; wilddev_len = 64 ; Wildcard mailbox name wilddev:.word wilddev_len, 0 .address wilddev_b ; groupstr_len = kgb$s_name ; Group name for matching groupstr: .word groupstr_len, 0 .address groupstr_b ; outbuf_len = 255 outbuf: .word outbuf_len, 0 .address outbuf_b ; output_len = nam$c_maxrss ; Size of output filename output: .word output_len, 0 .address output_b ; .psect mbox_dzero wrt rd noexe noshr ; contxt: .quad 0 ; Device scan context ; iosb: .quad 0 ; mbxctx: .long 0 ; Context for looping calls ; mbxpid: .long 0 ; Process ID of mailbox writer ; mbxwait:.long 0 ; Process is waiting reader ; mbxopcnt: .long 0 ; Operations completed ; mbxrefcnt: .long 0 ; References to mailbox ; mbxownuic: .long 0 ; UIC of owner ; mbxdevbufsiz: .long 0 ; Device buffer size (record) ; mbxiniquo: .long 0 ; Initial device quota ; mbxbufquo: .long 0 ; Device buffer size ; mbxdevdepend: .long 0 ; Low word = message count ; mbxmode: .long 0 ; Mode of attention ASTs ; mbxastadr: .long 0 ; AST address of attention ASTs ; mbxastprm: .long 0 ; AST param of attention ASTs ; flg_v_headerdone = 0 ; Printed out header yet? flg_v_group = 1 ; flags: .long 0 ; Working flags ; cfl_v_rwmbx = 0 cfl_v_read = 1 cfl_v_write = 2 cfl_v_messages = 3 cfl_v_headers = 4 cfl_v_pending = 5 ; cliflags: .long 0 ; Flags for qualifiers present clinegflags: .long 0 ; Negated version of the above ; mbxchan:.word 0 ; Channel to mailbox ; ; Byte = 0 ; Word = 1 ; Longword = 2 ; alignment: .long 0 ; Data alignment ; size: .long 0 ; Size of data ; base: .long 0 ; Base to use ; bytes_per_line: .long 0 ; Bytes to display on line ; line_length: .long 0 ; length of line in bytes ; frcpmt: .long 0 ; Force prompting flag ; match_group: .long 0 ; UIC to match against ; devnam_b: .blkb devnam_len ; Device name buffer ; mbxlognam_b: .blkb mbxlognam_len ; Proc name of mailbox writer ; mbxprocnam_b: .blkb mbxprocnam_len ; Proc name of mailbox writer ; wilddev_b: .blkb wilddev_len ; User wildcard device name ; groupstr_b: .blkb groupstr_len ; User wildcard device name ; outbuf_b: .blkb outbuf_len ; Output buffer ; output_b: .blkb output_len ; Output filename buffer ; ess_len = nam$c_maxrss ess_b: .blkb ess_len ; Expanded file name ; rss_len = nam$c_maxrss rss_b: .blkb rss_len ; Resultant file name ; mbxbuf_b: .blkb mbxbuf_len ; Mailbox contents buffer ; ; ; Declare the start labels for the locked PSECTS ; .psect mbox_code_locked rd exe pic shr lock_start: .if df AXP .jsb_entry ; .psect mbox_linkage_locked noexe nowrt lock_linkage_start: .endc .psect mbox_code nowrt rd exe pic shr ; .entry mbox ^m bsbw get_qualifiers_r1 blbc r0, 99$ bsbw open_output_r1 blbc r0, 99$ bsbw get_modes_r1 blbc r0, 99$ bsbw lock_code_and_data_r2 blbc r0, 99$ bsbw get_device_r1 blbc r0, 99$ 1$: bsbb search_device_r1 blbc r0, 100$ bsbw dump_device_r11 blbs r0, 1$ 99$: ret 100$: cmpw r0, #ss$_nomoredev bneq 99$ movl #ss$_normal, r0 ret ; ; Searches for devices matching the specification. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes ; R1 ; search_device_r1: .if df AXP .jsb_entry output = .endc bicl2 #<1@flg_v_headerdone>, flags ; Reset flags for next device 1$: movzwl mbxchan, r0 ; We already have a channel beql 2$ ; Nope $dassgn_s - ; Deassign old one chan = r0 blbc r0, 99$ ; Error? clrw mbxchan ; Say no channel anymore 2$: movw #devnam_len, devnam ; Reset descriptor $device_scan_s - ; Scan for next device return_devnam = devnam, - retlen = devnam, - itmlst = dvslst, - contxt = contxt blbc r0, 99$ bsbb get_device_name_r1 ; get the device name cmpw r0, #ss$_nosuchdev ; Gone now? beql 2$ ; yep so continue blbc r0, 99$ ; Quit if error 3$: bsbw match_device_r1 ; match the device name blbs r0, 99$ ; All is ok cmpl r0, #str$_nomatch ; No match status beql 1$ ; next device 99$: rsb ; ; Assigns the channel and uses $getdviw to obtain the device name. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; get_device_name_r1: .if df AXP .jsb_entry output = .endc $assign_s - ; Assign a channel to it devnam = devnam, - ; Use returned device name chan = mbxchan ; Save chan for later blbc r0, 99$ $getdviw_s - ; Get some info on this dev chan = mbxchan, - ; use mailbox chan rather iosb = iosb, - ; than name as less volatile itmlst = dvilst blbc r0, 99$ ; Quit on error movl iosb, r0 ; Get other status blbc r0, 99$ ; quit with error decl mbxrefcnt ; Don't count our reference pushal mbxbufquo ; Get space left pushal mbxiniquo ; Get initial space movzwl mbxchan, -(sp) ; From this mailbox calls #3, get_mailbox_sizes ; Get the mailbox sizes blbc r0, 99$ ; quit with error pushaq devnam ; Strip this device name calls #1, strip_device ; Cut off _ : and space etc 99$: rsb ; ; Dumps out the contents of the mailbox ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1,R2,R11 ; dump_device_r11: .if df AXP .jsb_entry output = .endc movl #ss$_normal, r0 ; Assume all is ok bbc #cfl_v_headers, cliflags, 1$ ; Need to print all headers bsbw print_header_r1 ; Print out header for mailbox blbc r0, 99$ ; Quit on error 1$: bbc #cfl_v_rwmbx, cliflags, 2$ ; Need to print RWMBX procs? bsbw print_rwmbx_r1 ; Print out waiting processes blbc r0, 99$ ; Quit with error 2$: bsbb print_attn_r2 ; Print out attention info blbc r0, 99$ bbc #cfl_v_pending, cliflags, 3$ ; Pending reads need doing? bsbw print_read_r1 ; print out pending I/O blbc r0, 99$ 3$: bbc #cfl_v_messages, cliflags, 99$ ; Need to print out contents bsbw print_contents_r11 99$: rsb ; ; Print the attention ASTs of the mailbox ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1,R2 ; print_attn_r2: .if df AXP .jsb_entry output= .endc pushal mbxastprm ; Put astprm here pushal mbxastadr ; Put astadr here pushal mbxpid ; Put PID here pushal mbxmode ; Put access mode here pushal mbxctx ; Context for loop clrl -(sp) ; Start on reads movzwl mbxchan, -(sp) ; Channel to mailbox pushl #7 ; Set number of args bbc #cfl_v_read, cliflags, 110$ ; Need to do reads? 1$: clrl mbxctx ; Start at first attn AST 2$: movl sp, r2 $cmkrnl_s - routin = w^get_attn_list_k, - ; Get the list arglst = (r2) blbc r0, 100$ bsbw get_procname_r1 ; Convert PID to PRCNAM blbc r0, 98$ ; Quit with error movl 4+4(sp), r0 ; Get list bsbb print_attn_line_r1 ; Print out the line blbs r0, 2$ ; continue 98$: addl2 #8*4, sp 99$: rsb 100$: cmpw r0, #ss$_endoffile bneq 98$ 110$: bbc #cfl_v_write, cliflags, 120$ ; Need to do writes? bbcs #0,4+4(sp), 1$ ; Do writes now 120$: movl #ss$_normal, r0 ; Say all is ok brb 98$ ; Continue ; ; Prints out the line for attention ASTs and outstanding I/O. ; ; Inputs: ; R0: List that is being traced. 0 = Read, 1 = Write ! attn only ; Outputs: ; R0: Status ; Trashes: ; R1 ; print_read_line_r1: .if df AXP .jsb_entry output = .endc movl #2, r0 ; Say we are internal .if df AXP bsbb print_attn_line_r1 rsb .endc ; print_attn_line_r1: .if df AXP .jsb_entry input=, output = .endc pushl r0 ; Save list bsbw print_header_r1 ; Print out header for mailbox popl r1 ; Restore list blbc r0, 99$ ; Quit on error movzbl #outbuf_len, outbuf ; Reset to max size movl attn[r1], r0 ; Get address of string movl mbxmode, r1 ; Get mode movab modes[r1], r1 ; Get address of char $fao_s ctrstr = attnctrstr, - outbuf = outbuf, - outlen = outbuf, - p1 = r0, - ; Attn list name p2 = mbxpid, - ; PID p3 = mbxprocnam, - ; Process name length p4 = mbxprocnam+4, - ; Process name p5 = #1, - ; one char for mode p6 = r1, - ; mode char p7 = mbxastadr, - ; AST address p8 = mbxastprm ; AST parameter blbc r0, 99$ bsbw write_r1 ; Put record to output 99$: rsb ; ; Print the outstanding I/O of the mailbox ; print_read_r1: .if df AXP .jsb_entry output = .endc pushal mbxastprm ; Put astprm here pushal mbxastadr ; Put astadr here pushal mbxpid ; Put PID here pushal mbxmode ; Put access mode here pushal mbxctx ; Context for loop movzwl mbxchan, -(sp) ; Channel to mailbox pushl #6 ; Set number of args 1$: clrl mbxctx ; Start at first I/O 2$: movl sp, r2 $cmkrnl_s - routin = w^get_read_list_k, - ; Get the list arglst = (r2) blbc r0, 100$ bsbw get_procname_r1 ; Convert PID to PRCNAM blbc r0, 98$ ; Quit with error bsbw print_read_line_r1 ; Print out the line blbs r0, 2$ ; continue 98$: addl2 #7*4, sp 99$: rsb 100$: cmpw r0, #ss$_endoffile bneq 98$ movl #ss$_normal, r0 ; Say all is ok brb 98$ ; Continue ; ; Print out processes waiting for space in this mailbox ; print_rwmbx_r1: .if df AXP .jsb_entry output = .endc cmpl mbxbufquo, mbxdevbufsiz bgequ 1$ pushaf #^F0.1 calls #1, g^lib$wait 1$: pushal mbxpid ; Put PID here pushal mbxctx ; Context for loop movzwl mbxchan, -(sp) ; Channel to mailbox pushl #3 ; Set number of args clrl mbxctx ; Start at first process movl sp, r2 2$: $cmkrnl_s - routin = w^get_rwmbx_k, - ; Get the processes arglst = (r2) blbc r0, 100$ bsbw get_procname_r1 ; Convert PID to PRCNAM blbc r0, 98$ ; Quit with error bsbb print_rwmbx_line_r1 ; Print out the line blbs r0, 2$ ; continue 98$: addl2 #4*4, sp 99$: rsb 100$: cmpw r0, #ss$_endoffile bneq 98$ movl #ss$_normal, r0 ; Say all is ok brb 98$ ; Continue ; ; Prints out the line for RWMBX processes. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; print_rwmbx_line_r1: .if df AXP .jsb_entry output = .endc bsbw print_header_r1 ; Print out header for mailbox blbc r0, 99$ ; Quit on error movzbl #outbuf_len, outbuf ; Reset to max size $fao_s ctrstr = rwmbxctrstr, - outbuf = outbuf, - outlen = outbuf, - p1 = mbxpid, - ; PID p2 = mbxprocnam, - ; Process name length p3 = mbxprocnam+4 ; Process name blbc r0, 99$ bsbw write_r1 ; Put record to output 99$: rsb ; ; ; Print the contents of the mailbox ; print_contents_r11: .if df AXP .jsb_entry output = .endc movl #1, r11 ; Start at line one clrl mbxctx ; Start at first message again pushal mbxwait ; Waiting? pushaw mbxbuf ; Build argument list pushaq mbxbuf ; on the stack ready for pushal mbxpid ; the call to $cmkrnl pushal mbxctx movzwl mbxchan, -(sp) ; Use this channel pushl #6 ; Set number of args 1$: movl sp, r2 movzwl #mbxbuf_len, mbxbuf ; Set max size of buffer $cmkrnl_s - routin = w^mbox_contents_k, - arglst = (r2) blbc r0, 100$ bsbw get_procname_r1 ; Convert PID to PRCNAM blbc r0, 98$ ; Quit with error bsbw print_data_r11 ; Print out this chunk of data incl r11 ; Say next message blbs r0, 1$ 98$: addl2 #7*4, sp 99$: rsb 100$: cmpw r0, #ss$_endoffile bneq 98$ movl #ss$_normal, r0 brb 98$ ; ; Matches the device name against the users input to see if this mailbox is ; one that is wanted ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; match_device_r1: .if df AXP .jsb_entry output = .endc movl #str$_nomatch, r0 ; Assume no match bbc #flg_v_group, flags, 1$ ; Need to test owner? cmpw mbxownuic+2, match_group ; Compare it bneq 99$ ; No need to go further 1$: bsbb get_logical_r2 ; get logical for mailbox blbc r0, 99$ ; Quit with error tstw wilddev ; Always match null string beql 99$ ; Skip match tests ; ; Try to match logical name first. ; pushaq wilddev ; Match against wild device pushaq mbxlognam ; Match logical name calls #2, g^str$match_wild ; wildcard match blbs r0, 99$ ; Matched so continue pushaq wilddev ; match against wild device pushaq devnam ; match against device name calls #2, g^str$match_wild ; match as wildcard 99$: rsb ; ; Gets the logical name for the mailbox. If none is found it substitutes a ; string to say so. ; get_logical_r2: .if df AXP .jsb_entry output = .endc movw #mbxlognam_len, mbxlognam ; Fix up to max size pushaw mbxlognam ; Patch up with size pushaq mbxlognam ; Put name here movzwl mbxchan, -(sp) ; Get from this channel pushl #3 ; Three arguments movl sp, r2 ; Get pointer to arglst $cmkrnl_s - routin = w^get_logical_k, - ; Get the mailbox logical arglst = (r2) addl2 #4*4, sp ; Drop arguments on floor blbc r0, 99$ ; Quit with error tstw mbxlognam ; Anything there? bneq 99$ ; Got something movw none, mbxlognam ; Set size pushaq mbxlognam ; Replace logical name pushaq none ; Copy none calls #2, g^lib$scopy_dxdx ; Copy the string 99$: rsb ; ; Gets the process name associated with a writers PID ; get_procname_r1: .if df AXP .jsb_entry output = .endc tstl mbxpid beql 99$ $getjpiw_s - pidadr = mbxpid, - itmlst = jpilst, - iosb = iosb blbc r0, 99$ movl iosb, r0 blbc r0, 99$ rsb 99$: movw #mbxprocnam_len, mbxprocnam ; Rest size of descriptor $getmsg_s - ; Try to get error message id msgid = r0, - msglen = mbxprocnam, - bufadr = mbxprocnam, - flags = #^B0010 blbs r0, 100$ movw unavailable, mbxprocnam pushaq mbxprocnam pushaq unavailable calls #2, g^lib$scopy_dxdx 100$: rsb ; ; Dumps out mailbox details. ; ; Inputs: ; R11: Line number ; Outputs: ; R0: Status ; Trashes: ; R1 ; print_data_r11: .if df AXP .jsb_entry input = , output = .endc bsbw print_header_r1 ; Print out header for mailbox blbc r0, 99$ ; Quit on error movzbl #outbuf_len, outbuf movq mbxprocnam, r0 movzwl r0, r0 movl mbxwait, r2 ; Get wait flag movl waitchars[r2], r2 ; Get wait character $fao_s ctrstr = msgctrstr, - outlen = outbuf, - outbuf = outbuf, - p1 = r11, - p2 = mbxbuf, - p3 = mbxpid, - p4 = r0, - p5 = r1, - p6 = r2 ; Print wait string blbc r0, 99$ bsbw write_r1 ; Put record to output blbc r0, 99$ bsbw dump_message_r7 99$: rsb ; ; Prints out the header line if not already done. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; print_header_r1: .if df AXP .jsb_entry output = .endc movl #ss$_normal, r0 ; Assume all ok bbss #flg_v_headerdone, flags, 99$ ; Print out header only once bsbb dump_header_1_r1 blbc r0, 99$ bsbb dump_header_2_r1 99$: rsb ; dump_header_1_r1: .if df AXP .jsb_entry output = .endc movaq devnam, r0 movaq mbxlognam, r1 movzbl #outbuf_len, outbuf $fao_s ctrstr = hdrctrstr1, - outlen = outbuf, - outbuf = outbuf, - p1 = r0, - p2 = r1, - p3 = mbxrefcnt, - p4 = mbxopcnt blbc r0, 99$ ; ; Cancel CTRL/O on new device so the user can use it to discard all output for ; the current mailbox. ; bsbw write_cco_r1 ; Put record to output 99$: rsb ; dump_header_2_r1: .if df AXP .jsb_entry output = .endc movzbl #outbuf_len, outbuf $fao_s ctrstr = hdrctrstr2, - outlen = outbuf, - outbuf = outbuf, - p1 = mbxiniquo, - p2 = mbxbufquo, - p3 = mbxdevbufsiz, - p4 = mbxdevdepend blbc r0, 99$ bsbw write_r1 ; Write the buffer 99$: rsb ; ; Dumps out the mailbox contents in ascii and hex. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1,R2,R4,R5,R6,R7 ; dump_message_r7: .if df AXP .jsb_entry output = .endc clrl r7 ; Say at offset zero movq mbxbuf, r4 ; Get descriptor 1$: movzwl r4, r4 ; Get real length beql 99$ ; Nothing to do clrw outbuf ; Say we are at the start bsbw add_spaces_r2 ; Add a few spaces blbc r0, 99$ ; quit with error bsbw add_space_r2 ; Add a few spaces blbc r0, 99$ ; quit with error subl3 #1, bytes_per_line, r6 ; Set size of line clrq r0 ; Say zero value and digits 2$: cmpl r4, r6 ; Beyond buffer bleq 3$ ; No data use spaces incl r1 ; Say one more byte ashl #8, r0, r0 ; make space for new byte movb (r5)[r6], r0 ; Get the byte 3$: bitl alignment, r6 ; On a boundary bneq 4$ ; None to do this time bsbw add_val_r3 ; Add value to buffer blbc r0, 99$ ; quit with error bsbw add_space_r2 ; Add a space blbc r0, 99$ ; quit with error clrq r0 ; Say zero value and digits 4$: sobgeq r6, 2$ ; Next byte bsbb add_ascii_r6 ; Add ascii bit blbc r0, 99$ ; quit with error bsbw add_space_r2 ; Add a space blbc r0, 99$ ; quit with error movl r7, r0 ; Put offset long on end bsbb add_val_long_r3 ; Add offset long blbc r0, 99$ ; quit with error bsbw write_r1 ; Put record to output addl2 bytes_per_line, r7 ; Update offset blbs r0, 1$ ; Repeat the process 99$: rsb ; ; Adds the ascii portion of the dump message. ; ; Inputs: ; R4: Size of mailbox message ; R5: Address of mailbox message ; Outputs: ; R0: Status ; R4: Reduced size of message ; R5: Address of next portion of message ; Trashes: ; R6 ; add_ascii_r6: .if df AXP .jsb_entry input = , output = .endc subl3 #1, bytes_per_line, r6 ; Set size of line 1$: tstl r4 ; Anything left to process beql 2$ ; Nothing add a dot movzbl (r5)+, r0 ; get next byte decl r4 ; one less byte cmpb r0, #^A/ / ; See if in range blssu 2$ ; its a control char cmpb r0, #^A/~/ ; Too high? bgtru 2$ ; its out of range bsbw add_byte_r2 ; Add the byte brb 3$ 2$: movzbl #^A/./, r0 ; add a dot bsbw add_byte_r2 ; Add the byte 3$: blbc r0, 99$ ; Quit if error sobgeq r6, 1$ ; Next char 99$: rsb ; ; Adds a longword ; add_val_long_r3: .if df AXP .jsb_entry input = , output = .endc movl #offset_size, r1 ; Set size of offset bsbb add_val_r3 ; Add the value rsb ; ; Adds a byte, word or long as a string followed by a space ; ; Inputs: ; R0: Value to add ; R1: Number of valid bytes ; Outputs: ; R0: Status add_val_r3: .if df AXP .jsb_entry input = , output = .endc pushl r4 clrb -(sp) ; Set end of buffer movl base, r2 ; Get base movl radix[r2], r2 ; get address of table movzbl (r2)[r1], r1 ; Get size of data movl size, r4 ; Get current size movzbl (r2)[r4], r4 ; Get size of current data type cmpl r1, r4 ; Compare sizes bleq 0$ ; No use as specified movl r1, r4 ; Set to maximum of size 0$: subl3 r1, r4, r3 ; Get start of spacing 1$: cmpl r4, r3 ; Need to fake data bgtr 2$ movb #^A/ /, -(sp) ; Need space at this point brb 3$ 2$: clrl r1 ; Upper of quad zero ediv base, r0, r0, r1 ; Get digit movb hextab[r1], -(sp) ; Get hex digit cmpl base, #10 ; Base ten? bneq 3$ ; nope tstl r0 ; Quotient zero? bneq 3$ ; Nope some left to do movl r4, r3 ; Make rest of digits invalid 3$: sobgtr r4, 1$ ; Next digit 4$: movzbl (sp)+, r1 ; Get byte to add beql 5$ ; end of list movl r1, r0 ; Set byte to copy bsbb add_byte_r2 ; add the byte brb 4$ ; next byte 5$: popl r4 ; Restore reg rsb ; ; Add a couple of spaces to the output buffer. ; ; Inputs: ; None ; Outputs: ; R0: Status ; Trashes: ; add_spaces_r2: .if df AXP .jsb_entry output = .endc .if df AXP bsbb add_space_r2 bsbb add_space_r2 rsb .if_false pushab b^add_space_r2 ; Cheap loop .endc add_space_r2: .if df AXP .jsb_entry output = .endc movzbl #^A/ /, r0 ; Put space into reg bsbb add_byte_r2 ; Add to buffer 99$: rsb ; add_byte_r2: .if df AXP .jsb_entry input = , output = .endc movq outbuf, r1 ; Get output descriptor movzwl r1, r1 ; Get real length addl2 r1, r2 ; Get to end of string subl3 r1, line_length, r1 ; Get chars left in buffer bleq 100$ ; Too short movb r0, (r2)+ ; Add byte to end incw outbuf ; One more char in output movl #ss$_normal, r0 ; All is ok rsb 100$: movl #str$_tru, r0 ; Say truncated rsb ; ; locks the high IPL code and buffers into the working set ; ; Inputs: ; None ; Outputs: ; R0: Status ; Trashes: ; R1, R2 ; lock_code_and_data_r2: .if df AXP .jsb_entry output = .endc pushab w^lock_start pushab w^lock_end movl sp, r2 $lkwset_s - inadr = (r2) blbc r0, 99$ .if df AXP movab w^lock_linkage_start, (r2) movab w^lock_linkage_end, 4(r2) $lkwset_s - inadr = (r2) blbc r0, 99$ .endc movab mbxbuf_b, (r2) movab mbxbuf_b+mbxbuf_len-1, 4(r2) $lkwset_s - inadr = (r2) 99$: addl2 #8, sp rsb ; ; Gets the device name from the command line and assign a channel to it ; ; Inputs: ; None ; Outputs: ; R0: Status ; Trashes: ; R1 ; get_device_r1: .if df AXP .jsb_entry output = .endc pushaw wilddev ; Put length here pushaq wilddev pushaq mailbox_qual ; Get from P1 calls #3, g^cli$get_value ; Get from command line blbc r0, 99$ pushaw wilddev pushaw wilddev calls #2, g^str$upcase ; Uppercase the sting blbc r0, 99$ pushaq wilddev ; Strip users input calls #1, strip_device ; Strip : etc 99$: rsb ; ; Writes outbuf to the output file. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; write_r1: .if df AXP .jsb_entry output = .endc movw outbuf, outrab+rab$w_rsz moval mbox__errput, outrab+rab$l_ctx ; Set error putting message $put rab = outrab, - ; Put record to output err = rmserr ; Signal any errors rsb ; write_cco_r1: .if df AXP .jsb_entry output = .endc bisl2 #rab$m_cco, outrab+rab$l_rop ; Set cancel control o bsbb write_r1 ; Write the buffer bicl2 #rab$m_cco, outrab+rab$l_rop ; Clear cancel control o rsb ; ; Initializes the CLI with our command line and gets the values supplied by the ; user. ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; get_qualifiers_r1: .if df AXP .jsb_entry output = .endc pushaw get_input ; Input and pushaw get_input ; continuation routines pushab mbox_clitable ; command table address pushaq verb ; start of command calls #4, g^cli$dcl_parse ; parse command blbc r0, 100$ ; quit with error pushaw output ; put length here pushaq output ; put string here pushaq output_qual ; Getting /OUTPUT calls #3, g^cli$get_value ; Get value from CLI blbc r0, 99$ bsbb get_cli_quals_r1 ; Get other qualifiers blbc r0, 99$ bsbw get_group_r1 ; Get /group value 99$: rsb 100$: bbss #sts$v_inhib_msg, - r0, 99$ ; Already signaled so inhibit it rsb ; ; Gets the qualifiers that control the output of various information. ; ; Outputs: ; ; R0: Status ; get_cli_quals_r1: .if df AXP .jsb_entry output = .endc movaq rwmbx_qual, r0 movl #cfl_v_rwmbx, r1 bsbb get_qual_r1 blbc r0, 99$ movaq read_qual, r0 movl #cfl_v_read, r1 bsbb get_qual_r1 blbc r0, 99$ movaq write_qual, r0 movl #cfl_v_write, r1 bsbb get_qual_r1 blbc r0, 99$ movaq messages_qual, r0 movl #cfl_v_messages, r1 bsbb get_qual_r1 blbc r0, 99$ movaq headers_qual, r0 movl #cfl_v_headers, r1 bsbb get_qual_r1 blbc r0, 99$ movaq pending_qual, r0 movl #cfl_v_pending, r1 bsbb get_qual_r1 blbc r0, 99$ tstl cliflags ; If no quals then default bneq 1$ ; At least one specified decl cliflags ; Set to all flags set 1$: bicl2 clinegflags, cliflags ; Remove negated flags 99$: rsb ; ; Gets a single qualifier and sets a bit in either cliflags or clinegflags. ; get_qual_r1: .if df AXP .jsb_entry output = .endc movq r0, -(sp) calls #1, g^cli$present popl r1 cmpl #cli$_absent, r0 beql 1$ cmpl #cli$_negated, r0 bneq 2$ bbss r1, clinegflags, 99$ 1$: movl #ss$_normal, r0 rsb 2$: cmpl #cli$_present, r0 beql 3$ cmpl #cli$_defaulted, r0 bneq 99$ 3$: bbss r1, cliflags, 99$ movl #ss$_normal, r0 99$: rsb ; ; Get the value if any of the /GROUP qualifier ; get_group_r1: .if df AXP .jsb_entry output = .endc pushaq group_qual ; group qualifier calls #1, g^cli$present ; is it there? blbc r0, 0$ ; Yep so get out now bisl2 #<1@flg_v_group>, flags ; Say we have seen it pushaw groupstr pushl (sp) pushaq group_qual ; group qualifier calls #3, g^cli$get_value blbc r0, 2$ ; ; Try to translate it as an Id first. ; $asctoid_s - name = groupstr, - id = match_group blbc r0, 1$ movzwl match_group+2, match_group ; Shift group down 0$: brb 98$ 1$: pushl #2 ; Only a word pushal match_group pushaq groupstr calls #3, g^ots$cvt_to_l ; Convert octal number blbc r0, 100$ ; Report nice error brb 99$ ; Return any error ; ; Use the group of the current process ; 2$: $getjpiw_s - iosb = iosb, - itmlst = jpigrp blbc r0, 99$ movl iosb, r0 blbc r0, 99$ 98$: movl #ss$_normal, r0 99$: rsb 100$: pushl r0 pushaq groupstr pushl #1 pushal mbox__erroctal calls #4, g^lib$signal rsb ; get_modes_r1: .if df AXP .jsb_entry output = .endc bsbw get_size_r1 blbc r0, 99$ bsbb get_radix_r1 blbc r0, 99$ movl base, r0 ; Get base movl radix[r0], r0 ; Get table address movzbl offset_size(r0), r1 ; get size of offset value addl2 #3+1, r1 ; 1 space for offset + 3 at start subl3 r1, line_length, -(sp) ; Get size minus display end movl size, r1 ; Get size of single item mull2 r1, (sp) ; Multiple top of fraction pushl r1 ; Save it for a sec or two movzbl (r0)[r1], r1 ; Get digits size addl2 (sp)+, r1 ; Add them up incl r1 ; +1 divl3 r1, (sp)+, r1 ; get bytes per page divl2 size, r1 ; reduce to multiple of size mull3 size, r1, bytes_per_line; Scale back up to whole number movl #ss$_normal, r0 ; all is ok 99$: rsb ; get_radix_r1: .if df AXP .jsb_entry output = .endc movl #10, base ; Assume decimal pushaq decimal_qual ; Decimal qualifier calls #1, g^cli$present ; is it there? blbs r0, 99$ ; Yep so get out now movl #16, base ; Assume hexadecimal pushaq hexadecimal_qual ; Hexadecimal qualifier calls #1, g^cli$present ; is it there? blbs r0, 99$ ; Yep so get out now movl #8, base ; Assume octal pushaq octal_qual ; octal qualifier calls #1, g^cli$present ; is it there? blbs r0, 99$ ; Yep so get out now movl #16, base ; Default to hexadecimal movl #ss$_normal, r0 ; Say all is ok 99$: rsb ; get_size_r1: .if df AXP .jsb_entry output = .endc movl #4, size ; Assume longword movl #^B11, alignment ; Assume longword pushaq longword_qual ; Longword calls #1, g^cli$present ; Is it there blbs r0, 99$ ; Get out when got it movl #2, size ; Assume word movl #^B1, alignment ; Assume word pushaq word_qual ; Word calls #1, g^cli$present ; Is it there blbs r0, 99$ ; Get out when got it decl size ; Assume byte clrl alignment ; Assume byte pushaq byte_qual ; Byte calls #1, g^cli$present ; Is it there blbs r0, 99$ ; Get out when got it movl #4, size ; Default to longword movl #^B11, alignment ; Default to longword movl #ss$_normal, r0 ; all is ok 99$: rsb ; ; Opens and connects to the output file ; ; Inputs: ; Outputs: ; R0: Status ; Trashes: ; R1 ; open_output_r1: .if df AXP .jsb_entry output = .endc movq output, r0 ; get descriptor movw r0, outfab+fab$b_fns ; set size of filename movl r1, outfab+fab$l_fna ; set address of buffer moval mbox__errcre, outfab+fab$l_ctx ; Set error creating message $create fab = outfab, - ; open the file err = rmserr ; Signal any errors blbc r0, 99$ movzwl #default_line_length, - line_length ; Set default line length bitl #dev$m_trm!dev$m_mbx, - outfab+fab$l_dev ; Terminal or mailbox? beql 1$ ; Nope leave as default ; ; Can't use fab$w_bls as it always returns 80! ; bsbb get_terminal_width_r1 ; get terminal width blbc r0, 99$ 1$: moval mbox__errcon, outfab+fab$l_ctx ; Set error connecting message $connect - rab = outrab, - ; Connect the rab err = rmserr ; Signal any errors 99$: rsb ; get_terminal_width_r1: .if df AXP .jsb_entry output = .endc pushl outnam+nam$l_dev ; get address of device movzbl outnam+nam$b_dev, -(sp) ; Set size of device movl sp, r0 $getdviw_s - devnam = (r0), - ; Use device from NAM block itmlst = trmdvilst, - ; Get terminal or mailbox size iosb = iosb addl2 #8, sp ; Drop descriptor blbc r0, 99$ movl iosb, r0 ; get other status blbc r0, 99$ cmpw line_length, #outbuf_len ; Is it bigger than buffer bleq 99$ ; Its ok movzbl #outbuf_len, line_length ; Minimise 99$: rsb ; .if df AXP .call_entry max_args = 4, home_args=TRUE, label=get_mailbox_sizes .if_false .entry get_mailbox_sizes ^m<> .endc $cmkrnl_s - routin = get_mailbox_sizes_k, - arglst = (ap) ret ; .entry get_mailbox_sizes_k ^m chan = 4 iniquo = chan + 4 bufquo = iniquo + 4 nargs = bufquo/4 ; .if ndf AXP movl #ss$_accvio, r0 ; Assume access violation prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list .endc movl chan(ap), r0 ; get channel number bsbw get_mbx_ucb_r5 ; Get device ucb of mailbox blbc r0, 99$ ; Quit with error ; ; We don't care if bufquo is changed while we are reading it. Its for ; information only so we wont need to lock them down. ; movl #ss$_accvio, r0 ; Assume access violation .if df AXP movl iniquo(ap), r2 movl bufquo(ap), r3 .if_false assume eq bufquo ; Move in one go? movq iniquo(ap), r2 ; Get both addresses .endc probew #0, #4, (r2) ; Can we write the first beql 99$ ; Nope so quit movzwl ucb$w_iniquo(r5), (r2) ; Get initial size probew #0, #4, (r3) ; Can we write the first beql 99$ ; Nope so quit movzwl ucb$w_bufquo(r5), (r3) ; Get remaining space movl #ss$_normal, r0 ; All was ok 99$: ret ; .entry mbox_contents_k ^m ; chan = 4 ctx = chan + 4 pid = ctx + 4 msg = pid + 4 len = msg + 4 wait = len + 4 nargs = wait/4 ; .if ndf AXP movl #ss$_accvio, r0 ; Assume access violation prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list .endc movl msg(ap), r1 ; get address of descriptor movl ctx(ap), r6 ; Get address of context movl len(ap), r9 ; get address of length movl wait(ap), r11 ; Get address of wait flag bsbw probe_buffers_r11 ; probe buffer and retlen blbc r0, 99$ ; cant read it movl chan(ap), r0 ; get channel number bsbw get_mbx_ucb_r5 ; Get device ucb of mailbox blbc r0, 99$ ; Quit with error movl (r6), r4 ; Get context value incl (r6) ; Increment context movl pid(ap), r3 ; Get address of PID probew #0, #4, (r3) ; Write it? beql 99$ ; Quit with error bsbb find_message_r10 ; look up message blbc r0, 99$ ; Quit with error tstl r6 ; An IRP with this message? beql 1$ ; No IRP so not waiting movl #1, (r11) ; Say process waiting 1$: movl r1, r0 ; Convert pid from internal .if df AXP jsb g^exe$cvt_ipid_to_epid ; to external format .if_false jsb g^exe$ipid_to_epid ; to external format .endc movl r0, (r3) ; Save the PID movl #ss$_normal, r0 ; assume all is ok cmpw r7, r10 ; Buffer too small bgequ 3$ ; It was big enough movl #str$_tru, r0 ; Say truncated movw r7, r10 3$: movw r10, (r9) ; Save length 99$: ret ; ; ; Probes the buffer and its return length ; ; Inputs: ; r1: Address of buffer descriptor ; R6: Address of context longword ; R9: Address of return length word ; r11: Address of return flag longword ; Outputs: ; R0: Return status ; R6: Address of context longword (probed) ; R7: Length of message buffer ; R8: Address of message buffer (probed) ; R9: Address of return length word (probed) ; R11: Address of wait flag to return ; Trashes: ; R1,R2,R3 ; probe_buffers_r11: .if df AXP .jsb_entry input = , output = .endc movl #ss$_accvio, r0 ; assume failure probew #0, #2, (r9) ; Write it beql 99$ ; Quit with error probew #0, #4, (r6) ; Can we read it beql 99$ ; Quit with error probew #0, #4, (r11) ; Write the flag? beql 99$ ; Quit with error clrl (r11) ; Assume not waiting jsb g^exe$probew_dsc ; Probe the buffer blbc r0, 99$ ; Quit with error movzwl r1, r7 ; get real length movl r2, r8 ; copy address for later movl #ss$_normal, r0 ; say all is ok 99$: rsb ; ; Looks up the message in the mailbox ; ; Inputs: ; R5: Address of mailbox UCB ; R7: Size of user buffer ; R8: Address of user buffer ; Outputs: ; R0: Status ; R10: Size of mailbox message ; Trashes: ; R1,R2,R4 ; .enable lsb find_message_r10: .if df AXP .jsb_entry input = , output = .endc .if ndf AXP movl g^vms$gl_license_version, r10 ; Get VMS version .endc startlock lock lockname = MAILBOX, - ; Lock mailbox -; lockipl = #ipl$_mailbox, - ; This is the IPL preserve = NO ; Trash R0 moval ucb$l_fqfl(r5), r1 ; Get start of queue movl r1, r2 ; copy start of queue 1$: movl mbx_l_flink(r2), r2 ; Get forward pointer assume mbx_l_flink eq 0 ; Can we compare to top? cmpl r2, r1 ; Back at start? beql 4$ ; We are done sobgeq r4, 1$ ; Next message pushr #^m ; save registers over move .if ndf AXP cmpl r10, #^X00050004; 5.4? blequ 2$ ; Yep use old format .endc pushl mbx5_l_pid(r2) ; Copy pid of message to stack movzwl mbx5_w_msgsiz(r2), r10 ; get size of message movl mbx5_l_irpadr(r2), r6 ; Get address of IRP movc5 r10, mbx5_r_msg(r2), #0, - r7, (r8) ; Copy message to buffer .if ndf AXP brb 3$ 2$: pushl mbx4_l_pid(r2) ; Copy pid of message to stack movzwl mbx4_w_msgsiz(r2), r10 ; get size of message movl mbx4_l_irpadr(r2), r6 ; Get address of IRP movc5 r10, mbx4_r_msg(r2), #0, - r7, (r8) ; Copy message to buffer .endc 3$: popr #^m ; Restore registers 4$: unlock lockname = MAILBOX, - ; Unlock mailbox newipl = #0, - ; Set IPL to zero preserve = NO ; Trash R0 endlock movzwl #ss$_endoffile, r0 ; Say no more messages tstl r1 ; PID or system address? blss 99$ ; Quit with error movl #ss$_normal, r0 ; Say all was ok 99$: rsb .disable lsb ; ; Gets the ucb of a mailbox from its channel number ; ; Inputs: ; R0: Channel number ; Outputs: ; R0: Status ; R1: CCB ; R5: UCB ; Trashes: ; R2,R3 ; get_mbx_ucb_r5: .if df AXP .jsb_entry input = , output = .endc jsb g^ioc$verifychan ; check out channel blbc r0, 99$ ; Quit with error ; ; R1 now contains CCB address. ; movl ccb$l_ucb(r1), r5 ; Get UCB address movzbl #ss$_devnotmbx, r0 ; Assume bad channel cmpb ucb$b_devclass(r5), #dc$_mailbox; This a mailbox? bneq 99$ ; Quit with error cmpb ucb$b_devtype(r5), #dt$_mbx ; This a mailbox? bneq 99$ ; Quit with error movl #ss$_normal, r0 ; All is ok 99$: rsb ; ; Gets the logical name associated with the mailbox (backpointer logical) ; .entry get_logical_k ^m chan = 4 log = chan + 4 len = log + 4 nargs = len/4 ; movl #ss$_accvio, r0 ; Assume access violation .if ndf AXP prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list .endc movl len(ap), r6 ; Get address of return len probew #0, #2, (r6) ; Write it? beql 99$ ; Quit with error movl chan(ap), r0 ; get channel number bsbb get_mbx_ucb_r5 ; Get device ucb of mailbox blbc r0, 99$ ; Quit with error movl log(ap), r1 ; get address of logical name jsb g^exe$probew_dsc ; Probe the buffer blbc r0, 99$ ; Quit with error movq r1, r2 ; Copy to safe place clrw (r6) ; Default to no string movl g^ctl$gl_pcb, r4 ; Get current PCB address jsb g^lnm$lockr ; Lock logical name table movl ucb$l_logadr(r5), r0 ; Get address of logical name beql 98$ ; nothing there .if df AXP assume eq lnmb$t_name moval lnmb$l_namelen(r0), r1 ; Get address of string movl (r1)+, r0 .if_false movab lnmb$t_name(r0), r1 ; Get address of string movzbl (r1)+, r0 ; Get size of string .endc cmpw r2, r0 ; Users buffer big enough? bgequ 1$ ; Branch if big enough movl r2, r0 ; Reduce to maximum 1$: movzbw r0, (r6) ; Save length movc5 r0, (r1), #^A/ /, r2, (r3) ; Copy string to buffer 98$: movl g^ctl$gl_pcb, r4 ; Get current PCB address jsb g^lnm$unlock ; Lock logical name table movl #ss$_normal, r0 ; say all is ok 99$: ret ; .entry strip_device ^m ; dev = 4 ; movl dev(ap), r6 ; Get address of descriptor movq (r6), r7 ; Get descriptor movzwl r7, r7 ; Get real size beql 98$ ; Nothing to do 1$: cmpb #^A/_/, (r8) ; Underscore on front? bneq 2$ ; Nope decl r7 ; One less character beql 97$ ; That's it movc3 r7, 1(r8), (r8) ; Copy dropping data 2$: cmpb -1(r8)[r7], #^A/:/ ; Colon on end bneq 97$ ; Reset size and continue decl r7 ; One less chars 97$: movw r7, (r6) ; Set new length 98$: movl #ss$_normal, r0 ; all is ok ret ; .entry get_input ^m<> ; Input routine for CLI$DCL_PARSE line = 4 ; put input here prompt = 8 ; use this prompt length = 12 ; put length of input here pushal frcpmt ; used to force prompting after first pushl length(ap) ; put length here .if df AXP pushl prompt(ap) pushl line(ap) .if_false assume eq prompt ; can we copy both in one movq line(ap), -(sp) ; copy line and prompt .endc calls #4, g^lib$get_foreign ; get command line ret ; ; This routine signals rms errors. ; .entry rmserr ^m ; rmsblock = 4 savedr0 = rmsblock + 4 savedr1 = savedr0 + 4 savedpc = savedr1 + 4 savedpsl = savedpc + 4 ; assume fab$l_sts eq rab$l_sts assume fab$l_stv eq rab$l_stv assume fab$l_ctx eq rab$l_ctx assume fab$b_bid eq rab$b_bid ; movl rmsblock(ap), r0 pushl fab$l_stv(r0) ; Save other status value pushl fab$l_sts(r0) ; Save status value ; ; Assume this is a RAB and if so move to the FAB ; movl r0, r1 ; Assume this is the fab cmpb rab$b_bid(r0), #rab$c_bid ; this a rab? bneq 1$ ; Its a FAB so no need to switch movl rab$l_fab(r0), r1 ; Get address of the fab 1$: movl fab$l_nam(r1), r2 ; Skip to NAM block ; ; Try and use resultant name first then expanded then finally fab inputs. ; pushl nam$l_rsa(r2) ; Save address of string movzbl nam$b_rsl(r2), -(sp) ; Set length of string bneq 2$ ; We got one so continue movl nam$l_esa(r2), 4(sp) ; Save address of other string movzbl nam$b_esl(r2), (sp) ; Save new length of string bneq 2$ ; We got one so continue movl fab$l_fna(r1), 4(sp) ; Save address of other string movzbl fab$b_fns(r1), (sp) ; Save new length of string 2$: pushl #2 ; Two arguments for error pushl fab$l_ctx(r0) ; Save primary error calls #6, g^lib$signal ; Signal the error ret ; ; This routine gets the read and write attention lists for a mailbox. ; .entry get_attn_list_k ^m ; chan = 4 ; mailbox channel list = chan + 4 ; list required 0 = read, 1 = write ctx = list + 4 ; Context for call loops mode = ctx + 4 ; access mode of AST pid = mode + 4 ; Process id of process astadr = pid + 4 ; AST address astprm = astadr + 4 ; AST parameter nargs = astprm/4 ; Number of arguments ; .enable lsb movl #ss$_accvio, r0 ; Assume access violation .if ndf AXP prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list .endc movl ctx(ap), r1 ; Get address of context .if df AXP movl mode(ap), r7 ; Get access mode movl pid(ap), r8 ; Get access pid .if_false assume eq pid ; Fields next to each other movq mode(ap), r7 ; Get access mode and pid .endc .if df AXP movl astadr(ap), r9 ; Get astadr address movl astprm(ap), r10 ; Get astprm address .if_false assume eq astprm ; Fields next to each other movq astadr(ap), r9 ; Get astadr and astprm address .endc movl chan(ap), r0 ; get channel number bsbb get_args_r10 ; Get the arguments blbc r0, 99$ moval ucb$l_astqbl(r5), r2 ; Assume write ast queue blbc list(ap), 1$ ; Just test low bit moval ucb$l_astqfl(r5), r2 ; Use read queue instead 1$: startlock lock lockname = MAILBOX, - ; Lock mailbox -; lockipl = #ipl$_mailbox, - ; This is the IPL preserve = NO ; Trash R0 movzwl #ss$_endoffile, r0 ; Assume we fail 3$: movl (r2), r2 ; Get forward link beql 98$ ; Done sobgeq r6, 3$ ; Do next .if df AXP movl acb$l_ast(r2), r3 ; get astadr and astprm movl acb$l_astprm(r2), r4 ; get astadr and astprm .if_false assume eq acb$l_astprm movq acb$l_ast(r2), r3 ; get astadr and astprm .endc extzv #acb$v_mode, #acb$s_mode, - acb$l_kast+8(r2), r1 ; Get access mode movl acb$l_kast+12(r2), r2 ; get pid movl #ss$_normal, r0 ; All is ok 98$: unlock lockname = MAILBOX, - ; Unlock mailbox newipl = #0, - ; Set IPL to zero preserve = YES ; Save R0 endlock blbc r0, 99$ ; Quit with error movl r1, (r7) ; Save mode movl r3, (r9) ; Save astadr movl r4, (r10) ; Save astprm movl r2, r0 ; Get into reg .if df AXP jsb g^exe$cvt_ipid_to_epid ; to external format .if_false jsb g^exe$ipid_to_epid ; to external format .endc movl r0, (r8) ; Save the PID movl #ss$_normal, r0 ; All is ok 99$: ret .disable lsb ; ; Gets the arguments and context etc from arguments list ; get_args_r10: .if df AXP .jsb_entry input = , output= .endc probew #0, #4, (r1) ; Write it? beql 100$ ; Exit with error movl (r1), r6 ; Get context value incl (r1) ; Update for next call probew #0, #4, (r7) ; Write the mode? beql 100$ ; Quit with error probew #0, #4, (r8) ; Write the pid? beql 100$ ; quit with error probew #0, #4, (r9) ; Write the mode? beql 100$ ; quit with error probew #0, #4, (r10) ; Write the mode? beql 100$ ; Quit with error bsbw get_mbx_ucb_r5 ; Get device ucb of mailbox 99$: rsb 100$: movl #ss$_accvio, r0 ; Assume access violation rsb ; ; ; This routine gets the IO lists for a mailbox for readvblk. ; .entry get_read_list_k ^m ; chan = 4 ; mailbox channel ctx = chan + 4 ; Context for call loops mode = ctx + 4 ; access mode of AST pid = mode + 4 ; Process id of process astadr = pid + 4 ; AST address astprm = astadr + 4 ; AST parameter nargs = astprm/4 ; Number of arguments ; .enable lsb movl #ss$_accvio, r0 ; Assume access violation .if ndf AXP prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list .endc movl ctx(ap), r1 ; Get address of context .if df AXP movl mode(ap), r7 ; Get access mode movl pid(ap), r8 ; Get pid .if_false assume eq pid ; Fields next to each other movq mode(ap), r7 ; Get access mode and pid .endc .if df AXP movl astadr(ap), r9 ; Get astadr address movl astprm(ap), r10 ; Get astprm address .if_false assume eq astprm ; Fields next to each other movq astadr(ap), r9 ; Get astadr and astprm address .endc movl chan(ap), r0 ; get channel number bsbw get_read_args_r10 ; Get the arguments blbc r0, 99$ .if ndf AXP movl g^vms$gl_license_version, r11 ; Get VMS version .endc startlock lock lockname = MAILBOX, - ; Lock mailbox -; lockipl = #ipl$_mailbox, - ; This is the IPL preserve = NO ; Trash R0 movzwl #ss$_endoffile, r0 ; Assume we fail .if ndf AXP cmpl r11, #^X00050004; 5.4? blequ 1$ ; Yep use old format .endc movaq ucb$l_mb_readqfl(r5), r3 ; New head for IO queue .if ndf AXP brb 2$ ; Get in line 1$: bbc #ucb$v_bsy, ucb$l_sts(r5), 98$ ; I/O in progress? movl ucb$l_irp(r5), r2 ; Get current IRP decl r6 ; First context? blss 4$ ; Give current IO packet first movaq ucb$l_ioqfl(r5), r3 ; Get IRP list head .endc 2$: movl r3, r2 ; Copy header assume irp$l_ioqfl eq 0 3$: movl (r2), r2 ; Get forward link cmpl r2, r3 ; At head again? beql 98$ ; Done sobgeq r6, 3$ ; Do next 4$: .if df AXP movl irp$l_ast(r2), r3 ; get astadr and astprm movl irp$l_astprm(r2), r4 ; get astadr and astprm .if_false assume eq irp$l_astprm ; Move both field at once? movq irp$l_ast(r2), r3 ; get astadr and astprm .endc extzv #acb$v_mode, #acb$s_mode, - irp$b_rmod(r2), r1 ; Get access mode movl irp$l_pid(r2), r2 ; get pid movl #ss$_normal, r0 ; All is ok 98$: unlock lockname = MAILBOX, - ; Unlock mailbox newipl = #0, - ; Set IPL to zero preserve = YES ; Save R0 endlock blbc r0, 99$ ; Quit with error movl r1, (r7) ; Save mode movl r3, (r9) ; Save astadr movl r4, (r10) ; Save astprm movl r2, r0 ; Get into reg .if df AXP jsb g^exe$cvt_ipid_to_epid ; to external format .if_false jsb g^exe$ipid_to_epid ; to external format .endc movl r0, (r8) ; Save the PID movl #ss$_normal, r0 ; All is ok 99$: ret .disable lsb ; ; Gets the arguments and context etc from arguments list ; get_read_args_r10: .if df AXP .jsb_entry input = , output= .endc probew #0, #4, (r1) ; Write it? beql 100$ ; Exit with error movl (r1), r6 ; Get context value incl (r1) ; Update for next call probew #0, #4, (r7) ; Write the mode? beql 100$ ; Quit with error probew #0, #4, (r8) ; Write the pid? beql 100$ ; quit with error probew #0, #4, (r9) ; Write the mode? beql 100$ ; quit with error probew #0, #4, (r10) ; Write the mode? beql 100$ ; Quit with error bsbw get_mbx_ucb_r5 ; Get device ucb of mailbox 99$: rsb 100$: movl #ss$_accvio, r0 ; Assume access violation rsb ; ; ; This routine gets the processes waiting for free space in this mailbox. ; .entry get_rwmbx_k ^m ; chan = 4 ; mailbox channel ctx = chan + 4 ; Context for call loops pid = ctx + 4 ; Process id of process nargs = pid/4 ; Number of arguments ; .if ndf AXP movl #ss$_accvio, r0 ; Assume access violation prober #0, #*4, (ap) ; Probe argument list beql 99$ ; Can't read argument list movl ctx(ap), r7 ; Get context arg probew #0, #4, (r7) ; Can we write it beql 99$ ; Quit with error movl pid(ap), r8 ; Get address of pid probew #0, #4, (r8) ; Can we write it beql 99$ ; Quit with error movl (r7), r6 ; Get offset into PCBVEC movl chan(ap), r0 ; get channel number bsbw get_mbx_ucb_r5 ; Get device ucb of mailbox blbc r0, 99$ ; Quit with error bsbb lookup_rwmbx_r6 ; Look up a process blbc r0, 99$ ; Quit with error movl r6, (r7) ; Save updated context movl r1, (r8) ; Save away PID 99$: ret .if_false movzwl #ss$_endoffile, r0 ret .endc ; ; Looks up processes that are in RWMBX for space in the specified mailbox. ; ; Inputs: ; R5: Address of mailbox UCB ; R6: PIX of last scanned process ; Outputs: ; R0: Status ; R1: PID of matching process ; Trashes: ; R2,R3,R4 ; .enable lsb lookup_rwmbx_r6: .if df AXP .jsb_entry .endc .if ndf AXP startlock lock lockname = SCHED, - ; Lock sched database -; lockipl = #ipl$_sched, - ; This is the IPL preserve = NO ; Trash R0 subl3 r6, g^sch$gl_maxpix, r2 ; Vectors left to process blss 97$ ; Nothing left to process movl g^sch$gl_pcbvec, r3 ; Get address of vector moval (r3)[r6], r3 ; Get address to start from 1$: incl r6 ; Keep track of PIX movl (r3)+, r4 ; Get PCB address cmpw pcb$w_state(r4), #sch$c_mwait ; Misc or mutex wait state? bneq 2$ ; Not do the next cmpl pcb$l_efwm(r4), #rsn$_mailbox ; Waiting for mailbox space? bneq 2$ ; Nope do the next one bbc #pcb$v_phdres, pcb$l_sts(r4), 2$; Can't get to header movl pcb$l_phd(r4), r0 ; Get phd address cmpl phd$l_r5(r0), r5 ; This the right UCB bneq 2$ ; Nope, wrong mailbox movl pcb$l_epid(r4), r1 ; Get PID for output movl #ss$_normal, r0 ; All is ok brb 98$ ; Get out now 2$: sobgeq r2, 1$ ; Next one 97$: movzwl #ss$_endoffile, r0 ; We have failed to find one 98$: unlock lockname = SCHED, - ; Unlock sched database newipl = #0, - ; Set IPL to zero preserve = YES ; Save R0 endlock .endc rsb .disable lsb ; ; Declare the final labels for the locked PSECTS ; .psect mbox_code_locked rd exe pic shr lock_end: .if df AXP .jsb_entry .psect mbox_linkage_locked noexe nowrt lock_linkage_end: .endc .end mbox