{ +---------------------------------------------------------------------------+ | | | [WHO]DISPLAY.PAS Output Formatting Routines | | Scott Bailey, Xerox Corporation Created November 2, 1990 | | | | Modification History | | V1.1-004 03/07/91 RSB Add support for /SYMBOL and /NOOUTPUT | | V1.1-003 01/23/91 RSB Add support for /FULL displays | | V1.0-002 11/09/90 RSB Add support for access masks, prime days | | V1.0-001 11/07/90 RSB Fix bug in parsing filter masks | | V1.0-000 11/02/90 RSB Original version | | | +---------------------------------------------------------------------------+ } [ident('V1.1-004'),environment('display'), inherit('sys$library:starlet', { System service definitions } 'sys$library:pascal$lib_routines', { Run-time library definitions } 'access', { Access utility routines } 'whodefs', { Common definitions } 'uafdef', { UAF record definitions } 'uaf_masks', { UAF bitmask definitions } 'masks')] { Bitmask utilities } module display; [hidden] const maxarg = 100; { Maximum arguments for $FAO } maxfix = 50; { Maximum integer $FAO args } [hidden] type extra_work = ( { What special routines? } quota, { Quota file lookup } nodes, { Node access lookup } privs, { Authorized privileges } defprivs, { Default privileges } flags, { Login flags } days, { Primary days } netacc, { Network access } batacc, { Batch access } locacc, { Local access } diaacc, { Dialup access } remacc); { Remote access } fixup_entry = record { Information for integer fix } source : unsigned; { Address of data source } target : integer; { Index of destination } end; {record fixup_entry} [hidden] var { Data storage for $FAO input. Anything which might be displayed needs to have a fixed location so that the $FAO argument list can be maintained. All information will get put into these variables before output formatting is attempted. } dec_uaf : [volatile] uaf_record_type; { Output buffer for DEC info } xerox_uaf : [volatile] xrx_uaf_type; { Output buffer for local info } node_list, { List of authorized nodes } privileges, { List of authorized privs } defprivileges, { List of default privs } login_flags : [volatile] varying [128] of char; { List of login flags } disk_quota : [volatile] integer; { Quota on default disk } disk_usage : [volatile] integer; { Usage on default disk } prime_days : [volatile] varying [30] of char; { List of prime days } network_access, { Network access hours } batch_access, { Batch access hours } local_access, { Local access hours } dialup_access, { Dialup access hours } remote_access : [volatile] varying [9] of char; { Remote access hours } { In the event local information has been mangled, the following will be substituted in its place. } default_xerox_uaf : [readonly] xrx_uaf_type { Default for missing local } value ( xrx$c_size, { Data area length } xrx$c_version, { Data area version } '(n/a) ', { Class } '(n/a) ', { Cost center } '(n/a) ', { Phone } '(n/a) ', { Mail stop } (0,0), { Site-specific privileges } -1, { Default disk quota } '(n/a) ', { Employee identification } (5,'(n/a) ')); { Manager name } { Masks used for selective filtering of privilege/flag output } maskp, { Authorized privileges } maskd, { Default privileges } maskf : mask_type; { Login flags } { The following are the fixup and argument lists which point to the above data so that $FAO can find it to prepare the output buffer. } work : set of extra_work; { Flags for special fixups } fixes : integer; { Number of integer fixups } fixup : array [1..maxfix] of fixup_entry; { Integer fixup list } faoarg : array [1..maxarg] of [unsafe] unsigned; { $FAO argument list } faoctl : varying [256] of char; { $FAO control string } header : array [1..2] of varying [256] of char; { Output header lines } use_header : boolean; { Should we use a header? } full_flag : boolean; { /FULL specified? } { Parse the /SHOW qualifier on the command line and use that to generate the information which will be used later for output formatting. } procedure generate_format; var have_arg, { Status from retrieval call } stat : integer; { Return status from calls } field : varying [32] of char; { Name of requested field } fsize : varying [4] of char; { Width of field from CLI } width : integer; { Requested width of field } break : integer; { Position of : or = in spec } i, j : integer; { Scratch for UIC format } textmask : varying [512] of char; { ASCII mask equivalence } currfield, { Current field to work on } argcnt : integer; { Next argument to fill } { This procedure extracts a list of values for a given CLI entity and returns them as a single string of comma-separated values. } procedure scan_values( target : packed array [l0..u0:integer] of char; { Entity to scan } var elements : varying [u1] of char); { Final list of values } var buff : varying [64] of char; { Working buffer } stat : integer; { Intermediate status } begin {procedure scan_values} elements := ''; { Clear output buffer } stat := cli$get_value(target,buff.body,buff.length); { Get 1st value } while stat <> cli$_absent do begin elements := elements + buff + ','; { Add to output buffer } stat := cli$get_value(target,buff.body,buff.length); { Next value } end; {while} if length(elements) > 0 then elements.length := elements.length - 1; { Drop trailing comma } end; {procedure scan_values} { A quickie subfunction to determine if the current field matches a keyword. Think of this as a "macro"... It also has important side-effects to get the length of the field. } function equal( keyword : packed array [l1..u1:integer] of char ) : boolean; var match : boolean; { Does arg match keyword? } begin {function equal} match := (index(keyword,field) = 1); if match then { Match! Get the length } cli$get_value('SHOW.'+keyword,fsize.body,fsize.length); equal := match; { Pass back final status } end; {function equal} { A quickie subprocedure to stick the given argument into the $FAO list } procedure add(arg : [unsafe] unsigned); begin {procedure add} argcnt := argcnt + 1; faoarg[argcnt] := arg; end; {procedure add} { A quickie subprocedure to set up fixups, etc. for integer $FAO arguments } procedure fix(arg : [unsafe] unsigned); begin {procedure fix} argcnt := argcnt + 1; fixes := fixes + 1; with fixup[fixes] do begin source := arg; target := argcnt; end; {with} end; {procedure fix} { A quickie subprocedure to append the required output specifications as needed. Don't bother to do anything if /FULL was used; it won't look at this stuff. } procedure build( spec : packed array [l1..u1:integer] of char; hdr : packed array [l2..u2:integer] of char); var p : varying [4] of char; lead : integer; begin {procedure build} if not full_flag then begin { If this is one-line mode } readv(fsize,lead); { Convert that to integer } lead := (lead - length(hdr)) div 2; { Spaces to center header } faoctl := faoctl + fsize + spec + ' !'; { Define data field } if lead < 1 then header[1] := header[1] + fsize + '<' + hdr + '!> !' { Define name } else begin writev(p,lead:1); { Leading blanks } header[1] := header[1] + fsize + ' !'; end; {else} header[2] := header[2] + fsize + '*- !';{ Define header underscore } end; {then} end; {procedure build} begin {procedure generate_format} { Initialize all fixup lists and control buffers } work := []; { No special fixups } fixes := 0; { No integer fixups } argcnt := 0; { No $FAO arguments } faoctl := '!'; { Clear control string } header[1] := '!'; { Clear header strings } header[2] := '!'; use_header := false; maskp[1] := -1; maskp[2] := -1; { Clear filter masks } maskd[1] := -1; maskd[2] := -1; maskf[1] := -1; { Figure out what the user wants to look at. There are two mutually exclusive possibilities -- /FULL triggers a full-screen display (not customizable) and /SHOW generates a one-line display tailored by the qualifier. } full_flag := (cli$present('FULL') = cli$_present); if not full_flag then { Scan all entries in the /SHOW= value list, in order. For each, append $FAO control information to our working lists. This will allow us to customize the program output while keeping the vast majority of the formatting work down to a one-time hit in this routine. We save this before further processing because the scan context this uses gets trashed by explicit width readings done below. } scan_values('SHOW',textmask) else { /FULL is present; build up a dummy "/SHOW" list -- this will cause the stuff below to build the correct $FAO argument lists. (We will ignore the generated control string because we already know exactly what the output will look like.) Note that changing the format of the full display will require reviewing the ordering of this dummy list. } textmask := 'USERNAME,OWNER,' + 'CLASS,MANAGER,' + 'PHONE,MAILSTOP,' + 'ACCOUNT,UIC,IDENTIFIER,' + 'DEFCLI,CLITABLES,' + 'DIRECTORY,' + 'LGICMD,' + 'FLAGS,' + 'PRIMEDAYS,' + 'NETWORK,BATCH,LOCAL,DIALUP,REMOTE,' + 'EXPIRATION,PWDMINIMUM,LOGFAILS,' + 'PWDLIFETIME,PWDDATE,' + 'LASTLOGIN,LASTNONINT,' + 'MAXJOBS,FILLM,BYTLM,' + 'MAXDETACH,BIOLM,JTQUOTA,' + 'PRCLM,DIOLM,WSDEFAULT,' + 'PRIORITY,ASTLM,WSQUOTA,' + 'QUEPRI,TQELM,WSEXTENT,' + 'ENQLM,PGFLQUOTA,' + 'PRIVILEGES,' + 'DEFPRIVILEGES'; { FAOARG contains the actual $FAO argument list which the output routine will use. FAOCTL is the corresponding control string telling $FAO how to use the list. However, $FAO expects that small (longword or less) integer arguments will be passed directly in the argument list. Therefore, FIXUP contains a list of these arguments which must be moved from the UAF record areas into the list before $FAO can be called. Finally, there are a few display fields which require extended conversion work, such as interpretation of a bitmask to form an ASCII string. The results of these conversions will be to known locations handled above, but a special mask WORK is used to indicate which routines must be called before doing fixups and the final $FAO call. The output header lines are also generated in parallel with the $FAO stuff. Note that a significant amount of error trapping is assumed to have been enforced by DCL and the .CLD specification of this command. (In particular, that only valid fields are specified, that lengths are always provided for each field, that all lengths will be integers, and that ambiguous abbreviations will not be used...) } currfield := 0; have_arg := rsb$element(field,currfield,',',textmask); { 1st field } while have_arg <> str$_noelem do begin { Throw away the length if it was specified. (We'll get it later) } break := index(field,'='); { Find separator between } if break = 0 then begin { field name and } break := index(field,':'); { width specification } if break = 0 then break := length(field) + 1; { Fix 'no-value' cases } end; {then} field.length := break - 1; { Discard length for now } { Figure out what was specified. This is made slightly more interesting because abbreviations are allowed. In an attempt to improve efficiency, check for the common stuff first (to cut down on repeated EQUAL tests). } if equal('HEADER') then use_header := true { Special case, not a field } else if equal('USERNAME') then begin add(uaf$s_username); add(iaddress(dec_uaf.username)); build('AD','Username'); end else if equal('OWNER') then begin add(iaddress(dec_uaf.owner)); build('AC','Owner Name'); end else if equal('UIC') then begin fix(iaddress(dec_uaf.uic.group)); fix(iaddress(dec_uaf.uic.member)); { The default UIC format does not provide even zero-filled numbers, which are very useful for sorting, so we'll do a home-brew format. This one gets built the hard way without using the build routine. } i := faoctl.length; { Remember current length } build('dummy','UIC'); { Build headers correctly } faoctl.length := i; { But don't add to control } readv(fsize,width); { Get width in binary } i := min((width - 3) div 2,6); { Space for group } j := min((width - 3) - i,6); { Space for member } writev(field,fsize,'<[!',i:1,'OW,!',j:1,'OW]!> !'); { UIC format } faoctl := faoctl + field; { Update control string } end else if equal('DIRECTORY') then begin add(iaddress(dec_uaf.defdev)); add(iaddress(dec_uaf.defdir)); build('','Default Directory'); end else if equal('ACCOUNT') then begin add(uaf$s_account); add(iaddress(dec_uaf.account)); build('AD','Account'); end else if equal('PHONE') then begin add(xrx$s_phone); add(iaddress(xerox_uaf.phone)); build('AD','Phone No.'); end else if equal('MAILSTOP') then begin add(xrx$s_mail_stop); add(iaddress(xerox_uaf.mail_stop)); build('AD','Mail Stop'); end else if equal('EMPLOYEE') then begin add(xrx$s_empid); add(iaddress(xerox_uaf.empid)); build('AD','Emp. No.'); end else if equal('MANAGER') then begin add(iaddress(xerox_uaf.manager)); build('AC','Manager'); end else if equal('CLASS') then begin add(xrx$s_class); add(iaddress(xerox_uaf.class)); build('AD','Class'); end else if equal('COSTCENTER') then begin add(xrx$s_cost_center); add(iaddress(xerox_uaf.cost_center)); build('AD','Cost Center'); end else if equal('PRIORITY') then begin fix(iaddress(dec_uaf.pri)); build('UB','Priority'); end else if equal('LGICMD') then begin add(iaddress(dec_uaf.lgicmd)); build('AC','Login Procedure'); end else if equal('DEFCLI') then begin add(iaddress(dec_uaf.defcli)); build('AC','CLI'); end else if equal('CLITABLES') then begin add(iaddress(dec_uaf.clitables)); build('AC','CLI Table'); end else if equal('LOGFAILS') then begin fix(iaddress(dec_uaf.logfails)); build('UW','Login Fails'); end else if equal('PWDMINIMUM') then begin fix(iaddress(dec_uaf.pwd_length)); build('UB','Pwd Length'); end else if equal('EXPIRATION') then begin add(iaddress(dec_uaf.expiration)); build('%D','Account Expiration'); end else if equal('PWDLIFETIME') then begin add(iaddress(dec_uaf.pwd_lifetime)); build('%D','Pwd Life'); end else if equal('PWDDATE') then begin add(iaddress(dec_uaf.pwd_date)); build('%D','Pwd Changed'); end else if equal('PWD2DATE') then begin add(iaddress(dec_uaf.pwd2_date)); build('%D','Pwd 2 Changed'); end else if equal('LASTLOGIN') then begin add(iaddress(dec_uaf.lastlogin_i)); build('%D','Last Interactive'); end else if equal('LASTNONINT') then begin add(iaddress(dec_uaf.lastlogin_n)); build('%D','Last non-Interactive'); end else if equal('QUEPRI') then begin fix(iaddress(dec_uaf.quepri)); build('UB','Quepri'); end else if equal('MAXJOBS') then begin fix(iaddress(dec_uaf.maxjobs)); build('UW','Maxjobs'); end else if equal('MAXDETACH') then begin fix(iaddress(dec_uaf.maxdetach)); build('UW','Maxdetach'); end else if equal('PRCLM') then begin fix(iaddress(dec_uaf.prccnt)); build('UW','Prclm'); end else if equal('BIOLM') then begin fix(iaddress(dec_uaf.biolm)); build('UW','BIOlm'); end else if equal('DIOLM') then begin fix(iaddress(dec_uaf.diolm)); build('UW','DIOlm'); end else if equal('TQELM') then begin fix(iaddress(dec_uaf.tqcnt)); build('UW','TQElm'); end else if equal('ASTLM') then begin fix(iaddress(dec_uaf.astlm)); build('UW','ASTlm'); end else if equal('ENQLM') then begin fix(iaddress(dec_uaf.enqlm)); build('UW','ENQlm'); end else if equal('FILLM') then begin fix(iaddress(dec_uaf.fillm)); build('UW','Fillm'); end else if equal('WSQUOTA') then begin fix(iaddress(dec_uaf.wsquota)); build('UL','WSquota'); end else if equal('WSDEFAULT') then begin fix(iaddress(dec_uaf.dfwscnt)); build('UL','WSdefault'); end else if equal('WSEXTENT') then begin fix(iaddress(dec_uaf.wsextent)); build('UL','WSextent'); end else if equal('PGFLQUOTA') then begin fix(iaddress(dec_uaf.pgflquota)); build('UL','Pgflquota'); end else if equal('BYTLM') then begin fix(iaddress(dec_uaf.bytlm)); build('UL','Bytlm'); end else if equal('PBYTLM') then begin fix(iaddress(dec_uaf.pbytlm)); build('UL','PBytlm'); end else if equal('JTQUOTA') then begin fix(iaddress(dec_uaf.jtquota)); build('UL','JTquota'); end else if equal('PRIVILEGES') then begin work := work + [privs]; { Mask needs translation } fix(iaddress(privileges.length)); add(iaddress(privileges.body)); build('AD','Privileges'); end else if equal('DEFPRIVILEGES') then begin work := work + [defprivs]; { Mask needs translation } fix(iaddress(defprivileges.length)); add(iaddress(defprivileges.body)); build('AD','Def. Privs.'); end else if equal('FLAGS') then begin work := work + [flags]; { Mask needs translation } fix(iaddress(login_flags.length)); add(iaddress(login_flags.body)); build('AD','Flags'); end else if equal('NODES') then begin work := work + [nodes]; { Special fixup for nodes } fix(iaddress(node_list.length)); add(iaddress(node_list.body)); build('AD','Nodes'); end else if equal('IDENTIFIER') then begin fix(iaddress(dec_uaf.uic)); build('','Identifier'); end else if equal('QUOTA') then begin work := work + [quota]; { Special fixup for disk quota } fix(iaddress(disk_quota)); build('UL','Quota'); end else if equal('USAGE') then begin work := work + [quota]; { Special fixup required } fix(iaddress(disk_usage)); build('UL','Usage'); end else if equal('PRIMEDAYS') then begin work := work + [days]; { Special fixup required } fix(iaddress(prime_days.length)); add(iaddress(prime_days.body)); build('AD','Prime Days'); end else if equal('NETWORK_ACCESS') then begin work := work + [netacc]; { Special fixup required } fix(iaddress(network_access.length)); add(iaddress(network_access.body)); build('AD','Net Access'); end else if equal('BATCH_ACCESS') then begin work := work + [batacc]; { Special fixup required } fix(iaddress(batch_access.length)); add(iaddress(batch_access.body)); build('AD','Batch Access'); end else if equal('LOCAL_ACCESS') then begin work := work + [locacc]; { Special fixup required } fix(iaddress(local_access.length)); add(iaddress(local_access.body)); build('AD','Local Access'); end else if equal('DIALUP_ACCESS') then begin work := work + [diaacc]; { Special fixup required } fix(iaddress(dialup_access.length)); add(iaddress(dialup_access.body)); build('AD','Dial Access'); end else if equal('REMOTE_ACCESS') then begin work := work + [remacc]; { Special fixup required } fix(iaddress(remote_access.length)); add(iaddress(remote_access.body)); build('AD','Remote Access'); end; { Now grab the next field identifier and repeat the process } currfield := currfield + 1; have_arg := rsb$element(field,currfield,',',textmask); end; {while} { Remove the trailing crud from the format specifications. If we didn't get a specification, that means that no output will be generated. Short-circuit that and complain. } if faoctl.length > 1 then begin faoctl.length := faoctl.length - 2; header[1].length := header[1].length - 2; header[2].length := header[2].length - 2; end {then} else lib$stop(%ref who$_nooutput); { If we will be displaying formatted bitmasks, we need to process the /FILTER qualifier for the appropriate masks. } if (privs in work) and_then (cli$present('FILTER.PRIVILEGES') <> cli$_absent) then begin scan_values('FILTER.PRIVILEGES',textmask); string_to_bits(textmask,maskp,priv_table); notmask(maskp); end; {then} if (defprivs in work) and_then (cli$present('FILTER.DEFPRIVILEGES') <> cli$_absent) then begin scan_values('FILTER.DEFPRIVILEGES',textmask); string_to_bits(textmask,maskd,priv_table); notmask(maskd); end; {then} if (flags in work) and_then (cli$present('FILTER.FLAGS') <> cli$_absent) then begin scan_values('FILTER.FLAGS',textmask); string_to_bits(textmask,maskf,flag_table); notmask(maskf); end; {then} end; {procedure generate_format} { This function generates the specified header line. It returns as a status the setting of the 'use_header' flag. } function format_header( var buff : varying [l1] of char; num : integer ) : boolean; begin {function format_header} if (num = 1) or (num = 2) then begin { If a valid header, } $fao(header[num],buff.length,buff.body,0);{ Format it and } format_header := use_header; { Say if it is visible } end else begin buff := ''; { Bogus crap, return nothing } format_header := false; { and definitely don't show it } end; {else} end; {function format_header} { Special fixup routine for disk quotas. It looks up information on quota and usage for the user's default device and sticks it in buffer area. } [hidden] procedure get_disk_quota; type quota_block = record { ACP quota block } dqf$l_flags : integer; { ACP interface flags } dqf$w_member : word_int; { Target UIC } dqf$w_group : word_int; dqf$l_usage : integer; { Current usage } dqf$l_permquota : integer; { Permanent quota } dqf$l_overdraft : integer; { Temporary overdraft } future : array [1..3] of unsigned; { Reserved for future use } end; {record quota_block} var stat : integer; { Return status from call } chan : word_int; { Device channel } iosb : array[1..4] of word_int; { I/O status block } qblk : quota_block; { Interface quota blocks } fib : fib1$type; { Operation block } doof1, doof2 : dsc1$type; { Parameter descriptors } dummy : word_int; { Dummy return argument } begin {procedure get_disk_quota} disk_quota := -1; { Assume errors will occur } disk_usage := -1; { Get a channel to the user's default device. } stat := $assign(dec_uaf.defdev.data,chan); { Set up blocks to retrieve information for this user. } if stat = ss$_normal then begin qblk.dqf$w_member := dec_uaf.uic.member; { Who are we looking for? } qblk.dqf$w_group := dec_uaf.uic.group; fib.fib$w_cntrlfunc := fib$c_exa_quota; { Examine disk quota } fib.fib$l_cntrlval := 0; { Build a descriptor for each block, then call the ACP } doof1.dsc$w_maxstrlen := size(fib); doof1.dsc$a_pointer := iaddress(fib); doof2.dsc$w_maxstrlen := size(qblk); doof2.dsc$a_pointer := iaddress(qblk); $qiow(,chan,io$_acpcontrol,iosb,,,%ref doof1,%ref doof2, %ref dummy,%ref doof2); { If it succeeded, return needed information. If it failed because quotas were active but no entry existed, return zeroes. Everything else gets -1. } if odd(iosb[1]) then begin { If successful, } disk_usage := qblk.dqf$l_usage; { Return real information } disk_quota := qblk.dqf$l_permquota; end else if iosb[1] = ss$_nodiskquota then begin disk_usage := -1; { No quota entry } disk_quota := 0; { so no quota, unknown usage } end; {else..then} { Deassign the channel to the disk and return. } $dassgn(chan); end; {then} end; {procedure get_disk_quota} { Special fixup routine for mask twiddling. It accepts the address of a UAF mask, a modification mask, and returns a "twiddled" mask and an indication of whether any bits got twiddled. } [hidden] procedure mask_bits( maskadr : unsigned; { Address of UAF mask } savemask : mask_type; { Mask of bits to save } quadmask : boolean; { false=long, true=quad mask } var outmask : mask_type; { Resulting mask } var cleared : boolean); { Set if any bits cleared } var uafmask : mask_ptr; { Working variable } begin {procedure mask_bits} uafmask := maskadr::mask_ptr; { Set pointer to mask } outmask[1] := uand(uafmask^[1],savemask[1]);{ Mask out 1st 32 bits } cleared := (uafmask^[1] <> outmask[1]); { See if anything changed } if quadmask then begin { If quadword mask, } outmask[2] := uand(uafmask^[2],savemask[2]); { Do 2nd 32 bits } if not cleared then cleared := (uafmask^[2] <> outmask[2]); { and check for changes } end; {then} end; {procedure mask_bits} { This procedure translates information in the supplied UAF record (or derived from it, like disk quotas) according to the rules defined by generate_format. The result is written to the specified output file, assumed to be open. (Note that the input record is defined as a variable parameter, even though it is not modified, so the compiler won't waste time making a local copy for each call. } procedure format_record( var uaf : uaf_record_type; { Input data UAF record } var outfile : text; { Output listing file } out_flag : boolean; { Use output file? } outsymbol : varying [u1] of char; { Output DCL symbol name } sym_flag : boolean); { Use output symbol? } var buff : varying [132] of char; { Output buffer } src : unsigned; { Block move temporary } i : integer; { Loop counter } tempmask : mask_type; { Temporary formatting mask } mashed : boolean; { Special mask games? } { This subprocedure handles the special case of /FULL. The generated argument list is used, but new control strings are substituted. Each line is done as a separate I/O to keep the output file format from looking too funny, but this requires stepping through the argument list in a manner which is heavily dependent upon the arrangement of the display and the formatting of each field. } procedure full_report; var idx : integer; { Context pointer } stat : integer; { Return status from scans } ctx, { Context pointer } idval, { Value of held identifier } attr : unsigned; { Identifier attributes } name, { Identifier name } nice, { Formatted attributes } line : varying [80] of char; { Output line buffer } procedure do_line( { Output one line of info } ctl : packed array [l1..u1:integer] of char; { $FAO control string } argcnt : integer); { Number of arguments } begin {procedure do_line} $faol(ctl,line.length,line.body,faoarg[idx]); { Generate a line } writeln(outfile,line); { Write it to output } idx := idx + argcnt; { Move index ahead } end; {procedure do_line} begin {procedure full_report} idx := 1; { Start at list head } { Output the fixed part of the display using the prepared argument list } do_line('Username: !33ADOwner: !AC',3); do_line('Class: !33ADManager: !AC',3); do_line('Phone: !33ADMail: !AD',4); do_line('Account: !33ADUIC: [!OW,!OW] (!%I)',5); do_line('CLI: !33ACTables: !AC',2); do_line('Default: !AC!AC',2); do_line('LGICMD: !AC',1); do_line('Flags: !AD',2); do_line('Primary days: !AD',2); writeln(outfile,'Access: Network Batch Local Dialup Remote'); do_line(' !5(10AD)',10); do_line('Expiration: !17%D Pwdminimum:!3UB Login Fails:!6UW',3); do_line('Pwdlifetime: !10%D Pwdchange: !17%D',2); do_line('Last Login: !17%D (interactive), !17%D (non-interactive)',2); do_line('Maxjobs:!10UW Fillm:!10UW Bytlm:!13UL',3); do_line('Maxdetach:!8UW BIOlm:!10UW JTquota:!11UL',3); do_line('Prclm:!12UW DIOlm:!10UW WSdef:!13UL',3); do_line('Prio:!13UB ASTlm:!10UW WSquo:!13UL',3); do_line('Queprio:!10UB TQElm:!10UW WSextent:!10UL',3); do_line('!20* Enqlm:!10UW Pgflquo:!11UL',2); writeln(outfile,'Authorized Privileges:'); do_line(' !78AD',2); writeln(outfile,'Default Privileges:'); do_line(' !78AD',2); writeln(outfile,'Identifier ' + 'Value Attributes'); { Now loop through all held identifiers and report on them } ctx := 0; { Clear context } stat := $find_held(uaf.uic,idval,attr,ctx); { Get 1st identifier } while odd(stat) do begin { While IDs remain } $idtoasc(idval,name.length,name.body); { Get name of identifier } attr := uand(attr,uor(kgb$m_resource,kgb$m_dynamic)); { Mask bits } if attr = 0 then nice := '' { No attributes } else if attr = kgb$m_resource then nice := 'RESOURCE' { Just resource } else if attr = kgb$m_dynamic then nice := 'DYNAMIC' { Just dynamic } else nice := 'RESOURCE,DYNAMIC'; { Both } $fao(' !33AS%X!8XL !AD',line.length,line.body, %stdescr (name),%immed idval,%immed nice.length,%ref nice.body); writeln(outfile,line); { Write it to file } stat := $find_held(uaf.uic,idval,attr,ctx); { Get next identifier } end; {while} writeln(outfile); { Blank line separator } end; {procedure full_report} begin {procedure format_record} { First move the contents of the record buffer into our mapped display buffer. Start with just the fixed (Digital-defined) part of the record. } lib$movc3(uaf$c_fixed,uaf,dec_uaf); { Locate the user-defined part of the record and move it, too. If it doesn't exit, grab the default definitions instead. } src := dec_uaf.usrdatoff; { Offset from record start } if src <> 0 then src := iaddress(uaf) + src { Calculate address } else src := iaddress(default_xerox_uaf); { Use default if missing } lib$movc3(xrx$c_size,%immed src,xerox_uaf); { Move the data } { Time to start munging. We must begin by performing any special fixups which might be required. WORK indicates which ones must be done. } if work <> [] then begin if quota in work then get_disk_quota; { Retrieve disk quota info } if nodes in work then get_resources(dec_uaf.uic,0,'CAN_LOGIN_ON_',buff,node_list); { Nodes } if privs in work then begin mask_bits(iaddress(dec_uaf.priv),maskp,true,tempmask,mashed); { Get bits } bits_to_string(tempmask,privileges,priv_table); { Make into string } if mashed then privileges := '*' + privileges; { Bits were filtered } end; {then} if defprivs in work then begin mask_bits(iaddress(dec_uaf.def_priv),maskd,true,tempmask,mashed); bits_to_string(tempmask,defprivileges,priv_table); if mashed then defprivileges := '*' + defprivileges; end; {then} if flags in work then begin mask_bits(iaddress(dec_uaf.flags),maskf,false,tempmask,mashed); bits_to_string(tempmask,login_flags,flag_table); if mashed then login_flags := '*' + login_flags; end; {then} if days in work then begin lib$movc3(1,uaf.primedays,tempmask); { Get bits into correct type } tempmask[1] := unot(tempmask[1]); { Fix sense of bits } bits_to_string(tempmask,prime_days,out_day_table); end; {then} if netacc in work then access_to_string(uaf.network_access,network_access); if batacc in work then access_to_string(uaf.batch_access,batch_access); if locacc in work then access_to_string(uaf.local_access,local_access); if diaacc in work then access_to_string(uaf.dialup_access,dialup_access); if remacc in work then access_to_string(uaf.remote_access,remote_access); end; {then} { That was fun. Next, transfer any integer arguments from their current location into the $FAO argument list. The FIXUP vector controls this function. } for i := 1 to fixes do lib$movc3(4,%immed fixup[i].source,faoarg[fixup[i].target]); { Finally, use $FAO to actually fill the output buffer; then write to the file. If we are generating one-line reports, this is straightforward. For full listings, disregard the control string and generate multiple output lines. } if full_flag then { /FULL specified? } full_report { Yup, churn out that info } else begin { No, just a single line } $faol(faoctl,buff.length,buff.body,faoarg); { Format it } if out_flag then { If file being generated, } writeln(outfile,buff); { send it to file } if sym_flag then { If symbol being updated, } lib$set_symbol(outsymbol,buff,lib$k_cli_global_sym); { zap global sym } end; {else} end; {procedure format_record} end. {module display}