% VAX-11 Librarian V04-00 * {Ւ rnՒ !!! (ACLDEF.H BUILD.COMC.HCLI.FDSC.F DYNAMIC.FORFATDEF.HFCHDEF.H$FH2DEF.HFI2DEF.HFM2DEF.H% FORMAT.FORITM.F MAKEFILE. XSHOCPU.MARR XSHOFILES.FS XSHOFILES.FORv XSHOFILES1.C XSHOFILES2.C@ XSHOQUE.F XSHOQUE.FORXSHOQUE.RELEASE_NOTES XSHOQUE1.FOR6 XSHOQUE2.FOR XSHOQUE3.FOROW.FOR# XSHOW.HLPW XSHOW1.FOR XSHOW2.FOR XSHOW_DCL.MAR" XSHOQUE_DEF.F  XSHOW.CLDA XSHOW.DOCO XSHOW.FOR# XSHOW.HLPW XSHOW1.FOR XSHOW2.FOR XSHOW_DCL.MAR' XSHOQUE3.FOR XSHOW_DCL.MAR `{Ւ+! XShow.Cld -- command definition for XSHOWJ! Pat Rankin, May'882! Images invoked: XShow, XShoQue, and XShoCmd.<! (XShoCmd should point to Joe Meadows' VERB utility.)! define type shoque_full_keywords! keyword queues, negatable! keyword jobs, negatable* keyword all, negatable, default keyword nonedefine type job_status_keywords! keyword all, negatable\ keyword executing, negatable !includes 'aborting','starting','restarting'! keyword holding, negatable! keyword pending, negatable! keyword waiting, negatable! keyword retained, negatable! keyword other, negatableH keyword printing, negatable !synonym for 'executing'F keyword after, negatable !synonym for 'waiting'define type queue_if_keywords! keyword active, negatable! keyword inactive, negatable! keyword empty, negatable! keyword nonempty, negatable! keyword normal, negatable! keyword abnormal, negatable! keyword generic, negatable! keyword execution, negatableN keyword something, negatable, default !ie, one or more jobs selected! keyword anything, negatable"define type shoque_devtyp_keywords! keyword printer, negatable! keyword terminal, negatable! keyword server, negatable* keyword all, negatable, default keyword none:!! [ logical(assigned), remote/local, generic/execution ]define syntax xshow_queue image XShoQue0 parameter p1, value(required), label=optionG parameter p2, value(LIST,default="*"), label=Queue, prompt="Queue"! qualifier all_jobs, negatable! qualifier batch, negatable qualifier brief, defaultK qualifier by_JOB_STATUS, value(required,list,type=job_status_keywords), negatable qualifier characteri stics! qualifier COMPRESS, negatableJ qualifier device, value(list,type=shoque_devtyp_keywords), negatable< qualifier ENTRY, value(required,list) !,type=$number), qualifier EXCLUDE, value(required,list)! qualifier files, negatable qualifier formsC qualifier full, value(type=shoque_full_keywords), negatable! qualifier generic, negatableL qualifier IF_QUEUE_STATUS, value(list,type=queue_if_keywords), negatable# qualifier JOBNAME, value(list) 0 qualifier ON_NODE, value(list,type=$infile)G qualifier output, value(type=$file,default="SYS$OUTPUT"), default qualifier summary# qualifier USERNAME, value(list)= qualifier WIDTH, value(type=$number,default=80), batchJ disallow (neg batch and neg device and not (forms or characteristics))/ disallow (brief and full and not full.none)9 disallow (generic and on_node) or (summary and files); disallow (device.none and (device.all or device.printer,  or device.terminal or device.server))D disallow (by_JOB_STATUS.executing and neg by_JOB_STATUS.printing? or by_JOB_STATUS.printing and neg by_JOB_STATUS.executing)8 or (by_JOB_STATUS.waiting and neg by_JOB_STATUS.after; or by_JOB_STATUS.after and neg by_JOB_STATUS.waiting)define syntax xshow_entry image XShoQue0 parameter p1, value(required), label=optionD parameter p2, value(required,list), label=entry, prompt="Entry"* qualifier all_jobs, default, negatable ! qualifier batch, negatable qualifier brief, default! qualifier device, negatable! qualifier files, negatable8 qualifier full, value(type=shoque_full_keywords)# qualifier jobname, value(list)G qualifier output, value(default="SYS$OUTPUT",type=$file), defaultE qualifier queue, value(list,default="*"), label=Queue, default# qualifier username, value(list)= qualifier width, value(type=$number,default=80), batchI! VERB -- extr act the definition of internal DCL commands (Joe Meadows)define syntax xshow_commandG image XShoCmd !$ DEFINE XSHOCMD dev:[dir]VERB0 parameter p1, value(required), label=optionJ parameter p2, value(required,list), label=verb, prompt="Command verb" qualifier all qualifier processH qualifier table, value(type=$infile,default="sys$share:DclTables")9 qualifier output, value(type=$outfile), nonnegatable8 qualifier width, value(type=$number), nonnegatable3 qualifier image, value(required,type=$infile)& qualifier symbol, value(required) qualifier list& disallow ANY2(table,process,image)9 disallow image and not symbol or symbol and not image?! DUMP/HEADER/BLOCK=COUNT=0 (VMS Dump) [*temporary*]define type xdump_dummy> keyword count, value(type=$number,default=0), defaultdefine syntax xshow_file image DUMP0 parameter p1, value(required), label=optionK parameter p2, value(required,type=$infile), label=input, prompt="File" qualifier allocated qualifier asciiF qualifier BLOCKS, value(type=xdump_dummy), default, nonnegatable qualifier byte qualifier decimal qualifier file_header* qualifier formatted,default, negatable- qualifier HEADER, default, nonnegatable qualifier hexadecimal qualifier longword qualifier number qualifier octalL qualifier OUTPUT, value(type=$outfile,default="SYS$OUTPUT:XShow.Lis"), default qualifier printer qualifier records qualifier wordF disallow (records or file_header or allocated or number or printer or blocks.count)2! (not fully implemented [can't handle wildcards])define syntax xshow_directory image XShoFiles0 parameter p1, value(required), label=optionB parameter p2, value(required,list,type=$file), label=DIRSPEC, prompt "Directory"* qualifier acl, default, negatableJ qualifier output, value(type=$outfile,default="SYS$OUTPUT"), default+ qualifier width, value(type=$number)define syntax show_daytime cliroutine showtime0 parameter p1, value(required), label=option noqualifiersdefine syntax show_default cliroutine showdef0 parameter p1, value(required), label=option noqualifiersdefine syntax show_protection cliroutine showprot0 parameter p1, value(required), label=option noqualifiersdefine syntax show_status) cliroutine sho wstat, cliflags(nostatus)0 parameter p1, value(required), label=option noqualifiers ! define syntax show_all_symbols! image SHOW2! parameter p1, value(required), label=optionI! qualifier output, value(default="SYS$OUTPUT",type=$file), default! define syntax show_symbol,! cliroutine showsymbl, cliflags(nostatus)! prefix CLI$K_SHSY_2! parameter p1, value(required), label=optionA! parameter p2, value(required,type=$insym), prompt "Symbol".! qualif ier global, placement=positional.! qualifier local, placement=positionalG! qualifier all, syntax=show_all_symbols, placement=positionalE! qualifier log !makes "/l","/lo" ambiguousdefine syntax show_translation cliroutine showtran0 parameter p1, value(required), label=optionA parameter p2, value(required,type=$inlog), prompt="Log_name"' qualifier table value(required)define syntax xshow_load_avg0 parameter p1, value(req uired), label=option qualifier brief, default qualifier fullG qualifier output, value(default="SYS$OUTPUT",type=$file), default disallow (brief and full)define syntax xshow_logins0 parameter p1, value(required), label=option8 qualifier interactive, nonnegatable !(no-op)G qualifier output, value(default="SYS$OUTPUT",type=$file), defaultdefine syntax xshow_pwd0 parameter p1, value(required), label=option qualifier username, valueG qu alifier output, value(default="SYS$OUTPUT",type=$file), defaultdefine syntax xshow_restart image XShoQue0 parameter p1, value(required), label=optionG qualifier output, value(default="SYS$OUTPUT",type=$file), defaultdefine syntax xshow_uic0 parameter p1, value(required), label=option1 parameter p2, value(type=$uic), label=in_uic- qualifier identification, value(required) qualifier username, valueG qualifier output, value(default="SYS$OUTPUT",type=$file), default1 disallow any2(in_uic,identification,username)define type watch_options keyword filedefine syntax xshow_watch0 parameter p1, value(required), label=optionJ parameter p2, value(required,type=WATCH_OPTIONS), label=watch_option, prompt="What"$ qualifier class, nonnegatableG qualifier output, value(default="SYS$OUTPUT",type=$file), defaultdefine type xshow_option! keyword card_reader+ keyword cli, syntax xshow_pwd/ keyword command, syntax xshow_command$ keyword control_y, negatable keyword cpus keyword day.! keyword daytime, syntax show_daytime+ keyword default, syntax xshow_pwd.!+ keyword device, syntax xshow_device1 keyword directory, syntax xshow_directory- keyword entry, syntax xshow_entry, keyword file, syntax xshow_file keyword host0 keyword load_average, syntax xshow_load_avg. keyword logins, syn!tax xshow_logins keyword messageI keyword node !synonym for host keyword on keyword output_rate+ keyword password_info, syntax xshow_pwd keyword prompt1 keyword protection, syntax show_protection- keyword queue, syntax xshow_queue/ keyword restart_value, syntax xshow_restart! keyword rights_list- keyword status, syntax show_status-!(?) keyword symbol, syntax show_symbol. keywor d time, syntax show_daytime2 keyword translation, syntax show_translation+ keyword uic, syntax xshow_uic keyword verify! keyword volume- keyword watch, syntax xshow_watchdefine verb xshow image XShowC parameter p1, value(required,type=xshow_option), prompt="What"G qualifier output, value(default="SYS$OUTPUT",type=$file), defaultwwDjm|Ւ6* XShoQue_Def.F -- structure definitions for XShoQueH* Pat Rankin, 5/88*RF PARAMETER q_CHAR_MASK_SIZE = 128/8 !128 bits == 16 bytesc queues: batch & print STRUCTURE /q_cmn/ INTEGER *4 flags INTEGER *4 status  INTEGER *2 quenamlen$ CHARACTER *32 queue_name !31 INTEGER *2 nodnamlen$ CHARACTER *16 node_name !08 INTEGER *4 owner_u$ fƿ{Ւ ! XShow.HlpH! Pat Rankin, 7/88! Online help for XSHOW.!1 XSHOWE Extended show command. Display information generally not available( through the standard VMS SHOW command. format:% XSHOW option [/option_qualifiers]2 CLI; Displays current or default Command Language Interpreter. format: XSHOW CLI 3 Qualifiers /USERNAME /USERNAME[=user]D Controls which CLI to display. By d%efault, the CLI of the currentG process is displayed. If /USERNAME if specified without a value thenH the user's default CLI is retreived from the System User AuthorizationE File. If a username value is included then that user's default CLI' is retreived (privilege is required)./OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.! 2 COMMAND5 Formats the definition of one or more DCL commands. format: XSHOW COMMAN&D cmd[,cmd...] 3 parameter cmd[,cmd...]A The name of one or more DCL commands. Wildcards are supported. 3 qualifiersE!(pr) /all is not of much use when the command parameter is required.!/ALL!! Display all commands./PROCESSA Requests commands defined for the current process be displayed. This is the default operation.' /PROCESS is incompatable with /TABLE./TABLE /TABLE[=tablefile]C Requests commands in the specified table image file be displayed./' The default value is SYS$SHARE:DCLTABLES.EXE./IMAGE /IMAGE=imagefileF Requests a compiled command definition be extracted from a shareable image. /SYMBOL is required./SYMBOL /SYMBOL=globalsymbolG Specifies the name of a global symbol within a shareable image. OnlyE allowed when /IMAGE is used. The symbol must be the module name of a compiled command definition./OUTPUT /OUTPUT=fileH Controls where the output is sent. By default, it goes to SYS$OUTPUT.(' The default output file type is .CLD./WIDTH /WIDTH=page_width Affects output formatting./LISTG Causes the names of commands to be listed, but not their definitions. 2 CONTROL< Displays the current status of CTRL/Y and CTRL/T settings. format: XSHOW CONTROL2 CPUE Displays the percentage of CPU utilization since the system booted. format: XSHOW CPU2 DAY> Displays the current system day type for user authorization. format: XSHOW )DAY 2 DEFAULTE Displays current or login-default disk and directory default values used by RMS. format: XSHOW DEFAULTF Note: the standard VMS SHOW DEFAULT command is quicker and utilizes less system resources. 3 Qualifiers /USERNAME /USERNAME[=user]C Controls which DEFAULT to display. Normally, the current defaultC is displayed. If /USERNAME if specified without a value then theE user's default is retreived from the System User Authorization FileG (t*he value that is stored in SYS$LOGIN at login time). If a usernameD value is included then that user's default is retreived (privilege is required)./OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.!2 ENTRY: Displays information about a batch or print queue entry.2 HOST2 Displays the name of the current host processor. format: XSHOW HOST XSHOW NODE is equivalent.2 LOAD_AVERAGEF Displays an approximatio+n of the current system load, estimated over? the last minute, last five minutes, and last fifteen minutes. format: XSHOW LOAD_AVERAGEG Note: Kashtan's load average driver (LAVDRIVER) must be installed on/ the system in order for this command to work. 3 Qualifiers/BRIEF /BRIEF/ Requests a single line display (the default)./FULL /[NO]FULLC Determines whether average blocking priority and maximum disk i/o? queue length values are also displayed if they are, available./OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.!2 LOGINS/ Displays the current interactive login limit. format: XSHOW LOGINS 2 MESSAGE2 Displays the current message component settings. format: XSHOW MESSAGE2 NODE2 Displays the name of the current host processor. format: XSHOW NODE XSHOW HOST is equivalent.!2 ONA! Displays the current settings of DCL ON-ERROR and ON-CO-NTROL_Y ! commands.! ! format: ! XSHOW ON!:! Note: only applicable from within a command procedure. 2 OUTPUT_RATE; Displays the current batch job's log-file flush interval. format: XSHOW OUTPUT_RATE1 Note: only applicable from within a batch job.2 PASSWORD_INFOC Displays expiration and other miscellaneous information about the@ user's password. The actual password value is never revealed. format: XSHOW PASSWORD_INFO 3 Qualifiers /USERN.AME /USERNAME[=user]E Controls which password is to be checked. Privilege is required to( obtain information about another user./OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.!2 PROMPT Displays the current prompt. format: XSHOW PROMPT2 QUEUEG Displays information about the system's batch and/or print queues and the jobs they contain. format:- XSHOW QUEUE [queue-name[,queue-name...]]@ /Note: provides much greater flexibility than the standard VMS SHOW QUEUE utility. 3 Parameters queue-name[,queue-name...]F Optional comma separated list of queue specifications; full wildcard- support is provided. Default value is "*". 3 Qualifiers /all_jobs /[no]all_jobsG Requests that jobs owned by any user (/ALL) or only jobs owned by theG current user (/NOALL, the default) be displayed. Same as SHOW QUEUE./batch /[no]batch@ Requests that batch queues b0e displayed (/BATCH) or suppressedC (/NOBATCH). The default is /BATCH unless one or more of /DEVICE,@ /FORMS, or /CHARACTERISTICS is specified. Same as SHOW QUEUE./brief /[no]brief> Requests a brief queue and job display. Same as SHOW QUEUE./BY_JOB_STATUSB /BY_JOB_STATUS=([[NO]ALL,][NO]EXECUTING,[NO]PENDING,[NO]WAITING,-& [NO]HOLDING,[NO]RETAINED,[NO]OTHER)E Specifies what category(s) of jobs to display. By default, jobs in! any category will be displayed.A The 1keyword PRINTING may be used as a synonym for EXECUTING and- AFTER may be used as a synonym for WAITING.F Note: the /ALL_JOBS qualifier still controls whether any jobs ownedF by other users may be displayed. Category OTHER is a catch-all that should never include any jobs./characteristicsG Requests that queue characteristics be displayed. Same as SHOW QUEUEE except that it may be used in combination with /FORMS, /DEVICE, and /BATCH.H Note: the queue-name parameter 2is treated as a list of characteristic names. /COMPRESS /[NO]COMPRESSC Determines whether to suppress blank lines and some column-header? lines in order to fit more information on the screen or page./deviceC /[no]DEVICE[=([[NO]ALL,][NO]PRINTER,[NO]TERMINAL,[NO]SERVER,NONE)]A Requests that print queues be displayed (/DEVICE) or suppressedD (/NODEVICE). The default is /DEVICE unless one or more of /BATCH,@ /FORMS, or /CHARACTERISTICS is specified. Same as SHOW QUEUE. 3F /DEVICE without a value is the same as /DEVICE=ALL, and /DEVICE=NONE is the same as /NODEVICE.C Note: under version 4 of VMS, any device queue that is neither aB terminal queue nor a server queue is treated as a printer queue./ENTRY> /ENTRY=([-,]entry-num[:entry-num][,entry-num[:entry-num]...])B Specifies a list of job entry numbers to determine which jobs toD display. Each element of the list may be a range specified by lowC and high values separated by a colon (':') or 4dash ('-'). If theE first element of the list is a dash ('-'), then the list represents' jobs to be excluded from the display.F Note: the /ALL_JOBS qualifier still controls whether any jobs owned" by other users may be displayed./EXCLUDE& /EXCLUDE=(queue-name[,queue-name...])9 Specifies queues (selected via wildcard) to be omitted.F Note: if the first element of the list is a dash ('-'), the dash is ignored./files /[no]filesF Requests that submitted files fo5r job(s) be displayed. IntermediateD between /BRIEF and /FULL. Same as SHOW QUEUE except that /NOFILESE is allowed with /FULL to provide an alternate intermediate display./formsD Requests that queue forms be displayed. Same as SHOW QUEUE exceptG that it may be used in combination with /CHARACTERISTICS and /DEVICE.E Note: the queue-name parameter is treated as a list of form names./full) /[no]FULL[= ALL | QUEUES | JOBS | NONE ]C Determines level of detail to display. 6 /FULL=NONE is the same asH /NOFULL; it is the default and is equivalent to /BRIEF. /FULL without< a value means /FULL=ALL and is the same as for SHOW QUEUE.G /FULL=QUEUES shows full queue information but /brief (or /files) dataI for jobs. Conversely, /FULL=JOBS shows full job (and file) information but /brief for queues./GENERIC /[NO]GENERICG Requests that only generic queues be displayed (/GENERIC) or that allF generic queues be suppressed (/NOGENERIC). By default, 7both generic% and execution queues are displayed.= This qualifier is ignored when /IF_QUEUE_STATUS is present./IF_QUEUE_STATUSH /IF_Q=([[NO]SOMETHING,][NO]ACTIVE,[NO]INACTIVE,[NO]EMPTY,[NO]NONEMPTY,-@ [NO]NORMAL,[NO]ABNORMAL,[NO]EXECUTION,[NO]GENERIC,[NO]ANYTHING)H Specifies selection criteria for which queues to display. By default,D all queues matching the queue-name parameter (possibly modified by9 the /exclude and/or /on_node qualifiers) are displayed.H /IF_QUEUE_STATUS 8 without a value defaults to /IF_QUEUE=SOMETHING whichC limits the display to queues that have one or more jobs displayedA (determined by /all_jobs, /by_job_status, /entry, /jobname, andD /username qualifiers). /IF_QUEUE=ANYTHING is the same as omitting, the /IF_QUEUE_STATUS qualifier altogether. SOMETHINGG A queue is considered "SOMETHING" (ie, of interest) if at least one! job in it is being displayed. ACTIVE,INACTIVEF A queue is considered active if it has one or 9more jobs executing, inactive otherwise. EMPTY,NONEMPTYB To determine whether a queue is empty, all jobs (regardless of username) are examined. NORMAL,ABNORMALG Stalled, paused, stop pending, stopped are all classed as abnormal. EXECUTION,GENERICE Every queue that is not generic is considered an execution queue. ANYTHING Catch-all for completeness./JOBNAME' /JOBNAME[=([-,]job-name[,job-name...])I List of one or more batch and/or print job-names o :f interest; wildcardsF are supported. Only jobs which match the name(s) will be displayed.G If the first element of the list is a dash ('-'), then only jobs that' do NOT match names will be displayed.F Note: the /ALL_JOBS qualifier still controls whether any jobs owned" by other users may be displayed./ON_NODE) /ON_NODE[=([-,]node-name[,node-name...])A List of one or more VAXcluster nodes of interest; wildcards areH supported. Only queues that execute on the node(s) will ; be displayed.D If the first element of the list is a dash ('-'), then only queues' NOT on the node(s) will be displayed.D By default, all queues regardless of node are displayed. /ON_NODEF without a value will limit the display to queues on the user's node,F and /ON_NODE=(-) will limit the display to execution queues on other than the user's node.D Note: appropriate for VAXcluster systems only; also, incompatable; with /GENERIC and /IF_QUEUE_STATUS=(GENERIC,NOEXECUTION).</output /output[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.G Same as SHOW QUEUE except that missing filename components default to XSHOQUE.LIS./summary /summaryC Displays a one-line job summary for each selected queue. /ALL is implied. /USERNAME* /USERNAME[=([-,]user-name[,user-name...])I List of one or more VMS usernames of interest; wildcards are supported.A Only jobs owned by the user(s) will be displayed. If the firs=tF element of the list is a dash ('-'), then only jobs NOT owned by theD user(s) will be displayed. The default value is the current user.F Note: the /ALL_JOBS qualifier still controls whether any jobs owned" by other users may be displayed./WIDTH /WIDTH=valueF Specifies line width used when formatting /FULL data. For output toH a terminal, the default value is the terminal's width; for output to aD file, the default value is 80 columns. Note that the base display- does> not attempt to stay within this limit.!2 RESTART_VALUE1 Displays the current batch job's restart value. format: XSHOW RESTART_VALUE1 Note: only applicable from within a batch job.2 UIC7 Displays current or default User Identification Code. format: XSHOW UIC [identifier] 3 ParameterF A uic or general identifier may be specified, in which case both itsD numeric and alphabetic values will be displayed. An identifier isG mutually exclusive with the ?/USERNAME and /IDENTIFICATION qualifiers. 3 Qualifiers/IDENTIFICATION /IDENTIFICATION=pidB Requests display of the specified process's UIC. GROUP or WORLD5 privilege may be required depending on the process.6 This qualifier and /USERNAME are mutually exclusive. /USERNAME /USERNAME[=user]D Controls which UIC to display. By default, the UIC of the currentG process is displayed. If /USERNAME if specified without a value thenH the user's default UIC is retreived from@ the System User AuthorizationE File. If a username value is included then that user's default UIC' is retreived (privilege is required).< This qualifier and /IDENTIFICATION are mutually exclusive./OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.!2 VERIFY7 Displays the process's current verification settings. format: XSHOW VERIFY!2 WATCHD! Displays the current flags from SET WATCH (undocumented command).! ! format:! XSHOW WATCH FILE! !3 Parameter! ! The FILE keyword is required. !3 Qualifiers!/CLASS! /CLASS9! Has not effect; complimentary to SET WATCH FILE/CLASS.!!/OUTPUT! /OUTPUT[=file-spec]!I! Controls where the output is sent. By default, it goes to SYS$OUTPUT.! 2 Qualifier/OUTPUT /OUTPUT[=file-spec]H Controls where the output is sent. By default, it goes to SYS$OUTPUT.1 Note: available with most but not all options.!ww B`n{ՒL+ XShow.Doc +J Pat Rankin, Jul'88J Description: revised, Nov'89H XSHOW is an unfinished project, but what there is of it worksH under VMS V4.x as well as V5.x. It is an "extended show" command toH supplement the standard DCL SHOW command. It has alternateH qualifiers or output for som Ce existing SHOW options (XSHOW QUEUE inH particular) and it implements some 'missing' options where DCL has aH SET but no corresponding SHOW (ie, XSHOW UIC, XSHOW HOST, XSHOWH COMMAND [which happens to use Joe Meadows' VERB utility]). Many ofH the options are already available via the F$ENVIRIONMENT() lexical function. Usage:J XSHOW is intended to be set-up and used as a 'native' DCL command.3 Once it has been defined, use it just like SHOW.F D $ XSHOW option [/option_specific_qualifiers] [/OUTPUT=file] Online help is available. Options:5 CLI -- process command interpreterA COMMAND -- DCL command definition(s) (requires Joe1 Meadows' VERB utility)D [NO]CONTROL_Y -- current setting of control Y and control T; CPUS -- idle cpu time (V5.x systems only)E DAY -- authorize's day type (PRIMARY vs SECONDARY)B DEFAUL ET -- RMS default directory (/username option)5 DIRECTORY -- directory info (incomplete); ENTRY -- batch or print job (many options)E FILE -- not yet implemented; uses DUMP/HEADER as an* interim measureB HOST -- miscellaneous system information (minor)A LOAD_AVERAGE -- current system load (requires that Dave< Kashtan's LAVDRIVER be installed)C LOGINS F -- interactive login limit and current value> MESSAGE -- message components currently enabled, NODE -- synonym for "host"A OUTPUT_RATE -- flush interval for batch job's log fileB PASSWORD_INFO -- miscellaneous non-privileged informationA (expiration date, minimum length, etc)H [note: does *not* reveal actual password; can beH completely disabled via system logical na Gme.]3 PROMPT -- current DCL prompt stringG QUEUE -- batch and/or print queues (many selection andH filtering options; superior to V5 SHOW QUEUE)H [note: see XSHOQUE.RELEASE_NOTES for a summary.]; RESTART_VALUE -- batch job's current restart valueC UIC -- current user identification code (in both9 numeric and rights-id formats)D VERIFY -- status H of procedure and image verificationB WATCH -- settings for undocumented SET WATCH FILEH The following 'SET' options have not been implemented in XSHOW due to, complexity and/or privilege requirements.@ RIGHTS_LIST (accessible through SHOW PROCESS/PRIVILEGE)D VOLUME (useful; only approximated by SHOW DEVICE/FULL)D DEVICE (list of wildcarded devices would be desirable)C [NO]ON (need access to fiche; limited utility anyway) I Installation:8 XSHOW should be added to the system's DCLTABLES.B $ dcltables = f$search(f$parse("DCLTABLES","SYS$SHARE:.EXE"))D $ SET COMMAND XSHOW.CLD /TABLES='dcltables' /OUTPUT='dcltables'E $ install := $install/command_mode !(only needed for VMS V4.x)G $ INSTALL REPLACE 'dcltables' /LOG !(on all nodes for a cluster)H Caveat: don't accidentally place DCLTABLES (or any sharable software)H in a sys$specific directory of a cluster-style directory struct Jure if% it actually belongs in sys$common.H If it is not possible or not desired to install XSHOW= system-wide, the DCL command "SET COMMAND" must be used. $ SET COMMAND XSHOWH This has several disadvantages: it's slow, it's not passed on toH spawned subprocesses, and it causes the process to use private memory? for its command tables instead of sharing the system tables.H In addition to installing the command definition, logical namesH K should be set up for the individual program images that the variousH options cause to be invoked. The commands should be placed inH SYLOGICALS.COM or SYSTARTUP.COM (or in their own command procedureH that is invoked by one of those two) so that they will be executed each time the system reboots.B $ DEFINE/SYSTEM XSHOW local_device:[local_directory]XSHOWD $ DEFINE/SYSTEM XSHOQUE local_device:[local_directory]XSHOQUEA $ DEFINE/SYSTEM XSHOCMD local_d Levice:[local_directory]VERBF $ DEFINE/SYSTEM XSHOFILES local_device:[local_directory]XSHOFILESH 'local_device:[local_directory]' should be replaced by whatever diskH and directory are appropriate for your system (the actual location ofH XSHOW.EXE, XSHOQUE.EXE, VERB.EXE, and XSHOFILES.EXE). Note: If theH command was not installed system-wide, then use DEFINE/PROCESSH or /job instead of /system and place XSHOW.CLD in the same directory as XSHOW.EXE.B To d Misable XSHOW PASSWORD_INFO, add the following command:% $ DEFINE/SYSTEM/EXEC XSHOW_PWD 0H or to restrict so that /USERNAME=user can not be used even by a privileged user,% $ DEFINE/SYSTEM/EXEC XSHOW_PWD 1H Notes: there is no reason to disable this option; a non-privilegedH user can retreive the information about him- or herself. The data isH obtained using the $GETUAI system service, which enforces privilegeH checking; GRPPRV or SYSPRV is necessary to retreiNve information about another user.: Finally, the online help should be made available.> $ LIBRARY/HELP SYS$HELP:local_help /INSERT XSHOW.HLP /LOGH If you don't have any local system-wide help libraries, you can add< XSHOW to the standard VMS help library, SYS$HELP:HELPLIB. Author: Pat Rankin- California State Legislature c/oK Assembly Elections, Reapportionment, Environmental Quality LaboratoryM & Constitutional Amendments Committee California Institute of Technology7 Los Angeles, CA Pasadena, CA. Internet: rankin @ eql.Caltech.EDU1 Bitnet: rankin%eql @ CITiago.bitnet. SPAN/HEPnet: EQL::RANKIN (EQL==5.970)N+ [pr] +wwP{Ւ PROGRAM XShow !A ! Pat Rankin, 6/88$ ! XSHOW -- extended show command. ! implicit none C local: INTEGER optval INTEGER *4 stsC functions:! INTEGER *4 XSho_Cmd_Option,, & XSho_Cmn_Qualifiers,H & XShow_Host, XShow_Logins, XShow_Password_Info,A & XShow_Message, XShow_Prompt, XShow_Uic,9 & XShow_QVerify, XShow_Output_Rate,E & XShow_Watch_File, XShow_Cli, XShow_Control,F & XShow_On, XShow_Load_Average, XShow_Default,- & XShow_Day, XShow_Cpu optval = 0 sts = XSho_Cmd_Option( optval) IF ( sts )# & sts = XSho_Cmn_Qualifiers() IF ( optval .EQ. 1 ) THEN sts = XShow_Host() ELSE IF ( optval .EQ. 2 ) THEN sts = XShow_Logins() ELSE IF ( optval .EQ. 3 ) THEN sts = XShow_Password_InfoR() ELSE IF ( optval .EQ. 4 ) THEN sts = XShow_Message() ELSE IF ( optval .EQ. 5 ) THEN sts = XShow_Prompt() ELSE IF ( optval .EQ. 6 ) THEN sts = XShow_UIC() ELSE IF ( optval .EQ. 7 ) THEN sts = XShow_Verify() ELSE IF ( optval .EQ. 8 ) THEN sts = XShow_Output_Rate() ELSE IF ( optval .EQ. 9 ) THEN sts = XShow_Watch_File() ELSE IF ( optval .EQ. 10 ) THEN sts = XShow_Cli() ELSE IF ( optval .EQ. 11 ) THEN sts = XShow_Control() ELSE SIF ( optval .EQ. 12 ) THEN sts = XShow_On() ELSE IF ( optval .EQ. 13 ) THEN sts = XShow_Load_Average() ELSE IF ( optval .EQ. 14 ) THEN sts = XShow_Default() ELSE IF ( optval .EQ. 15 ) THEN sts = XShow_Day() ELSE IF ( optval .EQ. 16 ) THEN sts = XShow_Cpu() ELSE) CALL Output( '% unsupported option') sts = '10000000'x END IF CALL EXIT( sts) end !of XShow(main)5 integer *4 function XSho_Cmd_Option ( option ) ! ! I Tnterpret the command line. ! implicit noneC constant: PARAMETER kEYWRD_CNT = 16% CHARACTER *16 kEYWORDS(kEYWRD_CNT)H & / 'HOST', 'LOGINS','PASSWORD_INFO', 'MESSAGE',E & 'PROMPT', 'UIC', 'VERIFY', 'OUTPUT_RATE',> & 'WATCH', 'CLI', 'CONTROL_Y', 'ON',G & 'LOAD_AVERAGE', 'DEFAULT', 'DAY', 'CPUS' /,, & sYNONYMS(kEYWRD_CNT)E & / 'NODE', U'INTERACTIVE', 'PASSWORD', 'MSG',8 & 6*' ', 'NOCONTROL', 5*' ' / C output: INTEGER option C local: CHARACTER *20 value INTEGER *2 ln INTEGER idx LOGICAL found INTEGER *4 stsC functions:, INTEGER *4 Cli_Present, Cli_Get_Value option = 0 ln = 0* sts = Cli_Get_Value( 'OPTION', value, ln)8 IF ( .NOT. sts ) sts = Cli_Get_Value( 'P1', value, ln) IF ( sts .AND. ln .GT. 0 ) THEN found = .VFALSE. idx = 07 DO WHILE ( idx .LT. kEYWRD_CNT .AND. .NOT. found ) idx = idx + 1. found = ( value(:ln) .EQ. kEYWORDS(idx)(:ln)> & .OR. value(:ln) .EQ. sYNONYMS(idx)(:ln) ) END DO IF ( found ) option = idx END IF XSho_Cmd_Option = sts RETURN END !of XSho_Cmd_Option2 INTEGER *4 FUNCTION XSho_Cmn_Qualifiers ( ) !8 ! Process qualifiers common to all (or most) options. ! implicit none C local: INTEGER *4 sts, dummyC functions: INTEGER *4 Cli_Present,# & Open_Output sts = 1 IF ( Cli_Present( 'OUTPUT') )6 & sts = Open_Output( 'XShow.Lis', dummy) XSho_Cmn_Qualifiers = sts RETURN! END !of XSho_Cmn_QualifierswwX`{Ւ$* XShow1.For -- routines for XSHOWH* Pat Rankin, 6/88* i*4 XShow_Host ( )* i*4 XShow_Logins ( )* i*4 XShow_Password_Info ( )* i*4 XShow_Message ( )* i*4 XShow_Prompt ( )* i*4 XShow_Uic ( )* i*4 XShow_Verify ( )* i*4 XShow_Output_Rate ( )* i*4 XShow_Watch_File ( )* i*4 XShow_Cli ( )* i*4 XShow_Control ( )*) INTEGER *4 FUNCTION XShow_Host ( ) !( ! Display infYormation about our node. ! implicit noneC constant: INCLUDE '($SYIdef)/nolist' INCLUDE 'f_inc:Itm.F' C local: RECORD /itmlst/ items(8)8 CHARACTER buffer *256, nodename *40, version *8* INTEGER *2 buflen, nodnamlen, ltmpA INTEGER *4 node_area, node_number, boottime(2), cpu_type LOGICAL *1 cluster_member INTEGER *4 sts, iosb(2)C functions: INTEGER *4 SYS$GETSYIW, & Output nodename = ' ' nodnamlZen = 0 version = ' ' cluster_member = .FALSE. node_area = 0 node_number = 0 boottime(1) = 0 boottime(2) = 0$ items(1).itm_length = LEN(nodename)$ items(1).itm_code = SYI$_NODENAME% items(1).itm_bufadr = %LOC(nodename)& items(1).itm_retlen = %LOC(nodnamlen)# items(2).itm_length = LEN(version)# items(2).itm_code = SYI$_VERSION$ items(2).itm_bufadr = %LOC(version)% items(3).itm_length = ITM_S_QUADWORD$ items(3).itm_code = SYI$_BOOTTIME% items(3).itm_bufadr = %LOC(bootti [me)! items(4).itm_length = ITM_S_BYTE* items(4).itm_code = SYI$_CLUSTER_MEMBER+ items(4).itm_bufadr = %LOC(cluster_member)% items(5).itm_length = ITM_S_LONGWORD% items(5).itm_code = SYI$_NODE_AREA& items(5).itm_bufadr = %LOC(node_area)% items(6).itm_length = ITM_S_LONGWORD' items(6).itm_code = SYI$_NODE_NUMBER( items(6).itm_bufadr = %LOC(node_number)% items(7).itm_length = ITM_S_LONGWORD? items(7).itm_code = SYI$_CPU !hardware type% items(7).itm_bufadr = %\LOC(cpu_type)( items(8).itm_code = ITM_K_END_OF_LIST% sts = SYS$GETSYIW(,,, items, iosb,,) IF ( sts ) sts = iosb(1) IF ( sts ) THEN IF ( nodnamlen .EQ. 0 )D & CALL STR$TRIM( nodename, '(unknown)', nodnamlen)9 CALL SYS$FAO( ' Host node is !AS,', buflen, buffer,/ & nodename(:nodnamlen) ) IF ( cluster_member ) THEN+ buffer(buflen+1:) = ' VAXcluster member,'. buflen = buflen + LEN('_VAXcluster_member,') END IF: IF ]( node_area .NE. 0 .AND. node_number .NE. 0 ) THEN. CALL SYS$FAO( ' DECnet address is !UW.!UW,',5 & ltmp, buffer(buflen+1:),A & %VAL(node_area), %VAL(node_number) ) buflen = buflen + ltmp END IF+ CALL STR$TRIM( version, version, ltmp); CALL SYS$FAO( '!/ VMS !AS, system up since !20%D.',1 & ltmp, buffer(buflen+1:),2 & version(:ltmp), boottime) buflen = buflen + ltmp#^ sts = Output( buffer(:buflen)) END IF XShow_Host = sts RETURN END !of XShow_Host+ INTEGER *4 FUNCTION XShow_Logins ( ) !D ! Display the system's current interactive login count and limit. ! implicit noneC constant:"C- INCLUDE '($SYIdef)/nolist'DC- INCLUDE 'f_inc:Itm.F' !item list structure C local: C- RECORD /itmlst/ items(3) CHARACTER *80 buffer INTEGER *2 buflen INTEGER *2 limit, cou_nt INTEGER *4 sts, iosb(2)C functions: INTEGER *4 Output#C- INTEGER *4 SYS$GETSYIW limit = 0 count = 0 CALL X_Logins( limit, count)(C- items(1).itm_length = ITM_S_WORD*C- items(1).itm_code = SYI$_IJOBLIM)C- items(1).itm_bufadr = %LOC(limit)C- items(1).itm_retlen = 0(C- items(2).itm_length = ITM_S_WORD@C- items(2).itm_code = SYI$_IJOBCNT !(not available))C- items(2).itm_bufadr = %LOC(count)C- items(`2).itm_retlen = 0/C- items(3).itm_code = ITM_K_END_OF_LIST,C- sts = SYS$GETSYIW(,,, items, iosb,,)!C- IF ( sts ) sts = iosb(1)C- IF ( sts ) THEN CALL SYS$FAO(H & ' Interactive login limit = !UW, current value = !UW.',C & buflen, buffer, %VAL(limit), %VAL(count) )# sts = Output( buffer(:buflen))C- END IF XShow_Logins = sts RETURN END !of XShow_Logins2 INTEGER *4 FUNCTION XShow_Passwor ad_Info ( ) !2 ! Display info relevant to the user's password.* ! [Not the password itself, of course!] ! implicit noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process infoA INCLUDE '($UAIdef)/nolist' !user authorization infoG INCLUDE '($SYIdef)/nolist' !system info !V5.2+7 INCLUDE '($LNMdef)/nolist' !logical namesI INCLUDE '($PSLdef)/nolist' !process status longword (modes)E INCLUDE '($SSdef) b/nolist' !system service status codes4 INCLUDE 'f_inc:Itm.F' !item lists; INCLUDE 'f_inc:Cli.F' !command line defsG PARAMETER UAI_M_RESTRICTED = '00000008'x, !V4,5.1 captiv!V5.2+N & UAI_M_NEW_CAPTIVE = '00010000'x, !V5.2 & up !V5.2+N & UAI_M_OLD_CAPTIVE = '00010008'x ! !V5.2+ CHARACTER *1 TAB PARAMETER ( TAB = CHAR(9) )7 INTEGER *4 qNULL(2) /0,0/ !quad cword zero C local: RECORD /itmlst/ items(9): CHARACTER disp *128, username *32, trans_buf *12,N & vms_version *8 !V5.2++ INTEGER *2 ln, usrnamlen, trnbuflen$ INTEGER *4 flags, pwd_length,7 & pwd(2), pwd2(2), pwd_life(2),C & pwd_date(2), pwd2_date(2), expir_date(2),( & now(2), work(2): LOGICAL got_pwd, got_pwd2, done, inhibit_user, dN & pre_v5_2 !V5.2+ INTEGER *4 sts, iosb(2)C functions: INTEGER Cmp_Quad,& & LIB$MATCH_COND7 INTEGER *4 SYS$GETJPIW, SYS$GETUAI, SYS$TRNLNM,4 & Cli_Present, Cli_Get_Value, & OutputKC see whether the system manager has disabled or restricted this optionHC [note: this routine only displays non-privileged info anyway] trans_beuf = ' ' trnbuflen = 0% items(1).itm_length = LEN(trans_buf)B items(1).itm_code = LNM$_STRING !logical name translation& items(1).itm_bufadr = %LOC(trans_buf)& items(1).itm_retlen = %LOC(trnbuflen)( items(2).itm_code = ITM_K_END_OF_LISTA sts = SYS$TRNLNM(, 'LNM$SYSTEM', 'XSHOW_PWD', PSL$C_EXEC, items) IF ( trnbuflen .GT. 07 & .AND. trans_buf(:trnbuflen) .EQ. '0' ) THEN4 sts = SS$_NOPRIV !option is disabled ELSE IF ( trnbuflen .GT. 07 & .AfND. trans_buf(:trnbuflen) .EQ. '1' ) THENK inhibit_user = .TRUE. !option is restricted (/username disabled)1 sts = SS$_NOPRIV .OR. 1 !set success bit ELSE sts = 1 END IF username = ' ' usrnamlen = 01C retreive username (required for UAF lookup)/ IF ( sts .AND. Cli_Present( 'USERNAME') ) THEN9 sts = Cli_Get_Value( 'USERNAME', username, usrnamlen)3 IF ( LIB$MATCH_COND( sts, CLI$_ABSENT) .GT. 0 )0 & sts = sts .OR. 1 !success g END IF" IF ( sts .AND. ( usrnamlen .EQ. 0C & .OR. username(:usrnamlen) .EQ. ' ' ) ) THEN' items(1).itm_length = LEN(username)' items(1).itm_code = JPI$_USERNAME( items(1).itm_bufadr = %LOC(username)) items(1).itm_retlen = %LOC(usrnamlen)+ items(2).itm_code = ITM_K_END_OF_LIST( sts = SYS$GETJPIW(,,, items, iosb,,) IF ( sts ) sts = iosb(1)( ELSE IF ( sts .AND. inhibit_user ) THENB sts = SS$_NOPRIV !"/username=anything"h not allowed END IF IF ( sts ) THEN flags = 0 pwd_length = 0 pwd(1) = 0 pwd(2) = 0 pwd2(1) = 0 pwd2(2) = 0( items(1).itm_length = ITM_S_LONGWORD$ items(1).itm_code = UAI$_FLAGS% items(1).itm_bufadr = %LOC(flags) items(1).itm_retlen = 0( items(2).itm_length = ITM_S_LONGWORD) items(2).itm_code = UAI$_PWD_LENGTH* items(2).itm_bufadr = %LOC(pwd_length)( items(3).itm_length = ITM_S_QUADWORD+ items(3).itm_code = UAI$_PWD_LiIFETIME( items(3).itm_bufadr = %LOC(pwd_life)( items(4).itm_length = ITM_S_QUADWORD' items(4).itm_code = UAI$_PWD_DATE( items(4).itm_bufadr = %LOC(pwd_date)( items(5).itm_length = ITM_S_QUADWORD" items(5).itm_code = UAI$_PWD# items(5).itm_bufadr = %LOC(pwd)( items(6).itm_length = ITM_S_QUADWORD( items(6).itm_code = UAI$_PWD2_DATE) items(6).itm_bufadr = %LOC(pwd2_date)( items(7).itm_length = ITM_S_QUADWORD# items(7).itm_code = UAI$_PWD2$ jitems(7).itm_bufadr = %LOC(pwd2)( items(8).itm_length = ITM_S_QUADWORD) items(8).itm_code = UAI$_EXPIRATION* items(8).itm_bufadr = %LOC(expir_date)+ items(9).itm_code = ITM_K_END_OF_LIST0C items(10).itm_length = ITM_S_QUADWORD2C items(10).itm_code = UAI$_LASTLOGIN_I3C items(10).itm_bufadr = %LOC(inter_login)0C items(11).itm_length = ITM_S_QUADWORD2C items(11).itm_code = UAI$_LASTLOGIN_N3C items(11).itm_bufadr = %LkOC(batch_login)0C items(12).itm_length = ITM_S_LONGWORD/C items(12).itm_code = UAI$_LOGFAILS0C items(12).itm_bufadr = %LOC(logfails)7 sts = SYS$GETUAI(,, username(:usrnamlen), items,,,) IF ( sts ) THEN CALL SYS$GETTIM( now)? CALL STR$TRIM( disp,' User '//username(:usrnamlen), ln)5 IF ( (flags .AND. UAI$M_DISACNT) .NE. 0 ) THEN% disp(ln+1:) = ', account disabled'& ln = ln + LEN(',_account_disabled') done = .TRUE.4 l ELSE IF ( Cmp_Quad( expir_date, qNULL) .GT. 0E & .AND. Cmp_Quad( now, expir_date) .GE. 0 ) THEN$ disp(ln+1:) = ', account expired'% ln = ln + LEN(',_account_expired') done = .TRUE. ELSENC determine VMS version (special handling for /CAPTIVE) !V5.2+@ items(1).itm_length = LEN(vms_version) !V5.2+@ items(1).itm_code = SYI$_VERSION !V5.2+@ items(1).itm_bufadr = %LOC(vms_version) !V5. m2+@ items(1).itm_retlen = 0 !V5.2+@ items(2).itm_code = ITM_K_END_OF_LIST !V5.2+@ call SYS$GETSYIW(,,, items, iosb,,) !V5.2+@ IF ( .NOT. iosb(1) ) vms_version = '?5.2' !V5.2+@ pre_v5_2 = ( vms_version(2:4) .LT. '5.2' ) !V5.2+0C create list of things to display done = .FALSE.@ IF ( pre_v5_2 ) THEN !V5.2+@ IF ( (flags .AND. UAI_M_OLD_CA nPTIVE) .NE. 0 ) THEN !V5.2*" disp(ln+1:) = ', captive'# ln = ln + LEN(',_captive') END IF@ ELSE !V5.2 or later !V5.2+@ IF ( (flags .AND. UAI_M_NEW_CAPTIVE) .NE. 0 ) THEN !V5.2+@ disp(ln+1:) = ', captive' !V5.2+@ ln = ln + LEN(',_captive') !V5.2+@ END IF !V5.2+@ IF ( (flags .AND. UAI_M_RESTRICTED) .NE. 0 ) THEN o!V5.2+@ disp(ln+1:) = ', restricted' !V5.2+@ ln = ln + LEN(',_restricted') !V5.2+@ END IF !V5.2+@ END IF !V5.2+3 IF ( (flags .AND. UAI$M_AUTOLOGIN) .NE. 0 ) THEN- disp(ln+1:) = ', automatic logins only'. ln = ln + LEN(',_automatic_logins_only') END IF1 IF ( (flags .AND. UAI$M_LOCKPWD) .NE. 0 ) THEN' disp(ln+1:) = p', locked password'( ln = ln + LEN(',_locked_password')5 ELSE IF ( (flags .AND. UAI$M_GENPWD) .NE. 0 ) THEN4 disp(ln+1:) = ', generated passwords required'5 ln = ln + LEN(',_generated_passwords_required') END IF END IF CALL Output( disp(:ln)) IF ( .NOT. done ) THEN. got_pwd = ( Cmp_Quad( pwd, qNULL) .NE. 0 )/ got_pwd2 = ( Cmp_Quad( pwd2, qNULL) .NE. 0 ) IF ( .NOT. got_pwd ) THEN/ CALL Output( TAB//'No password required')9 E qLSE IF ( (flags .AND. UAI$M_PWD_EXPIRED).NE. 0 ) THEN. CALL Output( TAB//'Password is expired'): ELSE IF ( (flags .AND. UAI$M_PWD2_EXPIRED).NE. 0 ) THEN8 CALL Output( TAB//'Secondary password is expired') ELSE IF ( got_pwd2 )H & CALL Output( TAB//'Secondary password required')3 IF ( Cmp_Quad( pwd_life, qNULL) .EQ. 0 ) THEN CALL STR$TRIM( disp,H & TAB//'No expiration on password', ln) ELSE IF ( rgot_pwd2 .AND.H & Cmp_Quad( pwd_date, pwd2_date) .GT. 0 ) THEN2 CALL LIB$SUBX( pwd2_date, pwd_life, work) CALL SYS$FAO(H & '!_Secondary password due to expire !20%D',3 & ln, disp, work) ELSE1 CALL LIB$SUBX( pwd_date, pwd_life, work)8 CALL SYS$FAO( '!_Password due to expire !20%D',3 & ln, disp, work) END IF CALL Output( dis sp(:ln))# IF ( pwd_length .EQ. 0 ) THEN CALL STR$TRIM( disp,H & TAB//'No minimum password length', ln) ELSE: CALL SYS$FAO( '!_Minimum password length is !UW',@ & ln, disp, %VAL(pwd_length) ) END IF CALL Output( disp(:ln))5 IF ( Cmp_Quad( expir_date, qNULL) .NE. 0 ) THEN7 CALL SYS$FAO( '!_Account due to expire !20%D',9 & ln, disp, expir_datte) CALL Output( disp(:ln)) END IF END IF END IF END IF END IF XShow_Password_Info = sts RETURN! END !of XShow_Password_Info, INTEGER *4 FUNCTION XShow_Message ( ) !4 ! Display the process's current message settings. ! implicit noneC constant:< CHARACTER *15 mSG_FIELDS(0:3) / 'TEXT', 'IDENTIFICATION',B & 'SEVERITY', 'FACILITY' / C local: CHARACTER *80 buffer INTEGuER *2 buflen, ln INTEGER msgmask, bit INTEGER *4 stsC functions: INTEGER *4 Output INTRINSIC BTEST msgmask = 0 CALL X_Msg( msgmask)0 CALL STR$TRIM( buffer, ' Message = (', buflen) DO bit = 3, 0, -1+ IF ( .NOT. BTEST( msgmask, bit) ) THEN" buffer(buflen+1:buflen+2) = 'NO' buflen = buflen + 2 END IF; CALL STR$TRIM( buffer(buflen+1:), mSG_FIELDS(bit), ln)= buflen = buflen + ln + 1 !count value & comma6 v buffer(buflen:buflen) = ',' !append comma END DO< buffer(buflen:buflen) = ')' !change last comma to paren sts = Output( buffer(:buflen)) XShow_Message = sts RETURN END !of XShow_Message+ INTEGER *4 FUNCTION XShow_Prompt ( ) !1 ! Display the process's current prompt string. ! implicit none C local:$ CHARACTER *32 prompt, outbuf *80) INTEGER *2 ln, buflen, carr_cntrl BYTE continue_chr INTEGER *4 stsC w functions: INTEGER *4 X_Prmpt, & Output INTRINSIC LEN, MIN ln = 05 sts = X_Prmpt( prompt, ln, continue_chr, carr_cntrl) ln = MIN( ln, LEN(prompt) ) IF ( sts ) THEN5 CALL Fmt_Strings( prompt, ln, 1, outbuf, buflen)3 sts = Output( ' Prompt = '//outbuf(:buflen) ) END IF XShow_Prompt = sts RETURN END !of XShow_Prompt( INTEGER *4 FUNCTION XShow_Uic ( ) !7 ! Display the user's UIC (User Identification Codxe). ! implicit noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process infoA INCLUDE '($UAIdef)/nolist' !user authorization infoA* INCLUDE '($CLIMSGdef)/nolist' !cli status codes* PARAMETER CLI$_IVVALU = '00038088'x3 INCLUDE 'f_inc:Itm.F' !item list; INCLUDE 'f_inc:Cli.F' !command line defs C local: RECORD /itmlst/ uai_list(2)3 CHARACTER *64 result, uic_string, username *32. INTEGyER *2 ln, p, ustr_len, usrnamlen LOGICAL show_user INTEGER *4 uic, pid, stsC functions: INTEGER LIB$MATCH_COND) INTEGER *4 LIB$GETJPI, SYS$GETUAI,3 & OTS$CVT_TZ_L, X_Parse_UIC,4 & Cli_Present, Cli_Get_Value, & Output% IF ( Cli_Present( 'USERNAME') ) THEN/C look up a user's (default = ours) UIC usrnamlen = 0: sts = Cli_Get_Value( 'USERNAME', username, usrnam zlen)2 IF ( LIB$MATCH_COND( sts, CLI$_ABSENT) .GT. 01 & .OR. sts .AND. ( usrnamlen .EQ. 0F & .OR. username(:usrnamlen) .EQ. ' ' ) )H & sts = LIB$GETJPI( JPI$_USERNAME,,,, username, usrnamlen) IF ( sts ) THEN) uai_list(1).itm_length = ITM_S_LONGWORD# uai_list(1).itm_code = UAI$_UIC$ uai_list(1).itm_bufadr = %LOC(uic) uai_list(1).itm_retlen = 0, uai_list(2).itm_code = ITM_K_END_OF_LIST8 sts = SYS$GETUAI(,, username(:{usrnamlen), uai_list,,,) END IF show_user = .TRUE.( ELSE IF ( Cli_Present( 'IN_UIC') ) THEN'C uic specified on command line9 sts = Cli_Get_Value( 'IN_UIC', uic_string, ustr_len)? IF ( sts ) sts = X_Parse_UIC( uic_string(:ustr_len), uic) show_user = .FALSE. ELSE pid = 0 sts = 1/ IF ( Cli_Present( 'IDENTIFICATION') ) THEN4 sts = Cli_Get_Value( 'IDENTIFICATION', result, ln) IF ( sts ) THEN+ sts = OTS$CVT_TZ_L( result(:ln), pid)|< IF ( .NOT. sts ) sts = CLI$_IVVALU !invalid value END IF END IF show_user = ( pid .NE. 0 )(C retreive process's current UIC9 IF ( sts ) sts = LIB$GETJPI( JPI$_UIC, pid,, uic,,) IF ( show_user .AND. sts )C & CALL SYS$FAO( 'PID !08XL', usrnamlen, username,+ & %VAL(pid)) END IF IF ( sts ) THEN' CALL Fmt_UIC( uic, -1, result, ln)B p = INDEX( result(:ln), '(') !find paren}thesis8 IF ( p .GT. 1 .AND. result(p-1:p-1) .NE. ' ' ) THEN7 result(p:ln+1) = ' ' // result(p:ln) !insert space ln = ln + 1 END IF IF ( show_user ) THENA CALL STR$TRIM( username, username(:usrnamlen), usrnamlen)8 sts = Output( ' '//username(:usrnamlen)//'''s UIC = ', & //result(:ln) ) ELSE) sts = Output( ' UIC = '//result(:ln) ) END IF END IF XShow_Uic = sts RETURN END !of XShow_Uic+ IN~TEGER *4 FUNCTION XShow_Verify ( ) !9 ! Display the process's current verification settings. ! implicit noneC constant:8 CHARACTER *10 vERIF_TYPE(0:1) / 'PROCEDURE','IMAGE' / C local: CHARACTER *80 buffer INTEGER *2 buflen, ln INTEGER verify, bit INTEGER *4 stsC functions: INTEGER *4 Output INTRINSIC BTEST verify = 0 CALL X_Ver( verify)/ CALL STR$TRIM( buffer, ' Verify = (', buflen) DO bit = 0, 1* IF ( .NOT. BTEST( verify, bit) ) THEN" buffer(buflen+1:buflen+2) = 'NO' buflen = buflen + 2 END IF; CALL STR$TRIM( buffer(buflen+1:), vERIF_TYPE(bit), ln)= buflen = buflen + ln + 1 !count value & comma6 buffer(buflen:buflen) = ',' !append comma END DO< buffer(buflen:buflen) = ')' !change last comma to paren sts = Output( buffer(:buflen)) XShow_Verify = sts RETURN END !of XShow_Verify0 INTEGER *4 FUNCTION XShow_Output_Rate ( ) !3 ! Display the batch process's output flush rate. ! implicit none C local:( CHARACTER *48 buffer, flush_rate *16 INTEGER *2 buflen, ln, p INTEGER *4 quad(2), stsC functions: INTEGER *4 Output INTEGER LIB$SKPC quad(1) = 0 quad(2) = 0 CALL X_OutRate( quad)@ IF ( quad(2) .GT. 0 .OR. quad(1).EQ.0 .AND. quad(2).EQ.0 ) THEN- CALL STR$TRIM( flush_rate, '(none)', ln) ELSE- CALL SYS$ASCTIM( ln, flush_rate, quad, )(  p = LIB$SKPC( flush_rate(:ln), ' ')1 IF ( flush_rate(1:5) .EQ. ' 0 ' ) p = 5+1 END IF/ CALL SYS$FAO( ' Log file output rate = !AS.',7 & buflen, buffer, flush_rate(p:ln) ) sts = Output( buffer(:buflen)) XShow_Output_Rate = sts RETURN END !of XShow_Output_Rate/ INTEGER *4 FUNCTION XShow_Watch_File ( ) !/ ! Display the process's file-watch settings. ! implicit noneC constant:! CHARACTER *20 wATCH_CLASS(0:5)8  & / 'MAJOR', 'CONTROL_FUNCTION',A & 'ATTRIBUTES', 'DIRECTORY_OPERATIONS',8 & 'DUMP', 'QUOTA_OPERATIONS' / C local:# CHARACTER *256 buffer, class *20 INTEGER *2 buflen, ln INTEGER watch, bit INTEGER *4 stsC functions: INTEGER *4 Output INTRINSIC BTEST watch = 0 CALL X_WatchFile( watch) IF ( watch .EQ. 0 ) THEN@ CALL STR$TRIM( buffer, ' File watching disabled.', buflen) ELSE CALL STR$TRIM( buffer,F & ' File watching enabled for the following classes: ',! & buflen) DO bit = 0, 5 IF ( BTEST( watch, bit) ) THEN1 CALL STR$TRIM( class, wATCH_CLASS(bit), ln)5 CALL SYS$FAO( '!/!_!AS', ln, buffer(buflen+1:),- & class(:ln) ) buflen = buflen + ln END IF END DO END IF sts = Output( buffer(:buflen)) XShow_Watch_File = sts RETURN  END !of XShow_Watch_File( INTEGER *4 FUNCTION XShow_Cli ( ) !! ! Show the process's CLI name. ! implicit noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process infoA INCLUDE '($UAIdef)/nolist' !user authorization info3 INCLUDE 'f_inc:Itm.F' !item list; INCLUDE 'f_inc:Cli.F' !command line defs C local: RECORD /itmlst/ uai_list(2)9 CHARACTER cli_name *40, username *32, result *80+ INTEGER *2 clinamlen, usrnamlen, ln LOGICAL show_user INTEGER *4 stsC functions: INTEGER LIB$MATCH_COND) INTEGER *4 LIB$GETJPI, SYS$GETUAI,4 & Cli_Present, Cli_Get_Value, & Output% IF ( Cli_Present( 'USERNAME') ) THEN/C look up a user's (default = ours) CLI usrnamlen = 0: sts = Cli_Get_Value( 'USERNAME', username, usrnamlen)2 IF ( LIB$MATCH_COND( sts, CLI$_ABSENT) .GT. 01 & .OR. sts .AND. ( usrnamlen .EQ. 0F & .OR. username(:usrnamlen) .EQ. ' ' ) )H & sts = LIB$GETJPI( JPI$_USERNAME,,,, username, usrnamlen) IF ( sts ) THEN clinamlen = 0( uai_list(1).itm_length = LEN(cli_name)& uai_list(1).itm_code = UAI$_DEFCLI) uai_list(1).itm_bufadr = %LOC(cli_name)* uai_list(1).itm_retlen = %LOC(clinamlen), uai_list(2).itm_code = ITM_K_END_OF_LIST8 sts = SYS$GETUAI(,, username(:usrnamlen), uai_list,,,) END IF% show_user = ( clinamlen .GT. 0 ) ELSE(C use this process's current CLI< sts = LIB$GETJPI( JPI$_CLINAME,,,, cli_name, clinamlen) show_user = .FALSE. END IF IF ( sts ) THENE CALL STR$TRIM( cli_name, cli_name, clinamlen) !V5+ IF ( show_user ) THEN/ CALL STR$TRIM( username, username, usrnamlen)3 CALL SYS$FAO( ' !AS''s CLI = "!AS"', ln, result,H & username(:usrnamlen), cli_name(:clinamlen))  ELSE result = ' ' // cli_name ln = LEN('__') + clinamlen END IF sts = Output( result(:ln)) END IF XShow_Cli = sts RETURN END !of XShow_Cli, INTEGER *4 FUNCTION XShow_Control ( ) !/ ! Show the process's control (t,y) settings. ! implicit noneC constant: INCLUDE '($CLIdef)/nolist' INCLUDE '($CliServDef)/nolist' STRUCTURE /clitmp/ UNION MAP8 INTEGER *4 cli_l_request !1st four bytes END MAP MAP RECORD /clidef1/ general END MAP MAP! RECORD /clidef3/ oob_mask END MAP END UNION END STRUCTURE% INTRINSIC CHAR, ICHAR, ISHFT5 INTEGER *4 kNOWN_KEYS !'02100000'x> PARAMETER ( kNOWN_KEYS = ISHFT( 1, ICHAR('T').AND.'1F'x)G & .OR. ISHFT( 1, ICHAR('Y').AND.'1F'x) ) C local: RECORD /clitmp/ cli CHARACTER *80 buf INTEGER *2 ln, ltmp INTEGER *4 mask, pos INTEGER *4 stsC functions: INTEGER LIB$FFS INTEGER *4 SYS$CLI, & Output INTRINSIC LEN, MINF cli.cli_l_request = 0 !clear 1st four bytes= cli.general.cli$b_rqtype = CLI$K_CLISERV !cli serviceI cli.general.cli$b_rqindx = CLI$K_ENABOOB !enable out-of-band ASTsH cli.oob_mask.cli$l_new_mask = 0 !but don't set anythingE cli.oob_mask.cli$l_old_mask = 0 !(output comes here) sts = SYS$CLI( cli,,) IF ( sts ) THEN' mask = cli.oob_mask.cli$l_old_mask IF ( mask .EQ. 0 ) THEN/ CALL STR$TRIM( buf, ' Control = (none)', ln) ELSE* CALL STR$TRIM( buf, ' Control = (', ln) pos = -1 DO WHILE ( pos .LT. 32 ): IF ( LIB$FFS( pos + 1, 32-(pos+1), mask, pos) ) THEN0 buf(ln+1:ln+1) = CHAR( pos + ICHAR('A') - 1 ) buf(ln+2:ln+2) = ',' ln = ln + 2 END IF END DOA buf(ln:ln) = ')' !change trailing comma to paren  END IF' mask = kNOWN_KEYS .AND. .NOT. mask IF ( mask .EQ. 0 ) THENH* CALL STR$TRIM( buf(ln+1:), ', NoControl = (none)',ltmp)* ln = ln + ltmp ELSE6 CALL STR$TRIM( buf(ln+1:), ', NoControl = (', ltmp) ln = ln + ltmp pos = -1 DO WHILE ( pos .LT. 32 ): IF ( LIB$FFS( pos + 1, 32-(pos+1), mask, pos) ) THEN0 buf(ln+1:ln+1) = CHAR( pos + ICHAR('A') - 1 ) buf(ln+2:ln+2) = ',' ln = ln + 2 END IF END DOA buf(ln:l n) = ')' !change trailing comma to paren END IF sts = Output( buf(:ln)) END IF XShow_Control = sts RETURN END !of XShow_Controlww`{Ւ$* XShow2.For -- routines for XSHOWH* Pat Rankin, 6/88* i*4 XShow_On ( )* i*4 XShow_Load_Average ( )* i*4 XShow_Default ( )* i*4 XShow_Day ( )*' INTEGER *4 FUNCTION XShow_On ( ) !4 ! Show the process's on-error/on-control_y state. ! implicit none C local: INTEGER *4 stsC functions: INTEGER *4 Output* sts = Output( ' ON not yet implemented') XShow_On = sts RETURN END !of XShow_On1 INTEGER *4 FUNCTION XShow_Load_Average ( ) !0 ! Show the system's approximate load average.> ! Requires that Kashtan's Load Averate driver be installed. ! implicit noneC constant:< INCLUDE '($IOdef)/nolist' !I/O function codes CHARACTER *(*) nO_LOAD_MSG PARAMETER ( nO_LOAD_MSG =H & ' (load average data not available)' )5 CHARACTER *(*) lAV_DEVICE !device nam e( PARAMETER ( lAV_DEVICE = '_LAV0:' )2 PARAMETER lAV_DATA_SIZE = 3*3*4, !36 bytes9 & lAV_DATA_MIN = 1*3*4 !12 bytes C local: CHARACTER line *44- INTEGER *2 ln, channel, iosb(4), ios INTEGER *4 sts0 REAL *4 load(3), prior(3), io_que(3),% & lav_data(3,3): EQUIVALENCE ( load, lav_data(1,1) ), !cpu loadJ & ( prior, lav_data(1,2) ), !blocking priorityM &  ( io_que, lav_data(1,3) ) !max i/o queue lengthC functions:% INTEGER *4 Cli_Present, Output& INTEGER *4 SYS$ASSIGN, SYS$QIOW) sts = SYS$ASSIGN( lAV_DEVICE, channel,,) IF ( sts ) THEN@ sts = SYS$QIOW(, %VAL(channel), %VAL(IO$_READVBLK), iosb,,,= & lav_data, %VAL(lAV_DATA_SIZE),,,,) IF ( sts ) sts = iosb(1)$ CALL SYS$DASSGN( %VAL(channel)) END IF) IF ( sts .AND. iosb(2) .GE. lAV_DATA_MIN, & .AND. load(1) .GT. 0.0001 ) THEN IF ( Cli_Present( 'FULL')7 & .AND. iosb(2) .EQ. lAV_DATA_SIZE ) THEN1 CALL Output( 'Approximate average system load')7 3 FORMAT ( 2X,A15,3(F8.2,X) ) !len=449 WRITE (line,'(2X,15X,3A9)') '1 min ','5 mins','15 mins' CALL Output( line)0 WRITE (line,3,IOSTAT=ios) 'cpu demand: ', load CALL Output( line)4 WRITE (line,3,IOSTAT=ios) 'ave. priority: ', prior CALL Output( line)5 WRITE (line,3,IOSTAT=ios) 'i/o queue len: ', io_que CALL Output( line) ELSE% WRITE (line,'(A,3F6.2)',IOSTAT=ios)/ & ' System load: ', load CALL STR$TRIM( line, line, ln) sts = Output( line(:ln)) END IF ELSE sts = Output( nO_LOAD_MSG) END IF XShow_Load_Average = sts RETURN END !of XShow_Load_Average, INTEGER *4 FUNCTION XShow_Default ( ) !3 ! Show the process's default device & directory.H ![*x Modified so that RMS will handle password if SYS$DISK has one. !+] !*E* Warning: no attempt is made to handle search lists; only the0* first element will be displayed.* implicit noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process infoA INCLUDE '($UAIdef)/nolist' !user authorization infoN*x INCLUDE '($LNMdef)/nolist' !logical name defs !+G INCLUDE '($FABdef)/nolist' !rms file access block !+= INCLUDE '($NAMdef)/nolist' !rms file name block3 INCLUDE 'f_inc:Itm.F' !item list; INCLUDE 'f_inc:Cli.F' !command line defsG BYTE fAB_PROTOTYPE(2) /FAB$C_BID,FAB$C_BLN/, !+N & nAM_PROTOTYPE(2) /NAM$C_BID,NAM$C_BLN/ !+ C local: RECORD /itmlst/ uai_list(3)G RECORD /fabdef/ fab !+G RECORD /namdef/ nam !+@ CHARACTER dev *40, dir *128, username *32, result *256< INTEGER *2 devlen, dirlen, usrnamlen, ln, len_wordG BYTE len_byte !+G EQUIVALENCE ( len_word, len_byte ) !+( LOGICAL show_user, need_concat INTEGER *4 stsC functions: INTEGER LIB$MATCH_COND) INTEGER *4 LIB$GETJPI, SYS$GETUAI,1 & !*x SYS$SETDDIR, SYS$TRNLNM,N & SYS$PARSE, !+4 & Cli_Present, Cli_Get_Value, & Output# INTRINSIC ICHAR, MIN, ZEXT% IF ( Cli_Present( 'USERNAME') ) THEN/C look up a user's (default = ours) CLI usrnamlen = 0: sts = Cli_Get_Value( 'USERNAME', username, usrnamlen)2 IF ( LIB$MATCH_COND( sts, CLI$_ABSENT) .GT. 01 & .OR. sts .AND. ( usrnamlen .EQ. 0F & .OR. username(:usrnamlen) .EQ. ' ' ) )H & sts = LIB$GETJPI( JPI$_USERNAME,,,, username, usrnamlen) IF ( sts ) THEN# uai_list(1).itm_length = LEN(dev)& uai_list(1).itm_code = UAI$_DEFDEV$ uai_list(1).itm_bufadr = %LOC(dev)' uai_list(1).itm_retlen = %LOC(devlen)# uai_list(2).itm_length = LEN(dir)& uai_list(2).itm_code = UAI$_DEFDIR$ uai_list(2).itm_bufadr = %LOC(dir)' uai_list(2).itm_retlen = %LOC(dirlen), uai_list(3).itm_code = ITM_K_END_OF_LIST8 sts = SYS$GETUAI(,, username(:usrnamlen), uai_list,,,) IF ( sts ) THEN@C convert from ASCIC (counted strings) to normal devlen = ICHAR(dev(1:1))B* devlen = MIN( IOR( devlen, '00FF'x), LEN(dev)) dev = dev(2:devlen+1) dirlen = ICHAR(dir(1:1))B* dirlen = MIN( IOR( dirlen, '00FF'x), LEN(dir)) dir = dir(2:dirlen+1) END IF END IF show_user = .TRUE. ELSE7C use this process's current device & directoryN*x sts = SYS$SETD DIR( %VAL(0), dirlen, dir) !retreive dir from RMS*x IF ( sts ) THEN1*x uai_list(1).itm_length = LEN(dev)4*x uai_list(1).itm_code = LNM$_STRING2*x uai_list(1).itm_bufadr = %LOC(dev)5*x uai_list(1).itm_retlen = %LOC(devlen):*x uai_list(2).itm_code = ITM_K_END_OF_LISTH*x sts = SYS$TRNLNM(, 'LNM$PROCESS', 'SYS$DISK',, uai_list)*x END IFN*x need_concat = .TRUE. !formatting: append dir to dev !+G CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !+G fab.fab$l_nam = %LOC(nam) !+G CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !+G nam.nam$b_nop = NAM$M_SYNCHK !syntax check only !+G result = ' ' !start w/ 2 leading blanks !+G nam.nam$l_esa = %LOC(result(2+1:)) !dest of expanded string !+G len_word = MIN( LEN(result)-2, '00FF'x) !(max==255) !+G nam.nam$b_ess = len_byte !size of exp str buffer !+G sts = SYS$PARSE( fab) !+G ln = 2 + nam.nam$b_node + nam.nam$b_dev + ZEXT(nam.nam$b_dir) !+G need_concat = .FALSE. !result contains dev//dir !+ show_user = .FALSE. END IF IF ( sts ) THEN IF ( show_user ) THEN/ CALL STR$TRIM( username, username, usrnamlen)8 CALL SYS$FAO( ' !AS''s default = !2(AS)', ln, result,2 & username(:usrnamlen),8 & dev(:devlen), dir(:dirlen))G ELSE IF ( need_concat ) THEN !*/ result = ' ' // dev(:devlen) // dir(:dirlen)" ln = LEN('__') + devlen + dirlen END IF sts = Output( result(:ln)) END IF XShow_Default = sts RETURN END !of XShow_Default( INTEGER *4 FUNCTION XShow_Day ( ) !? ! Show the system's primary/secondary accounting day status. ! implicit none C local: INTEGER *4 day, stsC functions: INTEGER X_Acc_Day INTEGER *4 Output day = 0 CALL X_Acc_Day( day) IF ( (day .AND. 3).EQ. 3 ) THEN sts = Output( 'SECONDARY') ELSE IF ( day .NE. 0 ) THEN sts = Output( 'PRIMARY') ELSE sts = Output( 'DEFAULT') END IF XShow_Day = sts RETURN END !of XShow_Dayww`?{Ւ .title XShow_DCL;H; Pat Rankin, 6/88; Routines for XShow.;; X_Ver ( flag.wb.r ); X_OutRate ( rate_wq_r )+; sts = X_Cli ( cliname.wt.dx [,len.ww.r] )J; sts = X_Prmpt ( prompt.wt.dx [,len.ww.r [,contin.wb.r [,carctl.ww.r]]] ); X_Msg ( flag.ww.r )+; X_Logins ( limit.ww.r, count.ww.r )!; X_WatchFile ( flag.ww_r ); X_Acc_Day ( flag.wb.r )M; val = Cmp_Quad ( a.rq.r, b.rq.r ) ;ret val: 0 (a=b), -1 (ab).; X_Parse_UIC ( string.rt.dx, uic.wl.r );2 .link "sys$system:DCLdef.Stb"/selective_search/ .link "sys$system:Sys.Stb"/selective_searchO .weak SYS$K_VERSION ;recompilation needed after VMS upgradeN .globl STR$COPY_R_R8 ;routine to copy string (ref to descr)7with_NOPs = 1 ;opcode for NOP: .psect _code, long, exe, rd, nowrt, pic, shr, gbl, con .subtitle XShow_Verify .entry X_Ver, ^m<> outflag = 43 clrl r0 ;clear work bufferC moval g^CTL$AG_CLIDATA, r1 ;pointer to start of cli data areaC moval @PPD$L_PRC(r1), r1 ;pointer to process permanent data ; verify=procedure2 bitw #PRC_M_VERIFY, - ;check verify bit) PRC_W_FLAGS(r1) ; in flags word beql 10$. bisb2 #<1@0>, r0 ;set bit zero10$: ; verify=image8 bitb #PRC_M_VERIMAGE, - ;check verify-image bit3 PRC_B_FLAGS2(r1) ; in secondary flags byte beql 20$- bisb2 #<1@1>, r0 ;set bit one 20$: ; done? movb r0, @(ap) ;store result in caller's byte ret ;end of X_Ver; .align long with_NOPs;; .subtitle XShow_Output_Rate .entry X_OutRate, ^m<> quadtime = 4C moval g^CTL$AG_CLIDATA, r1 ;pointer to start of cli data areaC moval @PPD$L_PRC(r1), r1 ;pointer to process permanent data ; fetch output flush rate5 movq PRC_Q_FLUSHTIME(r1), r0 ;quadword delta time; movq r0, @(ap) ;return result (unchecked) ret ;end of X_OutRate; .align long with_NOPs;; .subtitle XShow_Cli_Name .entry X_Cli, ^m cli_name = 4 clinamlen = 8D movab g^CTL$GT_CLINAME, r2 ;pointer to CLI name (ascic string)2 movzbl (r2)+, r1 ;length of string7 movaq @(ap), r0 ;descriptor for resultA pushr #^m ;-> note r1 (length) <-;1 jsb g^STR$COPY_R_R8 ;copy the stringD popr #^m ;restore registers (including r1). cmpb (ap), #2 ;got 2nd arg? blssu 10$? tstl (ap) ;does it look like an address? beql 10$E movw r1, @(ap) ;store length byte (not copy length)10$: ret ;end of X_Cli; .align long with_NOPs;; .subtitle XShow_Prompt .entry X_Prmpt, ^m prmpt_str = 4 prmpt_len = 8continue_chr = 12carr_cntrl = 16C moval g^CTL$AG_CLIDATA, r1 ;pointer to start of cli data areaC moval @PPD$L_PRC(r1), r1 ;pointer to process permanent dataF pushl PRC_B_PROMPTLEN(r1) ;length(b), carr_cntl(w), continue(b)F subb2 #3, (sp) ;don't count carr_cntl & continuation: movab PRC_G_PROMPT(r1), r2 ;address of prompt string9 movzbl (sp), r1 ;length of prompt string7 movaq @(ap), r0 ;descriptor for result pushr #^m1 jsb g^STR$COPY_R_R8 ;copy the string popr #^m. cmpb (ap), #2 ;got 2nd arg? blssu 50$? tstl (ap) ;does it look like an address? beql 30$E movzbw (sp), @(ap) ;store length byte (not copy length)30$:. cmpb (ap), #3 ;got 3rd arg? blssu 50$> tstl (ap) ;does it look like an address beql 40$G movb 3(sp), @(ap) ;return continuation character40$:. cmpb (ap), #4 ;got 4th arg? blssu 50$? tstl (ap) ;does it look like an address? beql 50$G movw 1(sp), @(ap) ;return carriage control chars50$: ret ;end of X_Prmpt; .align long with_NOPs;; .subtitle XShow_Message .entry X_Msg, ^m<> outflag = 4E movab g^CTL$GB_MSGMASK, r1 ;pointer to default protection word!4 movzbl (r1), r0 ;fetch message mask/ movb r0, @(ap) ;return result ret ;end of X_Msg; .align long with_NOPs;; .subtitle XShow_Login_Limit .entry X_Logins, ^m<>login_limit = 4login_count = 89 movzwl g^SYS$GW_IJOBLIM, r1 ;interactive login limitA movzwl g^SYS$GW_IJOBCNT, r0 ;current interactive login count/ movw r1, @(ap) ;return result, movw r0, @(ap) ; " " ret ;end of X_Logins;  .align long with_NOPs;; .subtitle XShow_Watch_File .entry X_WatchFile, ^m<> outflag = 4 clrl r0E movaw g^PIO$GW_DFPROT, r1 ;pointer to default protection word!> bicw3 #^xFF00, (r1), r0 ;low byte contains class mask; movw r0, @(ap) ;return result (unchecked) ret ;end of X_WatchFile; .align long with_NOPs;; .subtitle XShow_Day .entry X_Acc_Day, ^m<>:; note: does not assume that the two bits are adjacentB ; even though EXPLICITP is bit 20 and EXPLICITS is bit 21. outflag = 43 clrl r0 ;clear work bufferA movab g^EXE$V_EXPLICITP, r1 ;kludge to get value from linker; bbc r1, g^EXE$GL_FLAGS, 10$ ;check global system flags0 bisl2 #<1@0>, r0 ;set bit 0 (#1)H10$: movab g^EXE$V_EXPLICITS, r1 ;kludge to get value from linker; bbc r1, g^EXE$GL_FLAGS, 20$ ;check global system flags0 bisl2 #<1@1>, r0 ;set bit 1 (#2)F20$: movb r0, @(ap) ;store result in caller's byte ret ;end of X_Acc_Day; .align long with_NOPs;; .subtitle Compare_Quadwords .entry Cmp_Quad, ^marg1 = 4arg2 = 8? movq @(ap), r0 ;get 1st quadword into r0 & r1? movq @(ap), r2 ;get 2nd quadword into r2 & r37 cmpl r1, r3 ;compare high longword bgtr 10$ blss 20$6 cmpl r0, r2 ;compare low longword bgtru 10$ blssu 20$- clrl r0 ;arg1 = arg2 brb 30$10$:- movl #1, r0 ;arg1 > arg2 brb 30$20$:- mnegl #1, r0 ;arg1 < arg2; brb 30$30$:& ret ;done;; ;end of Cmp_Quad; .align long with_NOPs;; .page .subtitle XShow_UIC$TPADEF$LIBDEF.iif ndf SS$_NOSUCHID, $SSDEFE .globl LIB$TPARSE ;table-driven parsing routine $INIT_STATE tpa_table, tpa_dummy$STATEK$TRAN TPA$_IDENT ;identifier (more general than uic)$STATEA$TRAN TPA$_EOS, TPA$_EXIT ;end-of-string (all done)$STATEH$TRAN TPA$_LAMBDA, TPA$_FAIL ;anything (shouldn't reach here) $END_STATE) .entry X_Parse_UIC, ^m string = 4uic = 8; build argument block subl2 #TPA$C_LENGTH0, sp+ movc5 #0, (sp), #0, #TPA$C_LENGTH0, (sp)2 movl #TPA$K_COUNT0, TPA$L_COUNT(sp) ;re quired3 movq @string(ap), r0 ;string descriptor( movzwl r0, TPA$L_STRINGCNT(sp) ;length" movab (r1), TPA$L_STRINGPTR(sp)3; call lib$tparse( arg_blk, state_tbl, key_tbl)6 moval (sp), r1 ;pointer to arg block5 pushab tpa_dummy ;dummy keyword table- pushab tpa_table ;state table0 pushal (r1) ;argument block6 calls #3, g^LIB$TPARSE ;parse the uic string; return result5 movl TPA$L_NUMBER(sp ), @uic(ap) ;this is it!3 cmpl #LIB$_SYNTAXERR, r0 ;if 'syntax error' bneq 09$> movzwl #SS$_NOSUCHID, r0 ;then identifier wasn't found09$: ret ;end of X_Parse_UIC; .align long with_NOPs;; .end ;XSHOW_DCL.MARww [d{Ւ .title XShow_CPU;.; Display the CPU null time (XSHOW CPU).; Not valid for VMS V4.;@ .ident "V5.1" ;vms's version, not ours2 .link "sys$system:Sys.Stb"/selective_search .library "sys$library:Lib"J .weak SYS$K_VERSION ;rebuild recommended after upgradeF.globl Output ;write a record to sys$output: .noshow .nocross5 $CPUDEF ;cpu data structures7 $SYIDEF ;get-system-info codes $SSDEFL.globl SYS$FAO ;format something into string buffer8.globl SYS$GETSYIW ;get system info .cross .show;A TICK_TO_DELTA = ^d<-100000> ;10^-2 seconds -> -10^-7 seconds0 with_NOPs = 1 ;opcode for NOP;2 .psect _data, long, noexe, rd, wrt, pic, noshrCnow: .blkq 1 ;current time (quad format)@boottime: .blkq  1 ;cpu or system boot time>upquad: .blkq 1 ;cpu up time (derived)@idlequad: .blkq 1 ;cpu idle time (derived)Iuptime: .blkl 1 ;up time (ticks) for percent calcHidletime: .blkl 1 ;idle time (ticks) (from system)Apercent: .blkl 1 ;integer percent (0..100)Eper_frac: .blkl 1 ;percent's fraction ([.]0..9)Gfmt_buf: .blkb 64 ;b uffer to hold format for $fao?fmt_dsc: ;descriptor for fmt_buf3fmt_len: .blkw 1 ;dsc length2 .blkb 2 ;dsc type & classHfmt_adr: .blkl 1 ;dsc address (stored at runtime)@nodename: .blkq 1 ;descriptor for nodename;6 .psect _constant, long, noexe, rd, nowrt, pic, shrIout_fmt: .ascid " Uptime!13%D, null cpu!13%D, !3UB.!01ZB% idle " .align long.oth_fmt: .ascid "!AS CPU #!UB, down ";F; protect against mismatched VMS versions (ought to this better);M .if ndf SS$_NOLICENSE ;new status code introduced with V5.0!SMP$GL_CPUCONF:: .long 0!SMP$GL_ACTIVE_CPUS:: .long 0!SMP$GL_CPU_DATA:: .long 0 .endc;5 .psect _code, long, exe, rd, nowrt, pic, shr, gbl' .entry XShow_Cpu, ^m9; loop though all CPUs, displaying a message for each3 movl g^SMP$GL_CPUCONF, r2 ;cpu configuration@ movl g^SMP$GL_ACTIVE_CPUS, r3 ;flag indicating which are up pushl r2? calls #1, XCpu_Construct_Fmt ;make a format string for $fao02$:1 movzwl #1, r0 ;presume success< ffs #0, #32, r2, r4 ;find next cpu (r4 = 0..31) beql 09$/ bbs r4, r3, 06$ ;is it active?04$: pushl r4@ calls #1, XCpu_Display_Down ;if not, show alternate message brb 08$06$:B movl g^SMP$GL_CPU_DATA[r4], r1 ;get cpu's data structure7 movl CPU$L_NULLCPU(r1), idletime ;its null time: movq g^EXE$GQ_SYSTIME, now ;the current timeC movq CPU$Q_BOOT_TIME(r1), boottime ;cpu start time (absolute) bneq 07$B movq g^EXE$GQ_BOOTTIME, boottime ;system boot time instead07$:; calls #0, XCpu_Calc_Percent ;determine idle percentage' pushl r4 ;cpu #8 calls #1, XCpu_Display_Null ;format & output result08$:1 blbc r0, 09$  ;quit if problem> calls #0, XCpu_Adjust_Fmt ;blank out nodename after 1st9 bbsc r4, r2, 02$ ;clear flag bit and loop09$: ret ;end of XShow_Cpu; .align long with_NOPs;;%XCpu_Calc_Percent: .word ^m; calculate uptime movq now, r2 movq boottime, r0 subl r2, r0 sbwc r3, r1 movq r0, upquadD ediv #TICK_TO_DELTA, r0, r0, r1 ;convert delta to cpu ticks movl r0, uptime; compute percentage idle" emul #^d1000, idletime, #0, r0 ediv uptime, r0, r0, r1 clrl r1% ediv #^d10, r0, percent, per_frac; movzwl #1, r0 ret ;end of XCpu_Calc_Percent; .align long with_NOPs;;"XCpu_Display_Null: .word ^m4cpu = 4 ; p1 - cpu #C movl idletime, r0 ;number of 0.01 second clock ticksF emul #TICK_TO_DELTA, r0, - ;convert ticks to delta time quadword #0, idlequadL; allocate a short string on the stack and construct a descriptor for it subl2 #^d120, sp pushab (sp) movzwl #^d120, -(sp)< movaq (sp), r2 ;save address of descriptorO; sys$fao( &fmt_dsc, &buf.length, &buf, cpu#, &boottime, &quadtime, n%, n.): movzwl per_frac, -(sp) ;percent: fraction (0..9); movzwl percent, -(sp) ;percent: integer (0..100)+ pushaq idlequad ;null time( pushaq upquad ;uptime' pushl cpu(ap) ;cpu #= pushaq (r2)  ;descriptor of output buffer? pushaw (r2) ;word to receive output length= pushaq fmt_dsc ;descriptor of format string calls #8, g^SYS$FAO+ blbc r0, 15$ ; problem?; lib$put_output( &buf)5 pushaq (r2) ;result's descriptor calls #1, Output15$: ret ;end of XCpu_Display_Null; .align long with_NOPs;;+XCpu_Construct_Fmt: .word ^m4cpu = 4  ; p1 - cpu # clrq fmt_dsc moval fmt_buf, fmt_adr; get nodename& clrq -(sp) ;iosb movaq (sp), r21 clrq -(sp) ;end of itemlist clrq -(sp) moval (sp), r10 movw #8, (r1) ;size of buffer+ movw #SYI$_NODENAME, 2(r1) ;item code< movab fmt_buf, 4(r1) ;buffer to receive nodenameB movaw ^d12(r1), 8(r1) ;return length in end of itemlist<; sys$getqyiw( 0, NULL, NULL, &iteml ist, &iosb, NULL, 0)4 clrq -(sp) ;ast adr & ast parm& pushaq (r2) ;iosb* pushal (r1) ;itemlist4 clrq -(sp) ;csidadr & nodename( clrl -(sp) ;efn #03 calls #7, g^SYS$GETSYIW ;retreive nodename blbc r0, 24$- movzwl (r2), r0 ;iosb.status blbc r0, 24$4 movw ^d<-4>(r2), fmt_len ;length of nodename24$:: movq fmt_dsc, nodename ;copy nodename descriptor1 movab fmt_buf, r2 ;point to buffer? addw2 fmt_len, r2 ;move past nodename if present/; use shorter format for single cpu systemsD cmpl #1, cpu(ap) ;if only 1 cpu, don't include cpu # bgequ 26$C movl #^a" CPU", (r2)+ ;append literal text: " CPU #!UB," movw #^a" #", (r2)+/ movl #^a"!UB,", (r2)+ ;display cpu # brb 27$26$:: movw #^a"!+", (r2)+ ;skip parm (ignore cpu #)27$: movb #^a' ', (r2)+8 movc3 out_fmt, @out_fmt+4, (r2) ;copy rest of format movab fmt_buf, r26 subl2 r2, r3 ;calculate fmt length cvtlw r3, fmt_len movzwl #1, r0 ret ;XCpu_Construct_Fmt; .align long with_NOPs;;+XCpu_Adjust_Fmt: .word ^m4; blank out nodename (for 2nd & subsequent CPUs) movc5 #0, (sp), #^a' ', - nodename+0, @nodename+4 ret ;XCpu_Adjust_Fmt; .align long with_NOPs;;"XCpu_Display_Down: .word ^m4 cpu = 4 ; p1 - cpu #L; allocate a short string on the stack and construct a descriptor for it subl2 #^d80, sp pushab (sp) movzwl #^d80, -(sp)< movaq (sp), r2 ;save address of descriptor<; sys$fao( &oth_fmt, &buf.length, &buf, &nodename, cpu#)' pushl cpu(ap) ;cpu #5 pushaq nodename ;nodename descriptor= pushaq (r2) ;descriptor of output buffer? pushaw (r2)  ;word to receive output length= pushaq oth_fmt ;descriptor of format string calls #5, g^SYS$FAO blbc r0, 35$; lib$put_output( &buf)5 pushaq (r2) ;result's descriptor calls #1, Output35$: ret ;end of XCpu_Display_Down; .align long with_NOPs;; .end ;XShow_Cpuww@I>{Ւ PROGRAM XShoQue !A ! Pat Rankin, 5/88 ! SHOW QUEUE replacement. ! implicit none c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c local: LOGICAL sho_queues INTEGER *4 stsc functions:! INTEGER *4 Process_Command,J & XShow_Queues, !batch and/or print queuesQ & XShow_Forms_Chars, !defined forms or characteristicsB & XShow_Restart_Value !job restart value: sts = Process_Command() !process dcl command line IF ( sts ) THEN$ sts = 1 !SS$_NORMAL5c set up exit handler & clear $GETQUI context CALL XShoQue_Init( .FALSE.)& IF ( do_forms .OR. do_chars ) THEN8 IF ( do_forms ) sts = XShow_Forms_Chars( .TRUE.)9 IF ( do_chars ) sts = XShow_Forms_Chars( .FALSE.)* sho_queues = ( do_bat .OR. do_dev ) ELSE IF ( do_restart ) THEN" sts = XShow_Restart_Value() sho_queues = .FALSE. ELSE sho_queues = .TRUE. END IFc do the real work+ IF ( sho_queues ) sts = XShow_Queues()7c reset $GETQUI context and cancel exit handler CALL XShoQue_Finish( .TRUE.) END IF CALL EXIT( sts) END !of XShoQue(main). INTEGER *4 FUNCTION Process_Command ( ) !5 ! Retreive command line info & prepare it for use. !** V5 notes::* "/JOB_STATUS" changed to "/BY_JOB_STATUS",>* "/GENERIC" restored (but superceded by "/IF"),'* "/SUMMARY" implemented,M* explicit code for 'pending' added (previous kludge retained),-* code for suspended job added.* implicit nonec called by:* main XShoQuec constant:A INCLUDE '($QUIdef)/nolist' !Queue Information codesI INCLUDE '($JPIdef)/nolist' !Job & Process Information codesE INCLUDE '($SYIdef)/nolist' !System & Cluster Info codes= INCLUDE 'f_inc:Cli.F' !(private) cli codes c /deviceE PARAMETER dEVTYP_CNT = 4 !# of device type categories4 CHARACTER *8 devtyp_list(0:dEVTYP_CNT) / 'ALL',F & 'PRINTER', 'TERMINAL', 'SERVER', 'NONE' /4 PARAMETER dEV_PRINTER = 1, dEV_TERMINAL = 2,8 & dEV_SERVER = 4, dEV_NONE = 1282 I NTEGER *4 devtyp_values(0:dEVTYP_CNT) / -1,6 & dEV_PRINTER, dEV_TERMINAL,3 & dEV_SERVER, dEV_NONE /c /by_job_status@ PARAMETER jOB_STAT_CNT = 6 !# of status categories8 CHARACTER *10 job_stat_type(0:jOB_STAT_CNT) / 'ALL',? & 'EXECUTING', 'PENDING', 'WAITING',A & 'HOLDING', 'RETAINED', 'OTHER' /,B & job_stat_synonym(0:jOB_STAT_CNT) / 'ANY',E & 'PRINTING', ' ', 'AFTER', 'HELD', 2*' ' /PC note: suspended & pending added so V4 image will work correctly on V5.E PARAMETER qUI_M_JOB_SUSPENDED = '00000400'x !V5-E PARAMETER qUI_M_JOB_PENDING = '00000800'x !V5-$ INTEGER *4 qUI_M_JOB_EXE_mask,P & qUI_M_JOB_PEND_kludge, !**Also defined in Select_Job**!, & qUI_M_JOB_OTHER_mask< PARAMETER ( qUI_M_JOB_EXE_mask = QUI$M_JOB_EXECUTINGB & .OR. QUI$M_JOB_ABORTINGB & .OR. QUI$M_JOB_STARTINGD & .OR. QUI$M_JOB_RESTARTINGL & .OR. qUI_M_JOB_SUSPENDED !V5+LD & .OR. QUI$M_JOB_SUSPENDED !V5+ & ,S & qUI_M_JOB_PEND_kludge = '80000000'x !unused status bit!L & .OR. qUI_M_JOB_PENDING !V5+LD & .OR. QUI$M_JOB_PENDING !V5+ & )/ PARAMETER ( qUI_M_JOB_OTHER_mask = .NOT. (B & qUI_M_JOB_EXE_maskE & .OR. qUI_M_JOB_PEND_kludge? & .OR. QUI$M_JOB_TIMEDA & .OR. QUI$M_JOB_HOLDINGF & .OR. QUI$M_JOB_RETAINED ) )4 INTEGER *4 job_stat_mask(0:jOB_STAT_CNT) / -1,F & qUI_M_JOB_EXE_mask, qUI_M_JOB_PEND_kludge,B & QUI$M_JOB_TIMED, QUI$M_JOB_HOLDING,F & QUI$M_JOB_RETAINED, qUI_M_JOB_OTHER_mask / c /if> PARAMETER qUE_IF_CNT = 9 !# of "if" categories8 CHARACTER *14 que_if_type(0:qUE_IF_CNT) / 'ANYTHING',> & 'SOMETHING', 'AC TIVE', 'INACTIVE',F & 'EMPTY', 'NONEMPTY', 'NORMAL', 'ABNORMAL',4 & 'EXECUTION', 'GENERIC' /& PARAMETER iF_SOMETHING = '01'x,@ & iF_ACTIVE = '02'x, iF_INACTIVE = '04'x,@ & iF_EMPTY = '08'x, iF_NONEMPTY = '10'x,@ & iF_NORMAL = '20'x, iF_ABNORMAL = '40'x,E & iF_EXECUTION = '0080'x, iF_GENERIC = '0100'x0 INTEGER *4 que_if_mask(0:qUE_IF_CNT) / -1,) & iF_SOMETHING,3 & iF_ACTIVE, iF_INACTIVE,2 & iF_EMPTY, iF_NONEMPTY,3 & iF_NORMAL, iF_ABNORMAL,6 & iF_EXECUTION, iF_GENERIC / c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays1 DATA excl_list, excl_siz, excl_cnt /3*0/,8 & node_list, node_siz, node_cnt /3*0/,8 & user_list, user_siz, user_cnt /3 *0/,8 & entr_list, entr_siz, entr_cnt /3*0/,8 & que_list, que_siz, que_cnt /3*0/,7 & jbnm_list, jbnm_siz, jbnm_cnt /3*0/ c local:J CHARACTER nodename *256, !long enough for longest filenameP & our_username *32, !(max length is still 12 as of V4.7)P & our_node *16, !( " " " " 8 " " " )" & option *16 INTEGER *2 ln, optlen INTEGER width$ LOGICAL by_entry, need_all INTEGER *4 i4temp, idx,$ & sts, tmpstsc functions: INTEGER LIB$MATCH_COND; INTEGER *4 Cli_Present, Cli_Get_Value, Open_Output,7 & Get_Inp_List, Get_Inp_Element,: & Add_Inp_Element, Put_Inp_Element,8 & Parse_Node, Process_Entry_List,& & Parse_Keywords INTRINSIC INDEX option = ' ' optlen = 0Bc ('option' is used for XSHOW ENTRY & XSHOW RESTART_VALUE)/ sts = Cli_Get_Value( 'OPTION', option, optlen)# by_entry = ( optlen .GT. 0 .AND.@ & INDEX( 'ENTRY', option(:optlen)) .EQ. 1 )# do_restart = ( optlen .GT. 0 .AND.H & INDEX( 'RESTART_VALUE', option(:optlen)) .EQ. 1 )! do_bat = Cli_Present( 'BATCH')" do_dev = Cli_Present( 'DEVICE') devtyp_mask = -1 IF ( do_dev ) THEN7 devtyp_mask = Parse_Keywords( 'DEVICE', dEVTYP _CNT,P & devtyp_list, devtyp_list, !(no synonyms)6 & devtyp_values)A IF ( devtyp_mask .EQ. 0 .OR. devtyp_mask .EQ. dEV_NONE ) THEN do_dev = .FALSE.DC: ELSE IF ( devtyp_mask .EQ. (dEV_PRINTER .OR. dEV_TERMINAL>C: & .OR. dEV_SERVER) ) THEN,C: devtyp_mask = -1 !all END IF END IF do_all_full = .FALSE. do_que_full = .FALSE. do_job_full = . FALSE.! IF ( Cli_Present( 'FULL') ) THEN+ do_all_full = Cli_Present( 'FULL.ALL'). do_que_full = Cli_Present( 'FULL.QUEUES'), do_job_full = Cli_Present( 'FULL.JOBS') END IF! do_files = Cli_Present( 'FILES')! do_forms = Cli_Present( 'FORMS')+ do_chars = Cli_Present( 'CHARACTERISTICS')$ compress = Cli_Present( 'COMPRESS')$ all_jobs = Cli_Present( 'ALL_JOBS')@ any_job = ( ( Cli_Present( 'BY_JOB_STATUS') .AND. 1 ) .EQ. 0 )E do_summary = Cli_Present( 'SUMMARY')  !V5+7 IF ( LIB$MATCH_COND( do_job_full, CLI$_NEGATED) .GT. 0 & .OR. do_all_full .AND.E & LIB$MATCH_COND( do_que_full, CLI$_NEGATED) .EQ. 0 ) THEN do_que_full = .TRUE. END IF7 IF ( LIB$MATCH_COND( do_que_full, CLI$_NEGATED) .GT. 0 & .OR. do_all_full .AND.E & LIB$MATCH_COND( do_job_full, CLI$_NEGATED) .EQ. 0 ) THEN do_job_full = .TRUE. END IFE IF ( do_summary ) THEN !V5+E do_job_full = .FALSE. !V5+E do_files = .FALSE. !V5+E IF ( LIB$MATCH_COND( all_jobs, CLI$_NEGATED) .EQ. 0 ) !V5+L & all_jobs = .TRUE. !V5+E ELSE IF ( do_job_full !V5*L & .AND. LIB$MATCH_COND( do_files, CLI$_NEGATED) .EQ. 0 ) THEN !V5*E do_files = .TRUE. !V5*E END IF !V5+ batch_only = .FALSE. device_only = .FALSE.# IF ( ( do_bat .AND. .NOT. do_dev )B & .OR. LIB$MATCH_COND( do_dev, CLI$_NEGATED) .GT. 0 ) THEN batch_only = .TRUE.( ELSE IF ( ( do_dev .AND. .NOT. do_bat )G & .OR. LIB$MATCH_COND( do_bat, CLI$_NEGATED) .GT. 0 ) THEN device_only = .TRUE. END IF IF ( .NOT. any_job ) THEN6 job_status_mask = Parse_Keywords( 'BY_JOB_STATUS',H & jOB_STAT_CNT, job_stat_type,H & job_stat_synonym, job_stat_mask)7 any_job = ( job_status_mask .EQ. job_stat_mask(0) ) END IF& show_if_mask = -1 !set all bits IF ( by_entry ) THENIc for "XSHOW ENTRY", only show queues that have had jobs selected show_if_mask = iF_SOMETHING1 ELSE IF ( Cli_Present( 'IF_QUEUE_STATUS') ) THEN0c note: /if_queue_status supercedes /ifA show_if_mask = Parse_Key words( 'IF_QUEUE_STATUS', qUE_IF_CNT,Q & que_if_type, que_if_type, !(no synonyms)5 & que_if_mask)$ ELSE IF ( Cli_Present( 'IF') ) THEN2c note: /if supercedes /active & /generic4 show_if_mask = Parse_Keywords( 'IF', qUE_IF_CNT,Q & que_if_type, que_if_type, !(no synonyms)5 & que_if_mask) ELSE/c for compatability with other versions; IF ( Cli_Present( 'ACTIVE') ) show_if_mask = iF_ACTIVEE sts = Cli_Present( 'GENERIC') !(restore /generic for vms5) !V5+E IF ( sts ) THEN !V5+E show_if_mask = show_if_mask .OR. iF_GENERIC !set !V5+E show_if_mask = show_if_mask .AND. .NOT. iF_EXECUTION !clr !V5+E ELSE IF ( LIB$MATCH_COND( sts, CLI$_NEGATED) ) THEN !V5+E show_if_mask = show_if_mask .AND. .NOT. iF_GENERIC !clr !V5+E show_if_mask = show_if_mask .OR. iF_EXECUTION !set !V5+E END IF !V5+ END IF excl_cnt = 0$ IF ( Cli_Present( 'EXCLUDE') ) THENA sts = Get_Inp_List( 'EXCLUDE', excl_siz, excl_list, excl_cnt)) IF ( sts .AND. excl_cnt .LT. 0 ) THEN;* should prevent exclusions from being inverted excl_cnt = -excl_cnt END IF END IF que_cnt = 0" IF ( Cli_Present( 'QUEUE') ) THEN< sts = Get_Inp_List( 'QUEUE', que_siz, que_list, que_cnt)( IF ( sts .AND. que_cnt .LT. 0 ) THEN5c check for "xshow entry/queue=(-,que...)" IF ( by_entry ) THENLc command is "XSHOW ENTRY"; convert queue list to exclude list i4temp = excl_list excl_list= que_list que_list = i4temp i4temp = excl_siz excl_siz = que_siz que_siz = i4temp excl_cnt = -que_cnt que_cnt = 05 IF ( Add_Inp_Element( que_siz, que_list, 1, '*') )" &  que_cnt = 1 END IF END IFH* ELSE !(must have invoked via 'run' or foreign symbol)<* sts = Add_Inp_Element( que_siz, que_list, 1, '*')"* IF ( sts ) que_cnt = 1 END IF node_cnt = 0$ IF ( Cli_Present( 'ON_NODE') ) THENA sts = Get_Inp_List( 'ON_NODE', node_siz, node_list, node_cnt) ln = 00 IF ( node_cnt .EQ. 0 .OR. node_cnt .EQ. -1 )D & CALL LIB$GETSYI( SYI$_NODENAME, , our_node, ln, , ) IF ( node_cn t .EQ. 0 ) THEN-c if no node supplied, use our own5 sts = Add_Inp_Element( node_siz, node_list, 1,2 & our_node(:ln)) IF ( sts ) node_cnt = 1% ELSE IF ( node_cnt .EQ. -1 ) THEN@c if list consists of "-" then treat it as (-,'node')Hc replace first element of list (ie, "-") with our nodename; sts = Put_Inp_Element( node_cnt, %VAL(node_list), 1,2 & our_node(:ln)) END IFIc convert list into actual node names (rather than logical names) DO idx = 1, ABS(node_cnt)< CALL Get_Inp_Element( node_cnt, %VAL(node_list), idx,0 & nodename, ln); IF ( Parse_Node( nodename(:ln), nodename, ln) ) THEN5 IF ( ln .GT. 2 .AND. nodename(ln-1:ln) .EQ. '::' )" & ln = ln - 23 CALL Put_Inp_Element( node_cnt, %VAL(node_list),9 & idx, nodename(:ln)) END IF END DO4c generic queues aren't on any specific node IF ( node_cnt .GT. 0 ) THEN4 show_if_mask = show_if_mask .OR. iF_EXECUTION9 show_if_mask = show_if_mask .AND. .NOT. iF_GENERIC END IF END IF3 need_all = ( ( (show_if_mask .AND. iF_EMPTY).NE. 0? & .XOR.(show_if_mask .AND. iF_NONEMPTY).NE. 0 )( & .AND. .NOT. all_jobs ) user_cnt = 03 IF ( Cli_Present( 'USERNAME') .OR. need_all ) THEN all_jobs = .TRUE.A st s = Get_Inp_List('USERNAME', user_siz, user_list, user_cnt)J IF ( user_cnt .NE. 0 ) need_all = .FALSE. !don't force our username4 IF ( user_cnt .EQ. 0 .AND. .NOT. need_all ) THEN all_jobs = .FALSE.3 ELSE IF ( user_cnt .EQ. -1 .OR. need_all ) THEN@c if list consists of "-" then treat it as (-,'user') ln = 0> CALL LIB$GETJPI( JPI$_USERNAME, , , , our_username, ln)Fc replace first element of list (ie, "-") with our username4 IF ( Add_Inp_Element( user_cnt, user_list, 1,5 & our_username(:ln))0 & .AND. need_all ) user_cnt = 1 END IF END IF entr_cnt = 0" IF ( Cli_Present( 'ENTRY') ) THEN? sts = Get_Inp_List( 'ENTRY', entr_siz, entr_list, entr_cnt) IF ( entr_cnt .EQ. -1 ) THEN:c invalid--what entry are we trying to exclude?*$ ELSE IF ( entr_cnt .NE. 0 ) THEN; sts = Process_Entry_List( entr_cnt, %VAL(entr_list)) IF ( .NOT. sts ) THEN CALL PutMsg( 'XSHOW', sts, 0)# CALL Exit( sts .OR. '10000000'x) END IF END IF END IF jbnm_cnt = 0$ IF ( Cli_Present( 'JOBNAME') ) THENA sts = Get_Inp_List( 'JOBNAME', jbnm_siz, jbnm_list, jbnm_cnt) IF ( jbnm_cnt .EQ. -1 ) THEN<c invalid--what jobname are we trying to exclude? jbnm_cnt = 0 END IF END IF) sts = Open_Output( 'XShoQue.Lis', width) CALL Set_Margin( width) Process_Command = sts RETURN END !of Process_Command; INTEGER *4 FUNCTION Process_Entry_List( size, list ) !; ! Convert strings into integers. Overwrite the original? ! string descriptors with the values. Each string is eitherB ! a single number or a pair of numbers separated by '-' or ':'. ! implicit nonec called by:'* function Process_Commandc constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors STRUCTURE /dsc_or_range/ UNION MAP  RECORD /dsc/ descrip END MAP MAP INTEGER *4 low, high END MAP END UNION END STRUCTURE !dsc_or_range c input: INTEGER *4 sizec input/output: RECORD /dsc_or_range/ list(*) c local: RECORD /dsc_or_range/ work% INTEGER indx, pos, len_tmp! INTEGER *4 sts, low, highc functions:( INTEGER STR$COMPARE, LIB$INDEX INTEGER *4 STR$FREE1_DX,M & OTS$CVT_TI_L !convert text integer to long INTRINSIC ABSJ work.descrip.d_quad(1) = 0 !dsc: type = unspecified, class = unspecified sts = 1 indx = 0+ DO WHILE ( sts .AND. indx .LT. ABS(size) ) indx = indx + 12 work.descrip.d_len = list(indx).descrip.d_len2 work.descrip.d_adr = list(indx).descrip.d_adr low = 0 high = 0 IF ( indx .GT. 1@ & .OR. STR$COMPARE( work.descrip, '-') .NE. 0 ) THEN% pos = LIB$INDEX( work.descrip, ':')8 IF ( pos .EQ. 0 ) pos = LIB$INDEX( work.descrip, '-') IF ( pos .LE. 1 ) THEN8c single number (or negative => no good), sts = OTS$CVT_TI_L( work.descrip, low) high = low ELSEc range" len_tmp = work.descrip.d_len" work.descrip.d_len = pos - 1, sts = OTS$CVT_TI_L( work.descrip, low) IF ( sts ) THEN% work.descrip.d_len = len_tmp - pos0 work.descrip.d_adr = work.descrip.d_adr + pos* sts = OTS$CVT_TI_L( work.descrip, high) END IF END IF END IF work.low = low work.high = high7 IF ( list(indx).descrip.d_cls .EQ. DSC$K_CLASS_D ): & CALL STR$FREE1_DX( list(indx).descrip) list(indx).low = work.low list(indx).high = work.high END DO Process_Entry_List = sts RETURN END !of Process_Entry_List? INTEGER FUNCTION Search_Entry_List( size, list, target ) !: ! Search a (small) list of ranges for a specific value. ! implicit nonec called by:"* function Select_Job c input:* INTEGER *4 size, list(2,*), target c local: INTEGER indx, limit LOGICAL foundc functions: INTRINSIC ABS found = .FALSE. limit = ABS(size) indx = 0B IF ( size .LT. 0 ) indx = 1 !skip dummy first element/ DO WHILE ( indx .LT. limit .AND. .NOT. found ) indx = indx + 1( found = ( target .GE. list(1,indx)1 & .AND. target .LE. list(2,indx) ) END DO IF ( .NOT. found ) indx = 0! IF ( size .LT. 0 ) indx = -indx Search_Entry_List = indx RETURN END !of Search_Entry_List- LOGICAL FUNCTION Select_Queue( queue ) !@ ! Check a queue against various selection/rejection criteria. ! implicit nonec called by:$* function XShow_Queuesc constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions1 PARAMETER iF_ACTIVE = 2, iF_INACTIVE = 4,: & iF_NORMAL = 32, iF_ABNORMAL = 64,> & iF_EXECUTION = 128, iF_GENERIC = 256,; & dEV_PRINTER = 1, dEV_TERMINAL = 2,& & dEV_SERVER = 4$ INTEGER *4 qUI_M_ABNORMAL_MASK> PARAMETER ( qUI_M_ABNORMAL_MASK = .NOT.( QUI$M_QUEUE_IDLEG & .OR. QUI$M_QUEUE_LOWERCASED & .OR. QUI$M_QUEUE_REMOTEH & .OR. QUI$M_QUEUE_SERVER ) ) c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input:I RECORD /q_cmn/ queue !queue status, flags, name, node c local: LOGICAL skipc functions:< INTEGER Search_Inp_List !scan dynamic arrayO* ( active xor inactive !if neither or both, don't care about idlenessN* && active xor not idle )!skip if active & idle or inactive & not idle skip =( s how_if_mask .NE. -1: & .AND.( ( ( (show_if_mask .AND. iF_ACTIVE).NE. 0> & .XOR.(show_if_mask .AND. iF_INACTIVE).NE. 0 ): & .AND.( (show_if_mask .AND. iF_ACTIVE).NE. 0E & .XOR.(queue.status .AND. QUI$M_QUEUE_IDLE).EQ. 0 ) ): & .OR.( ( (show_if_mask .AND. iF_NORMAL).NE. 0> & .XOR.(show_if_mask .AND. iF_ABNORMAL).NE. 0 ): & .AND.( (show_if_mask .AND. iF_NORMAL).NE. 0H & .XOR.(queue.status .AND. qU I_M_ABNORMAL_MASK).EQ. 0 ) )= & .OR.( ( (show_if_mask .AND. iF_EXECUTION).NE. 0= & .XOR.(show_if_mask .AND. iF_GENERIC).NE. 0 )= & .AND.( (show_if_mask .AND. iF_EXECUTION).NE. 0G & .XOR.(queue.flags .AND. QUI$M_QUEUE_GENERIC).EQ. 0 ) ) & ) )F IF ( (queue.flags .AND. QUI$M_QUEUE_BATCH).EQ. 0 !device queue8 & .AND. devtyp_mask .NE. -1 .AND. .NOT. skip )F & skip =( ( (queue.flags .AND. QUI$M_QUEUE_TERMINAL).NE. 0C & .AND. (devtyp_mask .AND. dEV_TERMINAL).EQ. 0 )E & .OR. ( (queue.status .AND. QUI$M_QUEUE_SERVER).NE. 0A & .AND. (devtyp_mask .AND. dEV_SERVER).EQ. 0 )H & .OR. ( .TRUE. !don't hassle about assigned,generic,etcF & .AND. (queue.flags .AND. QUI$M_QUEUE_TERMINAL).EQ. 0E & .AND. (queue.status .AND. QUI$M_QUEUE_SERVER).EQ. 0LD & .AND. (queue.flags .AND. QUI$M_QUEUE_PRINTER).NE.0 !V5+D & .AND. (devtyp_mask .AND. dEV_PRINTER).EQ. 0 ) )( IF ( excl_cnt .GT. 0 .AND. .NOT. skip )@ & skip = Search_Inp_List( excl_cnt, %VAL(excl_list),H & queue.queue_name(:queue.quenamlen),3 & .TRUE.) .GT. 0G IF ( node_cnt .NE. 0 .AND. .NOT. skip ) !skip := absent .xor. reject@ & skip = Search_Inp_List( node_cnt, %VAL(node_list),G & queue.node_name(:queue.nodnamlen),3 & .TRUE.) .EQ. 0) & .XOR. node_cnt .LT. 0 Select_Queue = .NOT. skip RETURN END !of Select_Queue* LOGICAL FUNCTION Select_Job( job ) !> ! Check a job against various selection/rejection criteria. ! implicit nonec called by:<* function Show_Batch_Queue, Show_Device_Queuec constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions5 INTEGER *4 jSTAT_IGNORE, qUI_M_JOB_PEND_kludge7 PARAMETER ( jSTAT_IGNORE = QUI$M_JOB_INACCESSIBLE,W & qUI_M_JOB_PEND_kludge = '80000000'x ) !from Process_Command() c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /j_cmn/ job c local: LOGICAL skip INTEGER *4 jstatusc functions:4 INTEGER Search_Inp_List, Search_Entry_List IF ( any_job ) THEN skip = .FALSE. ELSE2 jstatus = job.status .AND. .NOT. jSTAT_IGNORE; IF ( jstatus .EQ. 0 ) jstatus = qUI_M_JOB_PEND_kludge6 skip = ( (jstatus .AND. job_status_mask) .EQ. 0 ) END IFG IF ( user_cnt .NE. 0 .AND. .NOT. skip ) !skip := absent .xor. reject? & skip = Search_Inp_List( user_cnt, %VAL(user_list),H & job.username(:job.usrnamlen),.TRUE.) & .EQ. 0( & .XOR. user_cnt .LT. 0G IF ( entr_cnt .NE. 0 .AND. .NOT. skip ) !skip := absent .xor. rejectA & skip = Search_Entry_List( entr_cnt, %VAL(entr_list),; & job.entry_num) .EQ. 0( & .XOR. entr_cnt .LT. 0G IF ( jbnm_cnt .NE. 0 .AND. .NOT. skip ) !skip := absent .xor. reject? & skip = Search_Inp_List( jbnm_cnt, %VAL(jbnm_list),H & job.job_name(:job.jobnamlen),.TRUE.) & .EQ. 0( & .XOR. jbnm_cnt .LT. 0 Select_Job = .NOT. skip RETURN END !of Select_JobL INTEGER FUNCTION Job_Category ( job ) !V5+E ! !V5+E ! Determine a job's category for summary display. !V5+E ! Based on "by_job_status" code from Process_Command(). !V5+E ! !V5+E implicit none  !V5+Lc called by: !V5+L* function Show_Batch_Queue, Show_Device_Queue !V5+Lc constant: !V5+E INCLUDE '($QUIdef)/nolist' !V5+E INCLUDE 'XShoQue_Def.F' !structure definitions !V5+E INTEGER *4 jSTAT_IGNORE !V5+E PARAMETER ( jSTAT_IGNORE = QUI$M_JOB_INACCESSIBLE ) !V5+E PARAMETER jOB_STAT_CNT = 6 !# of status categories !V5+Lc CHARACTER *10 job_stat_type(jOB_STAT_CNT) / !V5+Lc & 'EXECUTING', 'PENDING', 'WAITING', !V5+Lc & 'HOLDING', 'RETAINED', 'OTHER' /, !V5+Lc & job_stat_synonym(jOB_STAT_CNT) / !V5+Lc & 'PRINTING', ' ', 'AFTER', 'HELD', 2*' ' / !V5+E PARAMETER  qUI_M_JOB_SUSPENDED = '00000400'x !V5-E PARAMETER qUI_M_JOB_PENDING = '00000800'x !V5-E INTEGER *4 qUI_M_JOB_EXE_mask, !V5+P & qUI_M_JOB_PEND_kludge, !**Also defined in Select_Job**!L & qUI_M_JOB_OTHER_mask !V5+E PARAMETER ( qUI_M_JOB_EXE_mask = QUI$M_JOB_EXECUTING !V5+L & .OR. QUI$M_JOB_ABORTING  !V5+L & .OR. QUI$M_JOB_STARTING !V5+L & .OR. QUI$M_JOB_RESTARTING !V5+L & .OR. qUI_M_JOB_SUSPENDED !V5+LD & .OR. QUI$M_JOB_SUSPENDED !V5+L & , !V5+L & qUI_M_JOB_PEND_kludge = '80000000'x !V5-L &  .OR. qUI_M_JOB_PENDING !V5+LD & .OR. QUI$M_JOB_PENDING !V5+L & ) !V5+E PARAMETER ( qUI_M_JOB_OTHER_mask = .NOT. ( !V5+L & qUI_M_JOB_EXE_mask !V5+L & .OR. qUI_M_JOB_PEND_kludge !V5+L & .OR. QUI$M_JOB_TIMED !V5+L & .OR. QUI$M_JOB_HOLDING !V5+L & .OR. QUI$M_JOB_RETAINED ) ) !V5+E INTEGER *4 job_stat_mask(jOB_STAT_CNT) / !V5+L & qUI_M_JOB_EXE_mask, qUI_M_JOB_PEND_kludge, !V5+L & QUI$M_JOB_TIMED, QUI$M_JOB_HOLDING, !V5+L & QUI$M_JOB_RETAINED, qUI_M_JOB_OTHER_mask / !V5+Lc input: !V5+E RECORD /j_cmn/ job !V5+Lc local: !V5+E INTEGER result, cat_indx !V5+E INTEGER *4 jstatus !V5+ !V5+E jstatus = job.status .AND. .NOT. jSTAT_IGNORE !V5+E IF ( jstatus .EQ. 0 ) jstatus = qUI_M_JOB_PEND_kludge !V5+ !V5+E result = 0 !V5+E cat_indx = 0 !V5+E DO WHILE ( result .EQ. 0 .AND. cat_indx .LT. jOB_STAT_CNT ) !V5+E cat_indx = cat_indx + 1 !V5+E IF ( (jstatus .AND. job_stat_mask(cat_indx)).NE. 0 ) !V5+L & result = cat_indx !V5+E END DO !V5+E IF ( result .EQ. 0 ) result = jOB_STAT_CNT !'other' !V5+ !V5+E Job_Category = result !V5+E RETURN !V5+L END !of Job_Category !V5+? LOGICAL FUNCTION Select_Form_Char( item, form_vs_char ) !4 ! Check a form or characteristics against various9 ! selection/rejection criteria: /exclude on name, and ! /entry on number. ! implicit nonec called by:(* function Show_Forms_Charsc constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /frm_or_chr/ item LOGICAL form_vs_char c local: LOGICAL skipc functions:4 INTEGER Search_Inp_List, Search_Entry_List skip = .FALSE. , IF ( excl_cnt .GT. 0 ) !!.AND. .NOT. skip )@ & skip = Search_Inp_List( excl_cnt, %VAL(excl_list),= & item.name(:item.namlen),3 & .TRUE.) .GT. 0G IF ( entr_cnt .NE. 0 .AND. .NOT. skip ) !skip := absent .xor. rejectA & skip = Search_Entry_List( entr_cnt, %VAL(entr_list),9 & item.number) .EQ. 0( & .XOR. entr_cnt .LT. 0 Select_Form_Char = .NOT. skip RETURN END !of Select_Form_CharG INTEGER *4 FUNCTION Translate_Queue ( logname, q_name, qnamlen ) ! ! Validate queue name. ! implicit nonec called by:* main XShoQuec constant: INCLUDE '($QUIdef)/nolist'= INCLUDE 'f_inc:Itm.F' !item list structure c input: CHARACTER *(*) logname c output: CHARACTER *(*) q_name INTEGER *2 qnamlen c local: RECORD /itmlst/ q_lookup(3)9 CHARACTER *63 queuename !(max length is only 31) INTEGER *2 quenamlen, ln INTEGER *4 sts, iosb(2)c functions: INTEGER *4 SYS$GETQUIW INTRINSIC LEN ln = LEN(logname)- IF ( ln .GT. 1 .AND. logname(ln:ln) .EQ. ':'C & .AND. logname(ln-1:ln-1) .NE. ':' ) ln = ln - 1&c build item list for queue lookup q_lookup(1).itm_length = ln* q_lookup(1).itm_code = QUI$_SEARCH_NAME' q_lookup(1).itm_bufadr = %LOC(logname) q_lookup(1).itm_retlen = 0( q_lookup(2).itm_length = LEN(queuename)) q_lookup(2).itm_code = QUI$_QUEUE_NAME) q_lookup(2).itm_bufadr = %LOC(queuename)) q_lookup(2).itm_retlen = %LOC(quenamlen)+ q_lookup(3).itm_code = ITM_K_END_OF_LIST quenamlen = 03 sts = SYS$GETQUIW( , %VAL(QUI$_TRANSLATE_QUEUE), ,2 & %REF(q_lookup), iosb, ,) IF ( sts ) sts = iosb(1) IF ( sts ) THEN$c success: return the result; CALL STR$TRIM( q_name, queuename(:quenamlen), qnamlen) ELSE9c failure: just return a copy of the input string- CALL STR$TRIM( q_name, logname, qnamlen) END IF Translate_Queue = sts RETURN END !of Translate_Queue) SUBROUTINE XShoQue_Init ( wrapup ) !B ! Establish an exit handler to clear $getqui's contect (in case@ ! we don't finish completely). Also, execute it now to reset6 ! the context in case someone else didn't clear it. ! implicit nonec called by:* main XShoQuec 2nd entry:&* subroutine XShoQue_Finishc constant: INCLUDE '($QUIdef)/nolist' c input:6 LOGICAL wrapup !cleanup flag c local:. INTEGER *4 exit_reason, exit_handler(4)& SAVE exit_reason, exit_handlerc functions: INTEGER *4 SYS$GETQUIW EXTERNAL XShoQue_CleanUp exit_reason = 0( exit_handler(2) = %LOC(XShoQue_CleanUp)1 exit_handler(3) = 1 !one arg follows@ exit_handler(4) = %LOC(exit_reason) !arg required by system1 CALL SYS$DCLEXH( exit_handler) !declare handler**& ENTRY XShoQue_Finish ( wrapup ) !+ ! Clear context and cancel exit handler. !c called by:* main XShoQue CALL XShoQue_CleanUp( 1)@ IF ( wrapup ) CALL SYS$CANEXH( exit_handler) !cancel handler RETURN+ END !of XShoQue_Init & XShoQue_Finish5 INTEGER *4 FUNCTION XShoQue_CleanUp ( reason ) !+ ! Exit handler to clear $getqui context. ! implicit nonec called by:5* function XShoQue_Init, XShoQue_Finishc constant: INCLUDE '($QUIdef)/nolist' c input: INTEGER *4 reason c local: INTEGER *4 sts, iosb(2)c functions: INTEGER *4 SYS$GETQUIWc clear $getqui context@ sts = SYS$GETQUIW( , %VAL(QUI$_CANCEL_OPERATION), , 0, iosb, ,)!* IF ( sts ) sts = iosb(1) XShoQue_CleanUp = reason RETURN END !of XShoQue_CleanUpww t{Ւ,* XShoQue1.For -- routines for XSHOW QUEUEH* Pat Rankin, 5/88*+ INTEGER *4 FUNCTION XShow_Queues ( ) !4 ! Process one or more batch and/or device queues. ! implicit nonec called by:* main XShoQuec constant: INCLUDE '($QUIdef)/nolist'F INCLUDE '($JBCMSGdef)/nolist' !job controller message codes= INCLUDE 'f_inc:Cli.F' !(private) cli codes = INCLUDE 'f_inc:Itm.F' !item list structure? INCLUDE 'XShoQue_Def.F' !structure definitions c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c local:E RECORD /itmlst/ q_lookup(32) !V5* RECORD /q_cmn/ queue RECORD /q_bat/ batque RECORD /q_dev/ devque CHARACTER val *256 INTEGER *2 ln, p$ INTEGER *4 search_flags, idx,% & iosb(2), st sc functions:B INTEGER LIB$MATCH_COND !check condition value(s)L LOGICAL Select_Queue !check selection/rejection criteriaE INTEGER *4 Get_Inp_Element, !get item from dynamic arrayD & Translate_Queue, !validate queue nameF & SYS$GETQUIW !get queue informationc set up $getqui optionsJ search_flags = QUI$M_SEARCH_WILDCARD !triggers NOMOREQUE to break loop IF ( batch_on ly ) THEN7 search_flags = search_flags .OR. QUI$M_SEARCH_BATCH ELSE IF ( device_only ) THEN: search_flags = search_flags .OR. QUI$M_SEARCH_SYMBIONT END IF'c build item list for queue lookupI q_lookup(1).itm_length = 0 !length of user's queue name (set below)* q_lookup(1).itm_code = QUI$_SEARCH_NAME# q_lookup(1).itm_bufadr = %LOC(val)9 q_lookup(2).itm_length = ITM_S_LONGWORD !4+ q_lookup(2).itm_code = QUI$_SEARCH_FLAGS, q_lookup(2).itm_bufadr = %LOC(search_flags)/ q_lookup(3).itm_length = LEN(queue.queue_name)) q_lookup(3).itm_code = QUI$_QUEUE_NAME0 q_lookup(3).itm_bufadr = %LOC(queue.queue_name)/ q_lookup(3).itm_retlen = %LOC(queue.quenamlen)9 q_lookup(4).itm_length = ITM_S_LONGWORD !4* q_lookup(4).itm_code = QUI$_QUEUE_FLAGS+ q_lookup(4).itm_bufadr = %LOC(queue.flags)9 q_lookup(5).itm_length = ITM_S_LONGWORD !4+ q_lookup(5).itm_code = QUI$_QUEUE_STATUS, q_lookup(5).itm_bufadr = %LOC(queue .status). q_lookup(6).itm_length = LEN(queue.node_name)+ q_lookup(6).itm_code = QUI$_SCSNODE_NAME/ q_lookup(6).itm_bufadr = %LOC(queue.node_name)/ q_lookup(6).itm_retlen = %LOC(queue.nodnamlen)* q_lookup(7).itm_length = q_CHAR_MASK_SIZEJ q_lookup(7).itm_code = QUI$_CHARACTERISTICS !in case jobs are pending5 q_lookup(7).itm_bufadr = %LOC(queue.characteristics) p = 7/ IF ( do_que_full .OR. .NOT. device_only ) THENc device/full or batch- q_lookup(p+1).itm_length = ITM_S _LONGWORD1 q_lookup(p+1).itm_code = QUI$_BASE_PRIORITY8 q_lookup(p+1).itm_bufadr = %LOC(queue.base_priority) p = p + 1 END IF IF ( .NOT. device_only ) THENc batch queue items- q_lookup(p+1).itm_length = ITM_S_LONGWORD- q_lookup(p+1).itm_code = QUI$_JOB_LIMIT5 q_lookup(p+1).itm_bufadr = %LOC(batque.job_limit) p = p + 1 IF ( do_que_full ) THEN0 q_lookup(p+1).itm_length = ITM_S_LONGWORD2 q_lookup(p+1).itm_code = QUI$_CPU_DEFAU LT: q_lookup(p+1).itm_bufadr = %LOC(batque.cpu_default)0 q_lookup(p+2).itm_length = ITM_S_LONGWORD0 q_lookup(p+2).itm_code = QUI$_CPU_LIMIT: q_lookup(p+2).itm_bufadr = %LOC(batque.cpu_maximum)0 q_lookup(p+3).itm_length = ITM_S_LONGWORD0 q_lookup(p+3).itm_code = QUI$_WSDEFAULT8 q_lookup(p+3).itm_bufadr = %LOC(batque.wsdefault)0 q_lookup(p+4).itm_length = ITM_S_LONGWORD. q_lookup(p+4).itm_code = QUI$_WSQUOTA6 q_lookup(p+4).itm_b ufadr = %LOC(batque.wsquota)0 q_lookup(p+5).itm_length = ITM_S_LONGWORD/ q_lookup(p+5).itm_code = QUI$_WSEXTENT7 q_lookup(p+5).itm_bufadr = %LOC(batque.wsextent) p = p + 5 END IF END IF IF ( .NOT. batch_only ) THENc device queue items6 q_lookup(p+1).itm_length = LEN(devque.device_name)/ q_lookup(p+1).itm_code = QUI$_DEVICE_NAME7 q_lookup(p+1).itm_bufadr = %LOC(devque.device_name)5 q_lookup(p+1).itm_retlen = %LOC(devque.devnamlen )4 q_lookup(p+2).itm_length = LEN(devque.form_name)- q_lookup(p+2).itm_code = QUI$_FORM_NAME5 q_lookup(p+2).itm_bufadr = %LOC(devque.form_name)5 q_lookup(p+2).itm_retlen = %LOC(devque.frmnamlen)5 q_lookup(p+3).itm_length = LEN(devque.form_stock). q_lookup(p+3).itm_code = QUI$_FORM_STOCK6 q_lookup(p+3).itm_bufadr = %LOC(devque.form_stock)5 q_lookup(p+3).itm_retlen = %LOC(devque.frmstklen)9 q_lookup(p+4).itm_length = LEN(devque.assigned_queue)7 q_lookup (p+4).itm_code = QUI$_ASSIGNED_QUEUE_NAME: q_lookup(p+4).itm_bufadr = %LOC(devque.assigned_queue)5 q_lookup(p+4).itm_retlen = %LOC(devque.asnquelen) p = p + 4 IF ( do_que_full ) THEN: q_lookup(p+1).itm_length = LEN(devque.default_form)8 q_lookup(p+1).itm_code = QUI$_DEFAULT_FORM_NAME; q_lookup(p+1).itm_bufadr = %LOC(devque.default_form)8 q_lookup(p+1).itm_retlen = %LOC(devque.deffrmlen); q_lookup(p+2).itm_length = LEN(devque.default_stock) 9 q_lookup(p+2).itm_code = QUI$_DEFAULT_FORM_STOCK< q_lookup(p+2).itm_bufadr = %LOC(devque.default_stock)8 q_lookup(p+2).itm_retlen = %LOC(devque.defstklen)7 q_lookup(p+3).itm_length = LEN(devque.processor)0 q_lookup(p+3).itm_code = QUI$_PROCESSOR8 q_lookup(p+3).itm_bufadr = %LOC(devque.processor)8 q_lookup(p+3).itm_retlen = %LOC(devque.proceslen)5 q_lookup(p+4).itm_length = LEN(devque.library)< q_lookup(p+4).itm_code = QUI$_LIBRA RY_SPECIFICATION6 q_lookup(p+4).itm_bufadr = %LOC(devque.library)8 q_lookup(p+4).itm_retlen = %LOC(devque.libnamlen)3 q_lookup(p+5).itm_length = LEN(devque.reset)8 q_lookup(p+5).itm_code = QUI$_JOB_RESET_MODULES4 q_lookup(p+5).itm_bufadr = %LOC(devque.reset)7 q_lookup(p+5).itm_retlen = %LOC(devque.resetlen)0 q_lookup(p+6).itm_length = ITM_S_LONGWORD7 q_lookup(p+6).itm_code = QUI$_JOB_SIZE_MINIMUM9 q_lookup(p+6).itm_bufadr = %LOC(dev que.min_blocks)0 q_lookup(p+7).itm_length = ITM_S_LONGWORD7 q_lookup(p+7).itm_code = QUI$_JOB_SIZE_MAXIMUM9 q_lookup(p+7).itm_bufadr = %LOC(devque.max_blocks) p = p + 7LD q_lookup(p+1).itm_length = ITM_S_LONGWORD !V5+LD q_lookup(p+1).itm_code = QUI$_SYMBIONT_FLAGS !V5+LD q_lookup(p+1).itm_bufadr = %LOC(devque.symbiont_flags) !V5+LD p = p + 1  !V5+ END IF END IF IF ( do_que_full ) THEN- q_lookup(p+1).itm_length = ITM_S_LONGWORD- q_lookup(p+1).itm_code = QUI$_OWNER_UIC4 q_lookup(p+1).itm_bufadr = %LOC(queue.owner_uic)- q_lookup(p+2).itm_length = ITM_S_LONGWORD. q_lookup(p+2).itm_code = QUI$_PROTECTION4 q_lookup(p+2).itm_bufadr = %LOC(queue.prot_mask)4 q_lookup(p+3).itm_length = LEN(queue.gen_target)2 q_lookup(p+3).itm_code = QUI$_GENERIC_TARGET5 q_lookup(p+3).itm_bufadr = %LOC(queue. gen_target)4 q_lookup(p+3).itm_retlen = %LOC(queue.gentrglen) p = p + 3LD q_lookup(p+1).itm_length = LEN(queue.description) !V5+LD q_lookup(p+1).itm_code = QUI$_QUEUE_DESCRIPTION !V5+LD q_lookup(p+1).itm_bufadr = %LOC(queue.description) !V5+LD q_lookup(p+1).itm_retlen = %LOC(queue.dscriplen) !V5+LD p = p + 1 !V5+ END IF+ q_lookup(p+1).itm_code = ITM_K_END_OF_LIST0c loop through parameter list (queue names) sts = 1 DO idx = 1, que_cntc fetch next queue name@ CALL Get_Inp_Element( que_siz, %VAL(que_list), idx, val, ln). IF ( ln .GT. 1 .AND. val(ln:ln) .EQ. ':' ): & sts = Translate_Queue( val(:ln), val, ln)c update item listD q_lookup(1).itm_length = ln !length of user's queue name-c loop through queues that match name sts = 1 DO WHILE ( sts )c  clear old values8 CALL LIB$MOVC5( 0, %VAL(0), 0, q_CMN_SIZE, queue)9 CALL LIB$MOVC5( 0, %VAL(0), 0, q_BAT_SIZE, batque)9 CALL LIB$MOVC5( 0, %VAL(0), 0, q_DEV_SIZE, devque) c retreive queue infoC* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)7 sts = SYS$GETQUIW( , %VAL(QUI$_DISPLAY_QUEUE), ,9 & %REF(q_lookup), iosb, , )7 IF ( sts ) sts = iosb(1) !actual status IF ( .NOT. sts ) THEN5 IF ( LIB$MATCH_COND( sts, JBC$_NOMOREQUE) .EQ. 0 )4 & CALL PutMsg( 'XSHOW', sts, 0)4 sts = sts .OR. '10000000'x !message seen2 ELSE IF ( .NOT. Select_Queue( queue) ) THEN,C DO NOTHING--skip this queue< ELSE IF ( (queue.flags .AND. QUI$M_QUEUE_BATCH).NE. 0 & ) THEN( CALL Show_Batch_Queue( queue, batque) ELSE) CALL Show_Device_Queue( queue, devque) END IF END DO !until .not.stsH IF ( LIB$MATCH_COND( sts, JBC$_NOMOREQUE) .GT. 0 ) sts = 1 !success END DO !next idx XShow_Queues = sts RETURN END !of XShow_Queues= INTEGER *4 FUNCTION XShow_Forms_Chars ( form_vs_char ) ! ! xshow queue/forms [/full] ! xshow queue/characterics ! implicit nonec called by:* main XShoQuec constant: INCLUDE '($QUIdef)/nolist'F INCLUDE '($JBCMSGdef)/nolist' !job controller message codes= INCLUDE 'f_inc:Cli.F'  !(private) cli codes= INCLUDE 'f_inc:Itm.F' !item list structure? INCLUDE 'XShoQue_Def.F' !structure definitions c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: LOGICAL form_vs_char c local:3 RECORD /itmlst/ x_lookup(16) !item list:* RECORD /q_frm/ form !form dataD* RECORD /q_chr/ qchar !characteristic data= RECORD /frm_or_chr/ x !either form or char CHARACTER val *256 INTEGER *2 ln, p INTEGER disp_count2 INTEGER *4 search_flags, lookup_code, idx,% & iosb(2), stsc functions: INTEGER LIB$MATCH_COND! LOGICAL Select_Form_Char! INTEGER *4 Get_Inp_Element,# & SYS$GETQUIWc set up $getqui optionsJ search_flags = QUI$M_SEARCH_WILDCARD !triggers NOMORExxx to break loopMc  start item list with elements common to both forms and characteristicsE x_lookup(1).itm_length = 0 !length of user's parameter (set below)* x_lookup(1).itm_code = QUI$_SEARCH_NAME# x_lookup(1).itm_bufadr = %LOC(val)8 x_lookup(2).itm_length = ITM_S_LONGWORD !4+ x_lookup(2).itm_code = QUI$_SEARCH_FLAGS, x_lookup(2).itm_bufadr = %LOC(search_flags)% x_lookup(3).itm_length = LEN(x.name)I* x_lookup(3).itm_code = QUI$_xxx_NAME !(assigned below)& x_looku p(3).itm_bufadr = %LOC(x.name)( x_lookup(3).itm_retlen = %LOC(x.namlen)( x_lookup(4).itm_length = ITM_S_LONGWORDI* x_lookup(3).itm_code = QUI$_xxx_NUMBER !(assigned below)( x_lookup(4).itm_bufadr = %LOC(x.number) IF ( form_vs_char ) THEN# lookup_code = QUI$_DISPLAY_FORM7c additional item list entries for forms lookup+ x_lookup(3).itm_code = QUI$_FORM_NAME- x_lookup(4).itm_code = QUI$_FORM_NUMBER3 x_lookup(5).itm_length = LEN(x.form.stock_name) , x_lookup(5).itm_code = QUI$_FORM_STOCK4 x_lookup(5).itm_bufadr = %LOC(x.form.stock_name)3 x_lookup(5).itm_retlen = %LOC(x.form.stknamlen)4 x_lookup(6).itm_length = LEN(x.form.description)2 x_lookup(6).itm_code = QUI$_FORM_DESCRIPTION5 x_lookup(6).itm_bufadr = %LOC(x.form.description)3 x_lookup(6).itm_retlen = %LOC(x.form.descrplen) p = 6 IF ( do_all_full ) THEN0 x_lookup(p+1).itm_length = ITM_S_LONGWORD1 x_lookup(p+1).itm_code = QUI$_FOR M_FLAGS4 x_lookup(p+1).itm_bufadr = %LOC(x.form.flags)0 x_lookup(p+2).itm_length = ITM_S_LONGWORD2 x_lookup(p+2).itm_code = QUI$_FORM_LENGTH5 x_lookup(p+2).itm_bufadr = %LOC(x.form.length)0 x_lookup(p+3).itm_length = ITM_S_LONGWORD1 x_lookup(p+3).itm_code = QUI$_FORM_WIDTH4 x_lookup(p+3).itm_bufadr = %LOC(x.form.width)0 x_lookup(p+4).itm_length = ITM_S_LONGWORD6 x_lookup(p+4).itm_code = QUI$_FORM_MARGIN_TOP9 x_lookup(p+4).i tm_bufadr = %LOC(x.form.top_margin)0 x_lookup(p+5).itm_length = ITM_S_LONGWORD7 x_lookup(p+5).itm_code = QUI$_FORM_MARGIN_LEFT: x_lookup(p+5).itm_bufadr = %LOC(x.form.left_margin)0 x_lookup(p+6).itm_length = ITM_S_LONGWORD8 x_lookup(p+6).itm_code = QUI$_FORM_MARGIN_RIGHT; x_lookup(p+6).itm_bufadr = %LOC(x.form.right_margin)0 x_lookup(p+7).itm_length = ITM_S_LONGWORD9 x_lookup(p+7).itm_code = QUI$_FORM_MARGIN_BOTTOM< x_lookup(p+7) .itm_bufadr = %LOC(x.form.bottom_margin)3 x_lookup(p+8).itm_length = LEN(x.form.setup)9 x_lookup(p+8).itm_code = QUI$_FORM_SETUP_MODULES4 x_lookup(p+8).itm_bufadr = %LOC(x.form.setup)7 x_lookup(p+8).itm_retlen = %LOC(x.form.setuplen)8 x_lookup(p+9).itm_length = LEN(x.form.page_setup)9 x_lookup(p+9).itm_code = QUI$_PAGE_SETUP_MODULES9 x_lookup(p+9).itm_bufadr = %LOC(x.form.page_setup)8 x_lookup(p+9).itm_retlen = %LOC(x.form.pagsetlen) ! p = p + 9 END IF !full ELSE- lookup_code = QUI$_DISPLAY_CHARACTERISTIC?c specific item list entries for characteristics lookup5 x_lookup(3).itm_code = QUI$_CHARACTERISTIC_NAME7 x_lookup(4).itm_code = QUI$_CHARACTERISTIC_NUMBER p = 4 END IF+ x_lookup(p+1).itm_code = ITM_K_END_OF_LIST; disp_count = 0 !number of forms displayed"c loop through parameter list sts = 1 DO idx = 1, que_cnt8c get next form or character "istic (from command)@ CALL Get_Inp_Element( que_siz, %VAL(que_list), idx, val, ln)> x_lookup(1).itm_length = ln !length of param value5c loop through matching forms/characteristics sts = 1 DO WHILE ( sts )c clear old values9 CALL LIB$MOVC5( 0, %VAL(0), 0, FRM_or_CHR_SIZE, x)c retreive form infoC* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)0 sts = SYS$GETQUIW( , %VAL(lookup_code), ,9 & # %REF(x_lookup), iosb, , ) IF ( sts ) sts = iosb(1) IF ( .NOT. sts ) THEN- IF ( LIB$MATCH_COND( sts, JBC$_NOMOREFORM,D & JBC$_NOMORECHAR) .EQ. 0 )4 & CALL PutMsg( 'XSHOW', sts, 0)4 sts = sts .OR. '10000000'x !message seen2 ELSE IF ( .NOT. Select_Form_Char( x) ) THEN=C DO NOTHING--skip this form or characteristic ELSE6 IF ( disp_count .EQ. 0 ) $!need title?N & CALL Forms_Chars_Title( form_vs_char) !display title: disp_count = disp_count + 1 !increment count IF ( form_vs_char ) THEN7 CALL Show_QForm( x.form) !display form ELSEA CALL Show_QChar( x.qchar) !display characteristic END IF END IF END DO !until .not.sts. IF ( LIB$MATCH_COND( sts, JBC$_NOMOREFORM,P & JBC$_NOMORECHAR) .GT. 0 ) sts = 1 !success% END DO !next idx@ IF ( disp_count .GT. 0 .AND. .NOT. compress ) CALL Output(' ') XShow_Forms_Chars = sts RETURN END !of XShow_Forms_Chars% SUBROUTINE Show_QForm ( form ) ! ! Display a form. ! implicit nonec called by:(* function Show_Forms_Charsc constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions? CHARACTER *6 margin_type(4) /'TOP','LEFT','RIGHT','BOTTOM'/? INTEGER *&2 martyplen(4) / 3 , 4 , 5 , 6 / c global: INCLUDE 'XShoQue.F' c input: RECORD /q_frm/ form c local:7 CHARACTER buffer *280, form_stock *80, fmt *20# INTEGER *2 buflen, ln, flen INTEGER *4 fflags INTEGER i, save_indentc functions: INTEGER Set_Indent( CALL STR$TRIM( fmt, '!32AS !6SL', flen)@ CALL STR$TRIM( form_stock, form.form_name(:form.frmnamlen), ln)3 IF ( form.stknamlen .GT. 0 .AND. .NOT. do_all '_full2 & .AND. form.stock_name(:form.stknamlen)9 & .NE. form.form_name(:form.frmnamlen) ) THEN# form_stock(ln+1:) = ' (stock='H & // form.stock_name(:form.stknamlen) // ')': ln = ln + LEN('_(stock=') + form.stknamlen + LEN(')')R IF ( ln .GT. 32 ) !note: 2nd line needs 2 leading spaces to match indentationE & CALL STR$TRIM( fmt, '!AS -!/ !32 !6SL', flen) END IF* CALL SYS$FAO( fmt(:flen), buflen, buffer,> ( & form_stock(:ln), %VAL(form.form_number) ) save_indent = Set_Indent( 2) IF ( .NOT. do_all_full ) THEN CALL BufOut( buffer(:buflen)G & // ' ' // form.description(:form.descrplen), 3) ELSE !do_all_full< CALL BufOut( buffer(:buflen), 3) !show name & number CALL Set_Indent( 6 - 1): CALL Fmt_Strings( form.description, form.descrplen, 1,+ & buffer, buflen)6 CALL BufOut( ' /DESCRIPTION='//buffer(:buflen)), 0) IF ( form.stknamlen .GT. 0 )( & CALL BufOut( ' /STOCK='D & // form.stock_name(:form.stknamlen), 0)1 CALL SYS$FAO( ' /LENGTH=!SL', buflen, buffer,+ & %VAL(form.length) )$ CALL BufOut( buffer(:buflen), 0)0 CALL SYS$FAO( ' /WIDTH=!SL', buflen, buffer,* & %VAL(form.width) )$ CALL BufOut( buffer(:buflen), 0)> IF ( form.top_margin .NE. 0 .OR. form.bottom_margin .NE. 0E & .OR. fo *rm.left_margin .NE. 0 .OR. form.right_margin .NE. 0 & ) THEN3 CALL STR$TRIM( buffer, ' /MARGIN=(', buflen) DO i = 1, 4$ IF ( form.margin(i) .NE. 0 ) THEN6c add margin value and trailing comma6 CALL SYS$FAO( '!AS=!SL,', ln, buffer(buflen+1:),? & margin_type(i)(:martyplen(i)),7 & %VAL(form.margin(i)) ) buflen = buflen + ln END IF END DOD buffer(buflen:buflen) + = ')' !change last comma to paren' CALL BufOut( buffer(:buflen), 4) END IF fflags = form.flags; IF ( (fflags .AND. QUI$M_FORM_SHEET_FEED) .NE. 0 ) THEN& CALL BufOut( ' /SHEET_FEED', 0)?c- fflags = fflags .AND. .NOT. QUI$M_FLAG_SHEET_FEED END IFMc note: WRAP+TRUNCATE is illogical but we'll show both if indicated5 IF ( (fflags .AND. QUI$M_FORM_WRAP) .NE. 0 ) THEN CALL BufOut( ' /WRAP', 0)9c- fflags = fflags .A,ND. .NOT. QUI$M_FLAG_WRAP> ELSE IF ( (fflags .AND. QUI$M_FORM_TRUNCATE) .EQ. 0 ) THEN" CALL BufOut( ' /NOWRAP', 0)& CALL BufOut( ' /NOTRUNCATE', 0) END IF9 IF ( (fflags .AND. QUI$M_FORM_TRUNCATE) .NE. 0 ) THEN$ CALL BufOut( ' /TRUNCATE', 0)=c- fflags = fflags .AND. .NOT. QUI$M_FLAG_TRUNCATE END IF IF ( form.setuplen .GT. 0 )) & CALL BufOut( ' /SETUP=('E & // form.setup(:form.setuplen) // ')', 4) - IF ( form.pagsetlen .GT. 0 ). & CALL BufOut( ' /PAGE_SETUP=('H & // form.page_setup(:form.pagsetlen)//')',4) CALL Buf_Flush( 0) END IF CALL Set_Indent( save_indent) RETURN END !of Show_QForm& SUBROUTINE Show_QChar ( qchar ) ! ! Display a characterictic. ! implicit nonec called by:(* function Show_Forms_Charsc constant:? INCLUDE 'XShoQue_Def.F' !structure definition.s c input: RECORD /q_chr/ qchar c local: CHARACTER *48 buffer INTEGER *2 buflen INTEGER save_indentc functions: INTEGER Set_Indent, CALL SYS$FAO( '!32AS !6SL', buflen, buffer,7 & qchar.char_name(:qchar.chrnamlen),. & %VAL(qchar.char_number) ) save_indent = Set_Indent( 2)! CALL BufOut( buffer(:buflen), 3) CALL Set_Indent( save_indent) RETURN END !of Show_QChar4 SUBROUTINE Fo/rms_Chars_Title ( form_vs_char ) !0 ! Label the forms or characteristics display. ! implicit nonec called by:(* function Show_Forms_Chars c global:> INCLUDE 'XShoQue.F' !for 'compress','do_all_full' c input: LOGICAL form_vs_char c local:% CHARACTER title *160, fmt *64 INTEGER *2 tlen, flen INTEGER save_indentc functions: INTEGER Set_Indent IF ( form_vs_char ) THEN IF ( compress ) 0THEN< CALL STR$TRIM( fmt, ' !32
!6AS !AS!+'," & flen)& ELSE IF ( .NOT. do_all_full ) THEN CALL STR$TRIM( fmt,H & 'Print Forms!/ !32 !6AS !AS!/ !32<----!> !6*- !AS'," & flen) ELSE CALL STR$TRIM( fmt,H & 'Print Forms!/ !32 !6AS!+!/ !32<----!> !6*-!+'," & flen) END IF ELSE !is_char IF ( compress ) THEN CALL STR$T1RIM( fmt,D & ' !32 !6AS!+!+'," & flen) ELSE CALL STR$TRIM( fmt,H &'Queue Characteristics!/ !32 !6AS!+!/ !32<----!> !6*-!+'," & flen) END IF END IF' CALL SYS$FAO( fmt(:flen), tlen, title,< & 'Number', 'Description', '-----------') save_indent = Set_Indent( 0) CALL BufOut( title(:tlen), 3) CALL Set_Indent( save_indent) RETURN 2 END !of Forms_Chars_Title2 INTEGER *4 FUNCTION XShow_Restart_Value ( ) ! ! xshow restart_value ! implicit nonec called by:* main XShoQuec constant: INCLUDE '($QUIdef)/nolist'F INCLUDE '($JBCMSGdef)/nolist' !job controller message codesD* INCLUDE 'f_inc:Cli.F' !(private) cli codes= INCLUDE 'f_inc:Itm.F' !item list structure? INCLUDE 'XShoQue_Def.F' !structure defini3tions c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c local: RECORD /itmlst/ j_lookup(3)$ CHARACTER val *256, buf *300 INTEGER *2 ln, buflen INTEGER *4 search_flags,% & iosb(2), stsc functions: INTEGER Fmt_Strings,& & LIB$MATCH_COND INTEGER *4 SYS$GETQUIWc set up $getqui optionsA search_flags = QUI$M_SEARCH_THIS_JOB !(only works from batch)%c 4 build item list for job lookup9 j_lookup(1).itm_length = ITM_S_LONGWORD !4+ j_lookup(1).itm_code = QUI$_SEARCH_FLAGS, j_lookup(1).itm_bufadr = %LOC(search_flags)" j_lookup(2).itm_length = LEN(val). j_lookup(2).itm_code = QUI$_CHECKPOINT_DATA# j_lookup(2).itm_bufadr = %LOC(val)" j_lookup(2).itm_retlen = %LOC(ln)+ j_lookup(3).itm_code = ITM_K_END_OF_LISTc retreive job info=* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)/ sts = SYS$GETQUIW( , %V 5AL(QUI$_DISPLAY_JOB), ,3 & %REF(j_lookup), iosb, , )5 IF ( sts ) sts = iosb(1) !real status IF ( .NOT. sts ) THEN; IF ( LIB$MATCH_COND( sts, JBC$_NOSUCHJOB) .GT. 0 ) THEN> CALL Output( ' (only batch jobs have restart values)') ELSE$ CALL PutMsg( 'XSHOW', sts, 0) END IF5 sts = sts .OR. '10000000'x !message seen ELSE7 IF ( Fmt_Strings( val, ln, 1, buf, buflen) .EQ. 0 )2 & CALL STR$TRIM( buf, '""', buflen) CALL Output( buf(:buflen) ) END IF XShow_Restart_Value = sts RETURN! END !of XShow_Restart_Valueww72{Ւ,* XShoQue2.For -- routines for XSHOW QUEUEH* Pat Rankin, 5/88*< INTEGER *4 FUNCTION Show_Batch_Queue ( queue, bat_q ) !E ! Display batch queue header and process the jobs contained in it. ! implicit nonec called by:$* function XShow_Queuesc constant: INCLUDE '($QUIdef)/nolist'F INCLUDE '($JBCMSGdef)/nolist' !job controller message codes= INCLUDE 'f_inc:Itm.F' 8 !item list structure? INCLUDE 'XShoQue_Def.F' !structure definitionsE PARAMETER jOB_STAT_CNT = 6 !# of status categories !V5+" PARAMETER iF_SOMETHING = 1,7 & iF_EMPTY = 8, iF_NONEMPTY = 16 c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /q_cmn/ queue RECORD /q_bat/ bat_q c local:E RECORD /itmlst/ j_lookup(32) !V5* R9ECORD /j_cmn/ job RECORD /j_bat/ bat RECORD /j_str/ str INTEGER p, p_i,0 & disp_count, skip_count,L & job_count(jOB_STAT_CNT) !V5+ LOGICAL defer INTEGER *4 search_flags,% & iosb(2), stsc functions: LOGICAL Select_JobE INTEGER Job_Category !V5+ INTEGER LIB$MATCH_COND INTEGER *4 SYS$GETQUIWE IF :( do_summary ) THEN !V5+E DO p_i = 1, jOB_STAT_CNT !V5+E job_count(p_i) = 0 !V5+E END DO !V5+E defer = .TRUE. !V5+E ELSE !V5+" defer = ( show_if_mask .NE. -1? & .AND. ( ( (show_if_mask ;.AND. iF_EMPTY).NE. 0D & .XOR. (show_if_mask .AND. iF_NONEMPTY).NE. 0 )E & .OR. (show_if_mask .AND. iF_SOMETHING).NE. 0 ) )E END IF !V5+c display the queue header< IF ( .NOT. defer ) CALL Display_Batch_Queue( queue, bat_q))c set up item list for scanning jobs search_flags = 06 IF ( all_jobs ) search_flags = QUI$M_SEARCH_ALL_JOBS3 j_lookup(1).itm_length = ITM_S_LONGWORD < !4+ j_lookup(1).itm_code = QUI$_SEARCH_FLAGS, j_lookup(1).itm_bufadr = %LOC(search_flags)( j_lookup(2).itm_length = ITM_S_LONGWORD+ j_lookup(2).itm_code = QUI$_ENTRY_NUMBER- j_lookup(2).itm_bufadr = %LOC(job.entry_num)4 j_lookup(3).itm_length = LEN(job.job_name) !39' j_lookup(3).itm_code = QUI$_JOB_NAME, j_lookup(3).itm_bufadr = %LOC(job.job_name)- j_lookup(3).itm_retlen = %LOC(job.jobnamlen)4 j_lookup(4).itm_length = LEN(job.username) !12' j_lookup(4).itm_code = QU =I$_USERNAME, j_lookup(4).itm_bufadr = %LOC(job.username)- j_lookup(4).itm_retlen = %LOC(job.usrnamlen)( j_lookup(5).itm_length = ITM_S_LONGWORD( j_lookup(5).itm_code = QUI$_JOB_FLAGS) j_lookup(5).itm_bufadr = %LOC(job.flags)( j_lookup(6).itm_length = ITM_S_LONGWORD) j_lookup(6).itm_code = QUI$_JOB_STATUS* j_lookup(6).itm_bufadr = %LOC(job.status)3 j_lookup(7).itm_length = ITM_S_QUADWORD !8) j_lookup(7).itm_code = QUI$_AFTER_TIME. j_lookup(7).itm_bufadr = %LOC(job.after_t >ime)( j_lookup(8).itm_length = ITM_S_LONGWORD/ j_lookup(8).itm_code = QUI$_INTERVENING_JOBS0 j_lookup(8).itm_bufadr = %LOC(job.intrvng_jobs): j_lookup(9).itm_length = ITM_S_LONGWORD * cMPLTN_VCTR_SIZ/ j_lookup(9).itm_code = QUI$_CONDITION_VECTOR0 j_lookup(9).itm_bufadr = %LOC(job.compltn_stat)( j_lookup(10).itm_length= ITM_S_LONGWORD& j_lookup(10).itm_code = QUI$_JOB_PID+ j_lookup(10).itm_bufadr= %LOC(bat.job_pid)* j_lookup(11).itm_length= q_CHAR_MASK_SIZEF j_lookup(11).itm_code = ?QUI$_CHARACTERISTICS !in case it's pending3 j_lookup(11).itm_bufadr= %LOC(job.characteristics) p = 11 IF ( do_job_full ) THEN2 j_lookup(p+1).itm_length = ITM_S_QUADWORD !83 j_lookup(p+1).itm_code = QUI$_SUBMISSION_TIME4 j_lookup(p+1).itm_bufadr = %LOC(job.submit_time)2 j_lookup(p+2).itm_length = ITM_S_LONGWORD !4, j_lookup(p+2).itm_code = QUI$_PRIORITY1 j_lookup(p+2).itm_bufadr = %LOC(job.priority)/ j_lookup(p+3).itm_length = LEN(bat.logfile)5 j_look @up(p+3).itm_code = QUI$_LOG_SPECIFICATION0 j_lookup(p+3).itm_bufadr = %LOC(bat.logfile)2 j_lookup(p+3).itm_retlen = %LOC(bat.logfillen)3 j_lookup(p+4).itm_length = LEN(bat.print_queue)- j_lookup(p+4).itm_code = QUI$_LOG_QUEUE4 j_lookup(p+4).itm_bufadr = %LOC(bat.print_queue)2 j_lookup(p+4).itm_retlen = %LOC(bat.prtquelen)2 j_lookup(p+5).itm_length = ITM_S_LONGWORD !4- j_lookup(p+5).itm_code = QUI$_CPU_LIMIT0 j_lookup(p+5).itm_bufadr = %LOC(bat.cputime)- A j_lookup(p+6).itm_length = ITM_S_LONGWORD- j_lookup(p+6).itm_code = QUI$_WSDEFAULT2 j_lookup(p+6).itm_bufadr = %LOC(bat.wsdefault)- j_lookup(p+7).itm_length = ITM_S_LONGWORD+ j_lookup(p+7).itm_code = QUI$_WSQUOTA0 j_lookup(p+7).itm_bufadr = %LOC(bat.wsquota)- j_lookup(p+8).itm_length = ITM_S_LONGWORD, j_lookup(p+8).itm_code = QUI$_WSEXTENT1 j_lookup(p+8).itm_bufadr = %LOC(bat.wsextent)+ j_lookup(p+9).itm_length = LEN(bat.cli)' j_lookup(p+9).itm_ Bcode = QUI$_CLI, j_lookup(p+9).itm_bufadr = %LOC(bat.cli)/ j_lookup(p+9).itm_retlen = %LOC(bat.clilen) p = p + 91 DO p_i = 1, 8 !eight parameter strings; j_lookup(p+p_i).itm_length = LEN(str.parameter(p_i))> j_lookup(p+p_i).itm_code = QUI$_PARAMETER_1 + p_i - 1< j_lookup(p+p_i).itm_bufadr = %LOC(str.parameter(p_i)); j_lookup(p+p_i).itm_retlen = %LOC(str.parm_len(p_i)) END DO p = p + 81 j_lookup(p+1).itm_length = LEN(str.bat_c Chkpt)3 j_lookup(p+1).itm_code = QUI$_CHECKPOINT_DATA2 j_lookup(p+1).itm_bufadr = %LOC(str.bat_chkpt)1 j_lookup(p+1).itm_retlen = %LOC(str.chkptlen) p = p + 1LD j_lookup(p+1).itm_length = LEN(str.restart_queue) !V5+LD j_lookup(p+1).itm_code = QUI$_RESTART_QUEUE_NAME !V5+LD j_lookup(p+1).itm_bufadr = %LOC(str.restart_queue) !V5+LD j_lookup(p+1).itm_retlen = %LOC(str.rstrtlen) !V5+LD p D = p + 1 !V5+ END IFLD j_lookup(p+1).itm_length = ITM_S_LONGWORD !4 !V5+LD j_lookup(p+1).itm_code = QUI$_PENDING_JOB_REASON !V5+LD j_lookup(p+1).itm_bufadr = %LOC(job.pend_reason) !V5+LD p = p + 1 !V5++ j_lookup(p+1).itm_code = ITM_K_END_OF_LIST disp_count = 0 skip_count = 0c loop through the jobs sts E = 1 DO WHILE ( sts )c reset old values3 CALL LIB$MOVC5( 0, %VAL(0), 0, j_CMN_SIZE, job)3 CALL LIB$MOVC5( 0, %VAL(0), 0, j_BAT_SIZE, bat)C IF ( do_job_full ) !+: & CALL LIB$MOVC5( 0, %VAL(0), 0, j_STR_SIZE, str)c retreive job info@* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)2 sts = SYS$GETQUIW( , %VAL(QUI$_DISPLAY_JOB), ,5 & %REF(j_lookup), iosb, ,) IF ( s Fts ) sts = iosb(1) IF ( .NOT. sts ) THEN@ IF ( LIB$MATCH_COND( sts, JBC$_NOMOREJOB, JBC$_NOSUCHJOB): & .EQ. 0 ) CALL PutMsg( 'XSHOW', sts, 0)< sts = sts .OR. '10000000'x !message seen+ ELSE IF ( .NOT. Select_Job( job) ) THEN5 skip_count = skip_count + job.intrvng_jobs + 1 ELSE$ IF ( disp_count .EQ. 0 ) THEN IF ( defer ) THEN/ IF ( (show_if_mask .AND. iF_EMPTY).NE. 0@ & .AND. (show_if_mask .AND. GiF_NONEMPTY).EQ. 0A & .AND. (show_if_mask .AND. iF_SOMETHING).EQ. 0O & ) GOTO 800 !****BREAK LOOP**** (tsk! tsk! tsk!!!)- CALL Display_Batch_Queue( queue, bat_q) defer = .FALSE. END IF> IF ( .NOT. do_summary ) CALL Label_Jobs( bATCH) !V5* END IF" disp_count = disp_count + 11 skip_count = skip_count + job.intrvng_jobsE IF ( do_summary ) THEN !V5+> p_i = Job H_Category( job) !V5+> job_count(p_i) = job_count(p_i) + 1 !V5+E ELSE !V5+ IF ( skip_count .GT. 0 ) THEN2 CALL Intervening_Jobs( bATCH, skip_count, 0)( skip_count = 0 !reset END IF- CALL Show_Batch_Job( job, bat, str, queue)E END IF !V5+ END IF END DO !until .not.sts: IF ( LIB$MATCH_CONDI( sts, JBC$_NOMOREJOB, JBC$_NOSUCHJOB) & .GT. 0 ) sts = 1 IF ( sts .AND. defer ) THEN. IF ( ( (show_if_mask .AND. iF_EMPTY).NE. 0* & .AND. skip_count .EQ. 0 )8 & .OR. ( (show_if_mask .AND. iF_NONEMPTY).NE. 01 & .AND. skip_count .GT. 0 ) ) THEN. CALL Display_Batch_Queue( queue, bat_q) defer = .FALSE. END IF END IFE IF ( sts .AND. do_summary .AND. .NOT. defer ) !V5+L & CALL Display_Job_SumJmary( job_count, skip_count) !V5+L 800 CONTINUE !branch here if it we've found a job but want /empty: IF ( .NOT. compress .AND. .NOT. defer ) CALL Output(' ') Show_Batch_Queue = sts RETURN END !of Show_Batch_Queue6 SUBROUTINE Display_Batch_Queue ( queue, bat_q ) !> ! Display various items of information about a batch queue. ! implicit nonec called by:(* function Show_Batch_Queuec constant: INCLUDE '($QUIdef)/no Klist'? INCLUDE 'XShoQue_Def.F' !structure definitionsRC note: printer added (acl ignored) so V4 image will work correctly on V5.E PARAMETER qUI_M_QUEUE_PRINTER = '01000000'x !V5- INTEGER *4 qFLAG_DEV_ONLY,< & qFLAG_BAT_IGNORE, qSTAT_BAT_IGNORE: PARAMETER ( qFLAG_DEV_ONLY = QUI$M_QUEUE_FILE_BURSTE & .OR. QUI$M_QUEUE_FILE_BURST_ONE@ & .OR. QUI$M L_QUEUE_FILE_FLAGD & .OR. QUI$M_QUEUE_FILE_FLAG_ONEC & .OR. QUI$M_QUEUE_FILE_TRAILERG & .OR. QUI$M_QUEUE_FILE_TRAILER_ONE@ & .OR. QUI$M_QUEUE_JOB_BURST? & .OR. QUI$M_QUEUE_JOB_FLAGE & .OR. QUI$M_QUEUE_JOB_SIZE_SCHEDB & .OR. QUI$M_QUEUE_JOB_TRAILER? M & .OR. QUI$M_QUEUE_JOB_FLAG? & .OR. QUI$M_QUEUE_TERMINALD & .OR. QUI$M_QUEUE_FILE_PAGINATEF & .OR. QUI$M_QUEUE_RECORD_BLOCKINGL & .OR. qUI_M_QUEUE_PRINTER !V5-LD & .OR. QUI$M_QUEUE_PRINTER !V5+ & )7 PARAMETER ( qFLAG_BAT_IGNORE = QUI$M_QUEUE_BATC NH )6 PARAMETER ( qSTAT_BAT_IGNORE = QUI$M_QUEUE_IDLE )9 COMMON /queue_labels/ que_flag_labels, que_status_labels& CHARACTER *20 que_flag_labels(0:31)= & / 'batch','cpu_default','cpu_limit','file_burst',@ & 'burst_one','file_flag','flag_one','file_trailer',F & 'trailer_one','generic','generic_selection','job_burst',E & 'job_flag','job_size_sched','job_trailer','retain_all',F & 'retain_error','swap','terminal','wsdefault','wsextent O',: & 'wsquota','file_paginate','record_blocking',L & 'printer', 'acl_specified', !V5+L & 6*' ' / !V5*( CHARACTER *20 que_status_labels(0:31)H & / 'aligning','idle','lowercase','operator_request','paused',A & 'pausing','remote','resetting','resuming','server',F & 'stalled','starting','stopped','stopping','unavailable',L & 'closed', P !V5+L & 16*' ' / !V5* c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /q_cmn/ queue RECORD /q_bat/ bat_q c local:5 CHARACTER disp *512, qtype *20, on_node *16,. & status *128, misc *646 INTEGER *2 ln, onlen, qtypln, statln, msclen& INTEGER num_char, old_indent% LOGICAL is_Qgeneric, is_idle' INTEGER *4 pos, qflags, qstatusc functions: LOGICAL Node_AvailE INTEGER Set_Indent, Fmt_BitMask, Fmt_Strings, !V5* & LIB$FFS INTRINSIC LEN, INDEX qflags = queue.flags qstatus = queue.status is_generic = .FALSE.6 is_idle = ( (qstatus .AND. QUI$M_QUEUE_IDLE) .NE. 0 ) qtypln = 06 IF ( (qflags .AND. QUI$M_QUEUE_GENERIC) .NE. 0 ) THEN is_generic = .TRUE. qtype = 'generic ' qtRypln = LEN('generic_')A* ELSE IF ( (qstatus .AND QUI$M_QUEUE_REMOTE) .NE. 0 ) THEN* qtype = 'remote '"* qtypln = LEN('remote_') END IF qtype(qtypln+1:) = 'batch' qtypln = qtypln + LEN('batch')G qtype(1:1) = CHAR( ICHAR(qtype(1:1)) .AND. .NOT. '20'x ) !uppercase onlen = 0 msclen = 0 IF ( .NOT. is_generic ) THEN! IF ( queue.nodnamlen .GT. 0 )( & CALL STR$TRIM( on_node,H & ', on '//queue.node_name(:queue.nodnamlenS)//'::',% & onlen)% IF ( queue.base_priority .GT. 0 )> & CALL SYS$FAO( ', priority=!SL', msclen, misc,9 & %VAL(queue.base_priority) )& IF ( bat_q.job_limit .GT. 0 ) THEN8 CALL SYS$FAO( ', limit=!SL', ln, misc(msclen+1:),2 & %VAL(bat_q.job_limit) ) msclen = msclen + ln END IF ELSE3 qflags = qflags .AND. .NOT. QUI$M_QUEUE_GENERIC END IF/ qstatus = qstatus .AND. . TNOT. qSTAT_BAT_IGNORE status = ' ' statln = 0 pos = -1 DO WHILE ( pos .LT. 32 )= IF ( LIB$FFS( pos + 1, 32 - (pos+1), qstatus, pos) ) THEN/ IF ( pos .EQ. QUI$V_QUEUE_STOPPED ) THEN: IF (.NOT.Node_Avail( queue.node_name(:queue.nodnamlen)) & ) THEN: CALL STR$TRIM( disp, 'stopped, host unavailable',ln)> IF ( queue.nodnamlen .EQ. 0 ) !should never happenH & CALL STR$TRIM( disp, 'stopped (no host)',ln)! ELSE IF ( .UNOT. is_idle ) THEN. CALL STR$TRIM( disp, 'stop pending', ln) ELSE) CALL STR$TRIM( disp, 'stopped', ln) END IF ELSE3 CALL STR$TRIM( disp, que_status_labels(pos), ln)7 IF ( ln.EQ.0 ) CALL SYS$FAO( 'unknown status #!UL',B & ln, disp, %VAL(pos)) END IF, status(statln+1:) = ', ' // disp(:ln)' statln = statln + LEN(',_') + ln END IF END DO !until pos.ge.322 CALL SYS$FAO( '!AS queue !AS!AS V!AS!AS', ln, disp,H & qtype(:qtypln), queue.queue_name(:queue.quenamlen),F & status(:statln), on_node(:onlen), misc(:msclen) ) old_indent = Set_Indent( 0) CALL BufOut( disp(:ln), 2) CALL Set_Indent( 4 - 1) IF ( do_que_full ) THEN qflags = qflagsE & .AND. .NOT. (qFLAG_DEV_ONLY .OR. qFLAG_BAT_IGNORE)LD IF ( queue.dscriplen .GT. 0 ) THEN !V5+LD CALL Fmt_Strings( queue.description, que Wue.dscriplen, 1, !V5+LD & disp, ln) !V5+LD CALL BufOut( ' /Description='//disp(:ln), 2) !V5+LD END IF !V5+3 CALL Fmt_UIC( queue.owner_uic, 3, misc, msclen). CALL BufOut( ' /OWNER='//misc(:msclen), 0)7 CALL Fmt_Protctn( queue.prot_mask, 0, misc, msclen)3 CALL BufOut( ' /PROTECTION='//misc(:msclen), 4)LD IF ( (qflags .AND. QUI$ XM_QUEUE_ACL_SPECIFIED).NE. 0 ) THEN !V5+LD continue !retreive and format acl !V5+LD CALL BufOut( ' /ACL', 0) !V5+LD END IF !V5+ END IF) IF ( do_que_full .AND. is_generic ) THEN& IF ( queue.gentrglen .GT. 0 ) THENA IF ( INDEX( queue.gen_target(:queue.gentrglen), ',').EQ. 0) & ) THEN !only one CALL BufOut( ' /GENYERIC='E & //queue.gen_target(:queue.gentrglen), 0) ELSE CALL BufOut( ' /GENERIC=('H & //queue.gen_target(:queue.gentrglen)//')', 4) END IF END IF ELSE IF ( do_que_full ) THENc /full & .not.generic2 num_char = Fmt_BitMask( queue.characteristics,? & q_CHAR_MASK_SIZE*8, disp, ln) IF ( num_char .EQ. 1 ) THEN6 CALL BufOut( ' /CHARACTERISTIC='//disp(:ln), 0)$ EL ZSE IF ( num_char .GT. 1 ) THEN= CALL BufOut( ' /CHARACTERISTICS=('//disp(:ln)//')', 4) END IF= IF ( (qflags .AND. QUI$M_QUEUE_CPU_DEFAULT) .NE. 0 ) THEN: CALL Fmt_Cpu_Time( bat_q.cpu_default, misc, msclen)> IF ( misc(:msclen) .EQ. '00:00:00' ) misc = 'INFINITE'7 CALL BufOut( ' /CPU_DEFAULT='//misc(:msclen), 0) END IF; IF ( (qflags .AND. QUI$M_QUEUE_CPU_LIMIT) .NE. 0 ) THEN: CALL Fmt_Cpu_Time( bat_q.cpu_maximum, misc, msclen)> IF ( misc(:[msclen) .EQ. '00:00:00' ) misc = 'INFINITE'7 CALL BufOut( ' /CPU_MAXIMUM='//misc(:msclen), 0) END IF6 IF ( (qflags .AND. QUI$M_QUEUE_SWAP) .NE. 0 ) THEN<C DO NOTHING--/nodisable_swapping is the default ELSE, CALL BufOut( ' /DISABLE_SWAPPING', 0) END IF@ IF ( (qflags .AND. QUI$M_QUEUE_GENERIC_SELECTION).NE.0) THEN8C DO NOTHING--/enable_generic is the default ELSE, CALL BufOut( ' /NOENABLE_GENERIC', 0) END IF< IF ( (qf \lags .AND. QUI$M_QUEUE_RETAIN_ALL) .NE. 0 ) THEN" CALL BufOut( ' /RETAIN', 0)@ ELSE IF ( (qflags .AND. QUI$M_QUEUE_RETAIN_ERROR).NE.0) THEN( CALL BufOut( ' /RETAIN=ERROR', 0) END IF; IF ( (qflags .AND. QUI$M_QUEUE_WSDEFAULT) .NE. 0 ) THEN1 CALL SYS$FAO( ' /WSDEFAULT=!UW', ln, disp,2 & %VAL(bat_q.wsdefault) )! CALL BufOut( disp(:ln), 0) END IF9 IF ( (qflags .AND. QUI$M_QUEUE_WSQUOTA) .NE. 0 ) THEN/ CALL SYS$FAO( ' /WS]QUOTA=!UW', ln, disp,0 & %VAL(bat_q.wsquota) )! CALL BufOut( disp(:ln), 0) END IF: IF ( (qflags .AND. QUI$M_QUEUE_WSEXTENT) .NE. 0 ) THEN0 CALL SYS$FAO( ' /WSEXTENT=!UW', ln, disp,1 & %VAL(bat_q.wsextent) )! CALL BufOut( disp(:ln), 0) END IF END IF !full CALL Buf_Flush( 0) CALL Set_Indent( old_indent) RETURN! END !of Display_Batch_Queue= INTEGER *4 FUNCTION Show_Device_Queue (^ queue, dev_q ) !E ! Display print queue header and process the jobs contained in it. ! implicit nonec called by:$* function XShow_Queuesc constant: INCLUDE '($QUIdef)/nolist'F INCLUDE '($JBCMSGdef)/nolist' !job controller message codes= INCLUDE 'f_inc:Itm.F' !item list structure? INCLUDE 'XShoQue_Def.F' !structure definitionsE PARAMETER jOB_STAT_CNT = 6 !# of status categories !V5+" PARAMETER _ iF_SOMETHING = 1,7 & iF_EMPTY = 8, iF_NONEMPTY = 16 c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /q_cmn/ queue RECORD /q_dev/ dev_q c local:E RECORD /itmlst/ j_lookup(33) !V5* RECORD /j_cmn/ job RECORD /j_dev/ prt RECORD /j_str/ str INTEGER p, p_i,0 & disp_count, skip_count,L & job_count(jOB_STAT_CNT) ` !V5+ LOGICAL defer INTEGER *4 skip_blks,% & search_flags,% & iosb(2), stsc functions: LOGICAL Select_JobE INTEGER Job_Category !V5+ INTEGER LIB$MATCH_COND INTEGER *4 SYS$GETQUIWE IF ( do_summary ) THEN !V5+E DO p_i = 1, jOB_STAT_CNT !V5+E job_couant(p_i) = 0 !V5+E END DO !V5+E defer = .TRUE. !V5+E ELSE !V5+" defer = ( show_if_mask .NE. -1? & .AND. ( ( (show_if_mask .AND. iF_EMPTY).NE. 0D & .XOR. (show_if_mask .AND. iF_NONEMPTY).NE. 0 )E & .OR. (show_if_mask .AND. iF_SOMETHING).bNE. 0 ) )E END IF !V5+c display the queue header= IF ( .NOT. defer ) CALL Display_Device_Queue( queue, dev_q))c set up item list for scanning jobs search_flags = 06 IF ( all_jobs ) search_flags = QUI$M_SEARCH_ALL_JOBS3 j_lookup(1).itm_length = ITM_S_LONGWORD !4+ j_lookup(1).itm_code = QUI$_SEARCH_FLAGS, j_lookup(1).itm_bufadr = %LOC(search_flags)( j_lookup(2).itm_length = ITM_S_LONGWORD+ j_lookup(2) c.itm_code = QUI$_ENTRY_NUMBER- j_lookup(2).itm_bufadr = %LOC(job.entry_num)4 j_lookup(3).itm_length = LEN(job.job_name) !39' j_lookup(3).itm_code = QUI$_JOB_NAME, j_lookup(3).itm_bufadr = %LOC(job.job_name)- j_lookup(3).itm_retlen = %LOC(job.jobnamlen)4 j_lookup(4).itm_length = LEN(job.username) !12' j_lookup(4).itm_code = QUI$_USERNAME, j_lookup(4).itm_bufadr = %LOC(job.username)- j_lookup(4).itm_retlen = %LOC(job.usrnamlen)( j_lookup(5).itm_length = ITM_S_LONGWORD( j d_lookup(5).itm_code = QUI$_JOB_FLAGS) j_lookup(5).itm_bufadr = %LOC(job.flags)( j_lookup(6).itm_length = ITM_S_LONGWORD) j_lookup(6).itm_code = QUI$_JOB_STATUS* j_lookup(6).itm_bufadr = %LOC(job.status)3 j_lookup(7).itm_length = ITM_S_QUADWORD !8) j_lookup(7).itm_code = QUI$_AFTER_TIME. j_lookup(7).itm_bufadr = %LOC(job.after_time)( j_lookup(8).itm_length = ITM_S_LONGWORD' j_lookup(8).itm_code = QUI$_JOB_SIZE* j_lookup(8).itm_bufadr = %LOC(prt.blocks)( j_lookup(9).itm_l eength = ITM_S_LONGWORD/ j_lookup(9).itm_code = QUI$_COMPLETED_BLOCKS0 j_lookup(9).itm_bufadr = %LOC(prt.compltd_blks)( j_lookup(10).itm_length= ITM_S_LONGWORD1 j_lookup(10).itm_code = QUI$_INTERVENING_BLOCKS0 j_lookup(10).itm_bufadr= %LOC(prt.intrvng_blks)( j_lookup(11).itm_length= ITM_S_LONGWORD/ j_lookup(11).itm_code = QUI$_INTERVENING_JOBS0 j_lookup(11).itm_bufadr= %LOC(job.intrvng_jobs): j_lookup(12).itm_length= ITM_S_LONGWORD * cMPLTN_VCTR_SIZ/ j_lookup(12).itm_code = QUI$_CONDI fTION_VECTOR0 j_lookup(12).itm_bufadr= %LOC(job.compltn_stat)* j_lookup(13).itm_length= q_CHAR_MASK_SIZEF j_lookup(13).itm_code = QUI$_CHARACTERISTICS !in case it's pending3 j_lookup(13).itm_bufadr= %LOC(job.characteristics), j_lookup(14).itm_length= LEN(prt.form_name)F j_lookup(14).itm_code = QUI$_FORM_NAME !in case it's pending- j_lookup(14).itm_bufadr= %LOC(prt.form_name)- j_lookup(14).itm_retlen= %LOC(prt.frmnamlen). j_lookup(15).itm_length = LEN(prt.form_stock)F j_lookup( g15).itm_code = QUI$_FORM_STOCK !in case it's pending/ j_lookup(15).itm_bufadr = %LOC(prt.form_stock). j_lookup(15).itm_retlen = %LOC(prt.frmstklen) p = 15 IF ( do_job_full ) THEN2 j_lookup(p+1).itm_length = ITM_S_QUADWORD !83 j_lookup(p+1).itm_code = QUI$_SUBMISSION_TIME4 j_lookup(p+1).itm_bufadr = %LOC(job.submit_time)- j_lookup(p+2).itm_length = ITM_S_LONGWORD, j_lookup(p+2).itm_code = QUI$_PRIORITY1 j_lookup(p+2).itm_bufadr = %LOC(job.priority)- hj_lookup(p+3).itm_length = ITM_S_LONGWORD. j_lookup(p+3).itm_code = QUI$_JOB_COPIES2 j_lookup(p+3).itm_bufadr = %LOC(prt.job_count)- j_lookup(p+4).itm_length = ITM_S_LONGWORD3 j_lookup(p+4).itm_code = QUI$_JOB_COPIES_DONE5 j_lookup(p+4).itm_bufadr = %LOC(prt.job_cnt_done)- j_lookup(p+5).itm_length = ITM_S_LONGWORD4 j_lookup(p+5).itm_code = QUI$_JOB_COPIES_CHKPT6 j_lookup(p+5).itm_bufadr = %LOC(prt.job_cnt_chkpt) p = p + 51 DO p_i = 1, 8 !eigh it parameter strings; j_lookup(p+p_i).itm_length = LEN(str.parameter(p_i))> j_lookup(p+p_i).itm_code = QUI$_PARAMETER_1 + p_i - 1< j_lookup(p+p_i).itm_bufadr = %LOC(str.parameter(p_i)); j_lookup(p+p_i).itm_retlen = %LOC(str.parm_len(p_i)) END DO p = p + 81 j_lookup(p+1).itm_length = LEN(str.note_text)( j_lookup(p+1).itm_code = QUI$_NOTE2 j_lookup(p+1).itm_bufadr = %LOC(str.note_text)0 j_lookup(p+1).itm_retlen = %LOC(str.notelen)4 j_look jup(p+2).itm_length = LEN(str.oper_request)4 j_lookup(p+2).itm_code = QUI$_OPERATOR_REQUEST5 j_lookup(p+2).itm_bufadr = %LOC(str.oper_request)2 j_lookup(p+2).itm_retlen = %LOC(str.oprqstlen) p = p + 2LD j_lookup(p+1).itm_length = LEN(str.restart_queue) !V5+LD j_lookup(p+1).itm_code = QUI$_RESTART_QUEUE_NAME !V5+LD j_lookup(p+1).itm_bufadr = %LOC(str.restart_queue) !V5+LD j_lookup(p+1).itm_retlen = %LOC(str.rst krtlen) !V5+LD p = p + 1 !V5+ END IFLD j_lookup(p+1).itm_length = ITM_S_LONGWORD !4 !V5+LD j_lookup(p+1).itm_code = QUI$_PENDING_JOB_REASON !V5+LD j_lookup(p+1).itm_bufadr = %LOC(job.pend_reason) !V5+LD p = p + 1 !V5++ j_lookup(p+1).itm_code = ITM_K_END_OF_LIST disp_count = 0 skip_count l= 0 skip_blks = 0c loop through the jobs sts = 1 DO WHILE ( sts )c reset old values3 CALL LIB$MOVC5( 0, %VAL(0), 0, j_CMN_SIZE, job)3 CALL LIB$MOVC5( 0, %VAL(0), 0, j_DEV_SIZE, prt)C IF ( do_job_full ) !+: & CALL LIB$MOVC5( 0, %VAL(0), 0, j_STR_SIZE, str)c retreive job info@* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)2 sts = SYS$GETQUIW( , %VAL(QUI$_DISPLAY_JOB), ,5 & m %REF(j_lookup), iosb, ,) IF ( sts ) sts = iosb(1) IF ( .NOT. sts ) THEN@ IF ( LIB$MATCH_COND( sts, JBC$_NOMOREJOB, JBC$_NOSUCHJOB): & .EQ. 0 ) CALL PutMsg( 'XSHOW', sts, 0)< sts = sts .OR. '10000000'x !message seen+ ELSE IF ( .NOT. Select_Job( job) ) THEN5 skip_count = skip_count + job.intrvng_jobs + 1> skip_blks = skip_blks + prt.intrvng_blks + prt.blocks ELSE$ IF ( disp_count .EQ. 0 ) TH nEN IF ( defer ) THEN/ IF ( (show_if_mask .AND. iF_EMPTY).NE. 0@ & .AND. (show_if_mask .AND. iF_NONEMPTY).EQ. 0A & .AND. (show_if_mask .AND. iF_SOMETHING).EQ. 0O & ) GOTO 800 !****BREAK LOOP**** (tsk! tsk! tsk!!!). CALL Display_Device_Queue( queue, dev_q) defer = .FALSE. END IF> IF ( .NOT. do_summary ) CALL Label_Jobs( pRINT) !V5* END IF" disp_count = disp_count + 11 skip_co ount = skip_count + job.intrvng_jobs1 skip_blks = skip_blks + prt.intrvng_blksE IF ( do_summary ) THEN !V5+> p_i = Job_Category( job) !V5+> job_count(p_i) = job_count(p_i) + 1 !V5+E ELSE !V5+ IF ( skip_count .GT. 0 ) THEN: CALL Intervening_Jobs( pRINT, skip_count, skip_blks)( skip_count = 0 !reset skpip_blks = 0 END IF4 CALL Show_Print_Job( job, prt, str, queue, dev_q)E END IF !V5+ END IF END DO !until .not.sts: IF ( LIB$MATCH_COND( sts, JBC$_NOMOREJOB, JBC$_NOSUCHJOB) & .GT. 0 ) sts = 1 IF ( sts .AND. defer ) THEN. IF ( ( (show_if_mask .AND. iF_EMPTY).NE. 0* & .AND. skip_count .EQ. 0 )8 & .OR. ( (show_if_mask .AND. iF_NONEMPTY).NE. 01 & .AND. skip_count .GT. 0 )q ) THEN/ CALL Display_Device_Queue( queue, dev_q) defer = .FALSE. END IF END IFE IF ( sts .AND. do_summary .AND. .NOT. defer ) !V5+L & CALL Display_Job_Summary( job_count, skip_count) !V5+L 800 CONTINUE !branch here if it we've found a job but want /empty: IF ( .NOT. compress .AND. .NOT. defer ) CALL Output(' ') Show_Device_Queue = sts RETURN END !of Show_Device_Queue7 SUBROUTINE Display_Devirce_Queue ( queue, dev_q ) !> ! Display various items of information about a print queue. ! implicit nonec called by:)* function Show_Device_Queuec constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions INTEGER *4 qFLAG_BAT_ONLY,< & qFLAG_DEV_IGNORE, qSTAT_DEV_IGNORE,> & dEVQ_DEFAULT_MASK, dEVQ_SEPARATE_MASKRC note: printer added (acl ignored) so V4 imag se will work correctly on V5.E PARAMETER qUI_M_QUEUE_PRINTER = '01000000'x !V5-5 PARAMETER ( qFLAG_BAT_ONLY = QUI$M_QUEUE_BATCHB & .OR. QUI$M_QUEUE_CPU_DEFAULT@ & .OR. QUI$M_QUEUE_CPU_LIMIT; & .OR. QUI$M_QUEUE_SWAP@ & .OR. QUI$M_QUEUE_WSDEFAULT? & .OR. QUI$M_QUEUE_WSEXTENTD & t .OR. QUI$M_QUEUE_WSQUOTA )8 PARAMETER ( qFLAG_DEV_IGNORE = QUI$M_QUEUE_TERMINALL & .OR. qUI_M_QUEUE_PRINTER !V5-LD & .OR. QUI$M_QUEUE_PRINTER !V5+ & )4 PARAMETER ( qSTAT_DEV_IGNORE = QUI$M_QUEUE_IDLE= & .OR. QUI$M_QUEUE_REMOTE= & .OR. QUI$M_QUEUE_SERVERD & u .OR. QUI$M_QUEUE_LOWERCASE ): PARAMETER ( dEVQ_DEFAULT_MASK = QUI$M_QUEUE_FILE_BURSTE & .OR. QUI$M_QUEUE_FILE_BURST_ONE@ & .OR. QUI$M_QUEUE_FILE_FLAGD & .OR. QUI$M_QUEUE_FILE_FLAG_ONEC & .OR. QUI$M_QUEUE_FILE_TRAILERG & .OR. QUI$M_QUEUE_FILE_TRAILER_ONEH & .OR. QUI$M_QUEUE_FILvE_PAGINATE )9 PARAMETER ( dEVQ_SEPARATE_MASK = QUI$M_QUEUE_JOB_BURST? & .OR. QUI$M_QUEUE_JOB_FLAGE & .OR. QUI$M_QUEUE_JOB_TRAILER )9 COMMON /queue_labels/ que_flag_labels, que_status_labels& CHARACTER *20 que_flag_labels(0:31)( CHARACTER *20 que_status_labels(0:31) c global:B INCLUDE 'XShoQue.F' !options & dynamic arrays c input: RECORD /q_cmn/ queue RECORD /q_dev/ dev_q c w local:9 CHARACTER disp *512, qtype *20, on_node$dev *48,7 & status *128, misc *64, sep *16 INTEGER *2 ln, onlen, qtypln, statln, msclen& INTEGER num_char, old_indent3 LOGICAL is_assigned, is_generic, is_idle' INTEGER *4 pos, qflags, qstatusc functions: LOGICAL Node_AvailE INTEGER Set_Indent, Fmt_BitMask, Fmt_Strings, !V5* & LIB$FFS INTRINSIC LEN, INDEXx qflags = queue.flags qstatus = queue.status) is_assigned = ( dev_q.asnquelen .GT. 0 ) is_generic = .FALSE.6 is_idle = ( (qstatus .AND. QUI$M_QUEUE_IDLE) .NE. 0 ) qtypln = 0 IF ( is_assigned ) THEN3 qflags = qflags .AND. .NOT. QUI$M_QUEUE_GENERIC; ELSE IF ( (qflags .AND. QUI$M_QUEUE_GENERIC) .NE. 0 ) THEN is_generic = .TRUE. qtype = 'generic ' qtypln = LEN('generic_'); ELSE IF ( (qstatus .AND. QUI$M_QUEUE_REMOTE) .NE. 0 ) THEN qtype = 'remote ' qtyypln = LEN('remote_') END IF IF ( is_assigned ) THEN qtype(qtypln+1:) = 'logical'; ELSE IF ( (qstatus .AND. QUI$M_QUEUE_SERVER) .NE. 0 ) THEN qtype(qtypln+1:) = 'server'< ELSE IF ( (qflags .AND. QUI$M_QUEUE_TERMINAL) .NE. 0 ) THEN! qtype(qtypln+1:) = 'terminal' ELSE qtype(qtypln+1:) = 'printer' END IF% CALL STR$TRIM( qtype, qtype, qtypln)G qtype(1:1) = CHAR( ICHAR(qtype(1:1)) .AND. .NOT. '20'x ) !uppercase onlen = 0 IF ( .NOT. is_generic .AND.H & z ( dev_q.devnamlen .GT. 0 .OR. queue.nodnamlen .GT. 0 ) ) THEN on_node$dev(1:5) = ', on '! IF ( queue.nodnamlen .GT. 0 )2 & CALL STR$TRIM( on_node$dev(5+1:),G & queue.node_name(:queue.nodnamlen)//'::',% & onlen)@ on_node$dev(5+onlen+1:)= dev_q.device_name(:dev_q.devnamlen)' onlen = 5 + onlen + dev_q.devnamlen END IF msclen = 0 IF ( is_assigned ) THEN CALL STR$TRIM( misc,H & ', assign {ed to '//dev_q.assigned_queue(:dev_q.asnquelen), & msclen)" ELSE IF ( .NOT. is_generic ) THEN& IF ( dev_q.frmnamlen .GT. 0 ) THEN CALL STR$TRIM( misc,H & ', form='//dev_q.form_name(:dev_q.frmnamlen),# & msclen)" IF ( dev_q.frmstklen .GT. 0: & .AND. dev_q.form_stock(:dev_q.frmstklen)A & .NE. dev_q.form_name(:dev_q.frmnamlen) ) THEN misc(msclen+1:) = '(stock='G & | // dev_q.form_stock(:dev_q.frmstklen)( & // ')'5 msclen = msclen + LEN('(stock=') + dev_q.frmstklen# & + LEN(')') END IF END IF ELSE3 qflags = qflags .AND. .NOT. QUI$M_QUEUE_GENERIC END IF/ qstatus = qstatus .AND. .NOT. qSTAT_DEV_IGNORE status = ' ' statln = 0 pos = -1 DO WHILE ( pos .LT. 32 )? IF ( LIB$FFS( pos + 1, 32 - (pos + 1), qstatus, pos) ) THEN/ IF ( pos }.EQ. QUI$V_QUEUE_STOPPED ) THEN: IF (.NOT.Node_Avail( queue.node_name(:queue.nodnamlen)) & ) THEN: CALL STR$TRIM( disp, 'stopped, host unavailable',ln)> IF ( queue.nodnamlen .EQ. 0 ) !should never happenH & CALL STR$TRIM( disp, 'stopped (no host)',ln)! ELSE IF ( .NOT. is_idle ) THEN. CALL STR$TRIM( disp, 'stop pending', ln) ELSE) CALL STR$TRIM( disp, 'stopped', ln) END IF8 ELSE IF ( pos .EQ. QUI$V_QUEUE_~UNAVAILABLE ) THEN1 CALL STR$TRIM( disp, 'device unavailable', ln) ELSE3 CALL STR$TRIM( disp, que_status_labels(pos), ln)7 IF ( ln.EQ.0 ) CALL SYS$FAO( 'unknown status #!UL',B & ln, disp, %VAL(pos)) END IF, status(statln+1:) = ', ' // disp(:ln)' statln = statln + LEN(',_') + ln END IF END DO !until pos.ge.322 CALL SYS$FAO( '!AS queue !AS!AS!AS!AS', ln, disp,H & qtype(:qtypln), queue.q ueue_name(:queue.quenamlen),: & status(:statln), on_node$dev(:onlen),$ & misc(:msclen) ) old_indent = Set_Indent( 0) CALL BufOut( disp(:ln), 2) CALL Set_Indent( 4 - 1) IF ( do_que_full ) THEN qflags = qflagsE & .AND. .NOT. (qFLAG_BAT_ONLY .OR. qFLAG_DEV_IGNORE)LD IF ( queue.dscriplen .GT. 0 ) THEN !V5+LD CALL Fmt_Strings( queue.description, queue.dscriplen, 1, !V5+LD &  disp, ln) !V5+LD CALL BufOut( ' /Description='//disp(:ln), 2) !V5+LD END IF !V5+3 CALL Fmt_UIC( queue.owner_uic, 3, misc, msclen). CALL BufOut( ' /OWNER='//misc(:msclen), 0)7 CALL Fmt_Protctn( queue.prot_mask, 0, misc, msclen)3 CALL BufOut( ' /PROTECTION='//misc(:msclen), 4)LD IF ( (qflags .AND. QUI$M_QUEUE_ACL_SPECIFIED).NE. 0 ) THEN !V5+LD continue !retreive and format acl !V5+LD CALL BufOut( ' /ACL', 0) !V5+LD END IF !V5+ END IF) IF ( do_que_full .AND. is_generic ) THEN& IF ( queue.gentrglen .GT. 0 ) THENA IF ( INDEX( queue.gen_target(:queue.gentrglen), ',').EQ. 0) & ) THEN !only one CALL BufOut( ' /GENERIC='E & //queue.gen_target(:queue.gentrglen), 0) ELSE CALL BufOut( ' /GENERIC=('H & //queue.gen_target(:queue.gentrglen)//')', 4) END IF END IF ELSE IF ( do_que_full ) THEN c /full but .not.genericA IF ( (queue.status .AND. QUI$M_QUEUE_LOWERCASE) .NE. 0 ) THEN$ CALL BufOut( ' Lowercase', 0)+ ELSE IF ( dev_q.devnamlen .GT. 0 ) THEN$ CALL BufOut( ' Uppercase', 0) END IF2 num_char = Fmt_BitMask( queue.characteristic s,8 & q_CHAR_MASK_SIZE*8, disp, ln) IF ( num_char .EQ. 1 ) THEN6 CALL BufOut( ' /CHARACTERISTIC='//disp(:ln), 0)$ ELSE IF ( num_char .GT. 1 ) THEN= CALL BufOut( ' /CHARACTERISTICS=('//disp(:ln)//')', 4) END IF END IF; IF ( do_que_full ) THEN !even generic queues have this? IF ( (qflags .AND. QUI$M_QUEUE_JOB_SIZE_SCHED).NE. 0 ) THEN) CALL BufOut( ' /SCHEDULE=SIZE', 0)= qflags = qflags .AND. .NOT. QUI$M_QUEUE_JOB_SIZE_SCHED ELSE+ CALL BufOut( ' /SCHEDULE=NOSIZE', 0) END IF END IF/ IF ( do_que_full .AND. .NOT. is_generic ) THEN! IF ( dev_q.max_blocks .GT. 0/ & .AND. dev_q.min_blocks .EQ. 0 ) THEN3 CALL SYS$FAO( ' /BLOCK_LIMIT=!SL', ln, disp,3 & %VAL(dev_q.max_blocks) )! CALL BufOut( disp(:ln), 0)& ELSE IF ( dev_q.max_blocks .GT. 04 & .OR. dev_q.min_blocks .GT. 0 ) THEN* IF ( dev_q.max_blocks .EQ. 0 ) THEN% C ALL STR$TRIM( misc, '""', msclen) ELSE% CALL SYS$FAO( '!SL', msclen, misc,6 & %VAL(dev_q.max_blocks) ) END IF9 CALL SYS$FAO( ' /BLOCK_LIMIT=(!SL,!AS)', ln, disp,B & %VAL(dev_q.min_blocks), misc(:msclen) )! CALL BufOut( disp(:ln), 0) END IF@ IF ( (qflags .AND. QUI$M_QUEUE_GENERIC_SELECTION).NE.0) THEN8C DO NOTHING--/enable_generic is the default ELSE, CALL BufOut( ' /NOENABLE_GENERIC', 0) END IF@ IF ( (qflags .AND. QUI$M_QUEUE_RECORD_BLOCKING).NE. 0 ) THEN?C DO NOTHING--/record_blocking is (now) the default ELSE- CALL BufOut( ' /NORECORD_BLOCKING', 0) END IF< IF ( (qflags .AND. QUI$M_QUEUE_RETAIN_ALL) .NE. 0 ) THEN" CALL BufOut( ' /RETAIN', 0)@ ELSE IF ( (qflags .AND. QUI$M_QUEUE_RETAIN_ERROR).NE.0) THEN( CALL BufOut( ' /RETAIN=ERROR', 0) END IF& IF ( dev_q.proceslen .GT. 0 ) THEN" CALL BufOut( ' /PROCESSOR='B & // dev_q.processor(:dev_q.proceslen), 0) END IF$ IF ( queue.base_priority .NE. 0> &!! .AND. queue.base_priority .NE. system_base_priority & ) THEN5 CALL SYS$FAO( ' /BASE_PRIORITY=!UB', ln, disp,6 & %VAL(queue.base_priority) )! CALL BufOut( disp(:ln), 0) END IF& IF ( dev_q.libnamlen .GT. 0 ) THEN CALL BufOut( ' /LIBRARY='@ & // dev_q.library(:dev_q.libnamlen), 0) END IF0 IF ( (qflags .AND. dEVQ_DEFAULT_MASK) .NE. 01 & .OR. dev_q.deffrmlen .GT. 0 ) THEN disp = ' /DEFAULT=(' ln = LEN('_/DEFAULT=(')A IF ( (qflags .AND. QUI$M_QUEUE_FILE_PAGINATE).NE. 0 ) THEN disp(ln+1:) = 'FEED' ln = ln + LEN('FEED') ELSE disp(ln+1:) = 'NOFEED' ln = ln + LEN('NOFEED') END IFA IF ( (qflags .AND. QUI$M_QUEUE_FILE_FLAG_ONE).NE. 0 ) THEN disp(ln+1:) = ',FLAG=ONE' ln = ln + LEN(',FLAG=ONE')A ELSE IF ( (qflags .AND. QUI$M_QUEUE_FILE_FLAG).NE.0 ) THEN disp(ln+1:) = ',FLAG' ln = ln + LEN(',FLAG') END IFA IF ( (qflags .AND. QUI$M_QUEUE_FILE_BURST_ONE).NE.0 ) THEN disp(ln+1:) = ',BURST=ONE' ln = ln + LEN(',BURST=ONE')A ELSE IF ( (qflags .AND. QUI$M_QUEUE_FILE_BURST).NE.0) THEN disp(ln+1:) = ',BURST' ln = ln + LEN(',BURST') END IFA IF ((qflags .AND. QUI$M_QUEUE_FILE_TRAILER_ONE).NE.0) THEN dis p(ln+1:) = ',TRAILER=ONE' ln = ln + LEN(',TRAILER=ONE')A ELSE IF ((qflags.AND. QUI$M_QUEUE_FILE_TRAILER).NE.0) THEN disp(ln+1:) = ',TRAILER' ln = ln + LEN(',TRAILER') END IF) IF ( dev_q.deffrmlen .GT. 0 ) THEN disp(ln+1:) = ',FORM='E & // dev_q.default_form(:dev_q.deffrmlen), ln = ln + LEN(',FORM=') + dev_q.deffrmlen IF ( dev_q.defstklen .GT. 0@ & .AND. dev_q.default_stock(:dev_q.defstklen)G &  .NE. dev_q.default_form(:dev_q.deffrmlen) ) THEN disp(ln+1:) = '(stock='H & // dev_q.default_stock(:dev_q.defstklen)' & // ')': ln = ln + LEN('(stock=')+ dev_q.defstklen + LEN(')') END IF END IF disp(ln+1:ln+1) = ')' ln = ln + 1! CALL BufOut( disp(:ln), 4) END IF1 IF ( (qflags .AND. dEVQ_SEPARATE_MASK) .NE. 00 & .OR. dev_q.resetlen .GT. 0 ) THEN disp = ' /SEPARATE=' ln = LEN('_/SEPARATE=') sep = '('= IF ( (qflags .AND. QUI$M_QUEUE_JOB_FLAG) .NE. 0 ) THEN disp(ln+1:) = sep // 'FLAG' ln = ln + 1 + LEN('FLAG') sep = ',' END IF> IF ( (qflags .AND. QUI$M_QUEUE_JOB_BURST) .NE. 0 ) THEN disp(ln+1:) = sep // 'BURST' ln = ln + 1 + LEN('BURST') sep = ',' END IF@ IF ( (qflags .AND. QUI$M_QUEUE_JOB_TRAILER) .NE. 0 ) THEN! disp(ln+1:) = sep // 'TRAILER' ln = ln + 1 + LEN('TRAILER') sep = ',' END IF( IF ( dev_q.resetlen .GT. 0 ) THEN! disp(ln+1:) = sep // 'RESET=('D & // dev_q.reset(:dev_q.resetlen) // ')': ln = ln + 1 + LEN('RESET=(')+ dev_q.resetlen + LEN(')') END IF disp(ln+1:ln+1) = ')' ln = ln + 1! CALL BufOut( disp(:ln), 4) END IF END IF !full CALL Buf_Flush( 0) CALL Set_Indent( old_indent) RETURN" END !of Display_Device_Queueww{Ւ,* XShoQue3.For -- routines for XSHOW QUEUEH* Pat Rankin, 5/88-* i*4 Show_Batch_Job ( job, bat, str, que )2* i*4 Show_Print_Job ( job, prt, str, que, dev )* sub Label_Jobs ( is_print )?* sub Intervening_Jobs ( is_print, job_count, num_of_blocks )$* i*4 XShoQ_Job_Files ( is_print )$* int Compare_QChar ( p_ch, q_ch )8* sub Display_Job_Summary ( job_counts, skipped_jobs )*@ INTEGER *4 FUNCTION Show_Batch_Job ( job, bat, str, que ) !< ! Display various items of information about a batch job. !** V5 notes:0* explicit code for pending added.K* SYS$PRINT explicitly used for unspecified spooled log file.* implicit noneC called by:(* function Show_Batch_QueueC constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions INTEGER *4 jFLAG_DEV_ONLY8 PARAMETER  ( jFLAG_DEV_ONLY = QUI$M_JOB_FILE_BURSTC & .OR. QUI$M_JOB_FILE_BURST_ONEC & .OR. QUI$M_JOB_FILE_BURST_EXP> & .OR. QUI$M_JOB_FILE_FLAGB & .OR. QUI$M_JOB_FILE_FLAG_ONEB & .OR. QUI$M_JOB_FILE_FLAG_EXPA & .OR. QUI$M_JOB_FILE_TRAILERE & .OR. QUI$M_JOB_FILE_TRAILER_ONEE & .OR. QUI$M_JOB_FILE_TRAILER_EXP> & ! .OR. QUI$M_JOB_LOWERCASEB & .OR. QUI$M_JOB_FILE_PAGINATEH & .OR. QUI$M_JOB_FILE_PAGINATE_EXP )LD INTEGER *4 jPEND_IGNORE, jPEND_DEV_ONLY !V5+LD PARAMETER ( jPEND_IGNORE = QUI$M_PEND_QUEUE_BUSY, !V5+LD & jPEND_DEV_ONLY = QUI$M_PEND_ JOB_SIZE_MAX !V5+LD & .OR. QUI$M_PEND_JOB_SIZE_MIN !V5+MD & .OR. QUI$M_PEND_LOWERCASE_MISMATCH !V5+MD & .OR. QUI$M_PEND_STOCK_MISMATCH ) !V5+E PARAMETER qUI_M_JOB_PENDING = '0800'x !V5+ COMMON /job_labels/L & job_flag_labels, job_status_labels, pend_reason !V5*& CHARACTER *16 job_flag_labels(0:31)? & / 'cpu_limit','fil e_burst','burst_one','burst_exp',? & 'file_flag','flag_one','flag_exp','file_trailer',B & 'trailer_one','trailer_exp','log_delete','log_null',9 & 'log_spool','lowercase','notify','restart',/ & 'wsdefault','wsextent','wsquota',- & 'file_paginate','paginate_exp', & 11*' ' /( CHARACTER *16 job_status_labels(0:31)H & / 'aborting','executing','holding','inaccessible','refused',C & 'requeue','restart' ,'retained','starting','timed',L & 'suspended','pending', !V5+L & 20*' ' / !V5*E CHARACTER *16 pend_reason(0:31) !V5+L & / 'characteristics','too big','too small','lowercase', !V5+L & 'no access','queue_busy','queue not ready','form/stock', !V5+L & 24*' ' / !V5+ C global: B INCLUDE 'XShoQue.F' !options & dynamic arrays C input: RECORD /j_cmn/ job RECORD /j_bat/ bat RECORD /j_str/ str< RECORD /q_cmn/ que !(for characteristics only) C local:2 CHARACTER disp *256, status *128, fmt *48% INTEGER *2 ln, statln, fmtlen# INTEGER old_indent, p, i% LOGICAL no_priv, sho_status" INTEGER *4 jflags, jstatus,LD & preason, !V5+! & pos, stsC functions:8 INTEGER Set_Indent, Fmt_BitMask, Fmt_Strings,& & Compare_QChar, & LIB$FFS# INTRINSIC LEN, CHAR, ICHAR sts = 1? no_priv = ( (job.status .AND. QUI$M_JOB_INACCESSIBLE) .NE. 0 ) sho_status = .FALSE.8 jstatus = job.status .AND. .NOT. QUI$M_JOB_INACCESSIBLEC IF ( (jstatus.AND.QUI$M_JOB_RETAINED).NE. 0 ) !+J & jstatus = job.status .AND. .NO T. QUI$M_JOB_RESTARTING !+/ jflags = job.flags .AND. .NOT. jFLAG_DEV_ONLYC IF ( (jstatus .AND. .NOT. QUI$M_JOB_RESTARTING).EQ. 0 !*N & .OR. (jstatus .AND. .NOT. QUI$M_JOB_RESTARTING) !V5+!*L & .EQ. QUI_M_JOB_PENDING !V5+K & ) THEN !v5*C special handling for pending jobC IF ( (jstatus .AND. QUI$M_JOB_RESTARTING).NE. 0 ) THEN !+C  CALL STR$TRIM( status, 'Restart pending', statln) !+C ELSE !+0 CALL STR$TRIM( status, 'Pending', statln)C END IF !+G IF ( (que.flags .AND. QUI$M_QUEUE_GENERIC).EQ. 0 !not generic !v5-ND & .AND. job.entry_num .EQ. -1 !v5--always fail !V5+N & ) THEN !v5-G IF ( Compare_QChar( job.characteristics, !v5-N & que.characteristics) .AND. 1 ) THEN !v5-@ status(statln+1:) = ' (char)' !v5-@ statln = statln + LEN('_(char)') !v5-G END IF !v5-G END IF !v5-LD preason = job.pend_reason .AND. .NOT. jPEND_IGNORE !V5+LD &  .AND. .NOT. jPEND_DEV_ONLY !V5+LD IF ( preason .NE. 0 ) THEN !V5+LD status(statln+1:) = ' (' !V5+LD statln = statln + LEN('_(') !V5+LD pos = -1 !V5+LD DO WHILE ( pos .LT. 32 ) !V5+LD IF ( LIB$FFS( pos+1, 32-(pos+1), preason, pos) ) THEN !V5+LD CALL STR$TRIM( disp, pend_reason(pos), ln) !V5+LD IF ( ln .EQ. 0 ) !V5+LD & CALL SYS$FAO( 'unknown reason #!UL', !V5+LD & ln, disp, %VAL(pos)) !V5+LD status(statln+1:) = disp(:ln) // ',' !V5+LD statln = statln + ln + LEN(',') !V5+LD  END IF !V5+LD END DO !V5+LD status(statln:statln) = ')' !change last comma !V5+LD END IF !V5+ ELSEC job is not pending status = ' ' statln = 0 pos = -1 DO WHILE ( pos .LT. 32 )@ IF ( LIB$FFS( pos + 1, 32 - (pos+1), jstatus, pos) ) THEN' IF ( pos .EQ. QUI $V_JOB_TIMED ) THEN* CALL SYS$FAO( 'holding until !17%D',: & ln, disp, job.after_time)/ ELSE IF ( pos .EQ. QUI$V_JOB_ABORTING ) THEN8 IF ( bat.job_pid .NE. 0 .AND. .NOT. no_priv ) THEN- CALL SYS$FAO( 'aborting, pid=!08XL',@ & ln, disp, %VAL(bat.job_pid)) ELSE- CALL STR$TRIM( disp, 'aborting', ln) END IF7 jstatus = jstatus .AND. .NOT. QUI$M_JOB_EXECUTING0 ELSE IF ( pos .EQ. QUI$ V_JOB_EXECUTING ) THEN8 IF ( bat.job_pid .NE. 0 .AND. .NOT. no_priv ) THEN. CALL SYS$FAO( 'executing, pid=!08XL',@ & ln, disp, %VAL(bat.job_pid)) ELSE. CALL STR$TRIM( disp, 'executing', ln) END IF/ ELSE IF ( pos .EQ. QUI$V_JOB_RETAINED ) THEN% IF ( job.compltn_stat(1) ) THEN: CALL STR$TRIM( disp, 'Retained on completion',ln)1 ELSE IF ( job.compltn_stat(1) .NE. 0 ) THEN6 CALL STR$TRIM( disp, 'Ret ained on error', ln) sho_status = .TRUE. ELSE- CALL STR$TRIM( disp, 'Retained', ln) END IF* ELSE IF ( pos .EQ. QUI$V_JOB_RESTARTING@ & .AND. (jstatus .AND. (QUI$M_JOB_ABORTINGH & .OR. QUI$M_JOB_EXECUTING)) .NE. 0 ) THEN- CALL STR$TRIM( disp, '(restarted)', ln) ELSE6 CALL STR$TRIM( disp, job_status_labels(pos), ln) IF ( ln .EQ. 0 )> & CALL SYS$FAO( 'unknown status #!UL',; & ln, disp, %VAL(pos)) END IF IF ( statln .GT. 0 ) THEN& status(statln+1:statln+2) = ', ' statln = statln + 2 END IF status(statln+1:) = disp(:ln) statln = statln + ln END IF END DO@ IF ( statln .GT. 0 ) !make first character uppercaseH & status(1:1) = CHAR( ICHAR(status(1:1)) .AND. .NOT. '20'x ) END IF IF ( no_priv ) THEN CALL STR$TRIM( fmt,H & '! 15 !+!12AS!6UL !AS', fmtlen)9 ELSE IF ( job.jobnamlen .GT. 15 .AND. do_job_full ) THENLC note: 2nd line needs 18 leading spaces (16 + indentation of 2)? CALL STR$TRIM( fmt, '!AS -!/!18!12AS!6UL !AS', fmtlen) ELSE8 CALL STR$TRIM( fmt, '!15AS !12AS!6UL !AS', fmtlen) END IF& CALL SYS$FAO( fmt(:fmtlen), ln, disp,2 & job.job_name(:job.jobnamlen),2 & job.username(:job.usrnamlen),; & %VAL(job.entry_num), status(:statln) ) old_indent = Set_Indent( 2) CALL BufOut( disp(:ln), 2) CALL Set_Indent( 4 - 1) IF ( sho_status ) THEN9C show completion status of job retained on error CALL Set_Indent( 4) DO i = 1, cMPLTN_VCTR_SIZ( IF ( job.compltn_stat(i) .NE. 0 ) THEN ln = 01 CALL SYS$GETMSG( %VAL(job.compltn_stat(i)),< & ln, disp, %VAL('0F'x), ). IF ( i .GT. 1 .AND. disp(1:1) .EQ. '%' )+ & disp(1:1) = '-' CALL BufOut( disp(:ln), 3) END IF END DO CALL Set_Indent( 4 - 1) END IF, IF ( do_job_full .AND. .NOT. no_priv ) THEN/ CALL SYS$FAO( ' Submitted !17%D', ln, disp,( & job.submit_time) CALL BufOut( disp(:ln), 0)# IF ( job.priority .NE. 0 ) THEN0 CALL SYS$FAO( ' /PRIORITY=!UB', ln, disp,/ & %VAL(job.priority) )! CALL BufOut( disp(:ln), 0) END IF= p = Fmt_BitMask( job.characteristics, q_CHAR_MASK_SIZE*8,$ & disp, ln) IF ( p .EQ. 1 ) THEN6 CALL BufOut( ' /CHARACTERISTIC='//disp(:ln), 0) ELSE IF ( p .GT. 1 ) THEN= CALL BufOut( ' /CHARACTERISTICS=('//disp(:ln)//')', 4) END IF! IF ( bat.clilen .GT. 0 ) THEN6 CALL BufOut( ' /CLI='//bat.cli(:bat.clilen), 0) END IF9 IF ( (jflags .AND. QUI$M_JOB_CPU_LIMIT) .NE. 0 ) THEN0 CALL Fmt_Cpu_Time( bat.cputime, disp, ln): IF ( disp(:ln) .EQ. '00:0 0:00' ) disp = 'INFINITE'/ CALL BufOut( ' /CPUTIME='//disp(:ln), 0) END IF7 IF ( (jflags .AND. QUI$M_JOB_RESTART) .NE. 0 ) THEN, CALL STR$TRIM( disp, ' /RESTART', ln)LD IF ( str.rstrtlen .GT. 0 ) THEN !V5+LD disp(ln+1:) = '=' // str.restart_queue(:str.rstrtlen) !V5+LD ln = ln + LEN('=') + str.rstrtlen !V5+LD END IF !V5+! CALL BufOut( disp(:ln), 0) ELSE3C DO NOTHING--/norestart is the default END IF6 IF ( (jflags .AND. QUI$M_JOB_NOTIFY) .NE. 0 ) THEN" CALL BufOut( ' /NOTIFY', 0) END IF: IF ( (jflags .AND. QUI$M_JOB_LOG_DELETE) .NE. 0 ) THEN" CALL BufOut( ' /NOKEEP', 0) ELSE CALL BufOut( ' /KEEP', 0) END IF8 IF ( (jflags .AND. QUI$M_JOB_LOG_NULL) .NE. 0 ) THEN! CALL BufOut( ' /NOLOG', 0)) ELSE IF ( bat.logfillen .GT. 0 ) THEN=  CALL BufOut( ' /LOG='//bat.logfile(:bat.logfillen), 0) END IF9 IF ( (jflags .AND. QUI$M_JOB_LOG_SPOOL) .NE. 0 ) THENE IF ( bat.prtquelen .GT. 0 ) THEN !V5+ CALL BufOut( ' /PRINTER='C & // bat.print_queue(:bat.prtquelen), 0)E ELSE IF ( (jflags .AND. QUI$M_JOB_LOG_NULL) .EQ. 0 ) THEN !V5+> CALL BufOut( ' /PRINTER=SYS$PRINT', 0) !V5+E END IF  !V5+ ELSE# CALL BufOut( ' /NOPRINT', 0) END IF9 IF ( (jflags .AND. QUI$M_JOB_WSDEFAULT) .NE. 0 ) THEN1 CALL SYS$FAO( ' /WSDEFAULT=!UW', ln, disp,0 & %VAL(bat.wsdefault) )! CALL BufOut( disp(:ln), 0) END IF7 IF ( (jflags .AND. QUI$M_JOB_WSQUOTA) .NE. 0 ) THEN/ CALL SYS$FAO( ' /WSQUOTA=!UW', ln, disp,. & %VAL(bat.wsquota) )! CALL BufOut( disp(:ln), 0) END IF8 IF ( (jflags .AND. QUI$M_JOB_WSEXTENT) .NE. 0 ) THEN0 CALL SYS$FAO( ' /WSEXTENT=!UW', ln, disp,/ & %VAL(bat.wsextent) )! CALL BufOut( disp(:ln), 0) END IF> p = Fmt_Strings( str.parameter, str.parm_len, 8, disp, ln) IF ( p .EQ. 1 ) THEN1 CALL BufOut( ' /PARAMETER='//disp(:ln), 0) ELSE IF ( p .GT. 1 ) THEN8 CALL BufOut( ' /PARAMETERS=('//disp(:ln)//')', 4) END IF# IF ( str.chkptlen .GT. 0 ) THENA CALL Fmt_Strings( str.bat_chkpt, str.chkptlen, 1, disp,ln) CALL Set_Indent( 6)3 CALL BufOut( 'Restart_Value='//disp(:ln), 3) END IF END IF !full CALL Buf_Flush( 0)C display job's file(s)$ IF ( do_files .AND. .NOT. no_priv )* & CALL XShoQ_Job_Files( bATCH) CALL Set_Indent( old_indent) Show_Batch_Job = sts RETURN END !of Show_Batch_JobE INTEGER *4 FUNCTION Show_Print_Job ( job, prt, str, que, dev ) !< ! Display various items of information about a print job. !** V5 notes:0* explicit code for pending added.* implicit noneC called by:)* function Show_Device_QueueC constant: INCLUDE '($QUIdef)/nolist'? INCLUDE 'XShoQue_Def.F' !structure definitions INTEGER *4 jFLAG_BAT_ONLY7 PARAMETER ( jFLAG_BAT_ONLY = QUI$M_JOB_CPU_LIMIT? & .OR. QUI$M_JOB_LOG_DELETE= & .OR. QUI$M_JOB_LOG _NULL> & .OR. QUI$M_JOB_LOG_SPOOL> & .OR. QUI$M_JOB_WSDEFAULT= & .OR. QUI$M_JOB_WSEXTENT@ & .OR. QUI$M_JOB_WSQUOTA )LD INTEGER *4 jPEND_IGNORE !V5+LD PARAMETER ( jPEND_IGNORE = QUI$M_PEND_QUEUE_BUSY ) !V5+E PARAMETER qUI_M_JOB_PENDING = '0800'x !V5+ COMMON /j ob_labels/L & job_flag_labels, job_status_labels, pend_reason !V5*& CHARACTER *16 job_flag_labels(0:31)( CHARACTER *16 job_status_labels(0:31)E CHARACTER *16 pend_reason(0:31) !V5+ C global:B INCLUDE 'XShoQue.F' !options & dynamic arrays C input: RECORD /j_cmn/ job RECORD /j_dev/ prt RECORD /j_str/ strB RECORD /q_cmn/ que !(for queue characteristics only)7 RECORD /q_dev/ dev  !(for queue form only) C local:2 CHARACTER disp *256, status *128, fmt *48% INTEGER *2 ln, statln, fmtlen% LOGICAL no_priv, sho_status# INTEGER old_indent, p, i" INTEGER *4 jflags, jstatus,LD & preason, !V5+! & pos, stsC functions:8 INTEGER Set_Indent, Fmt_BitMask, Fmt_Strings,& & Compare_QChar, & LIB$FFS# INTRINSIC LEN, CHAR, ICHAR sts = 1? no_priv = ( (job.status .AND. QUI$M_JOB_INACCESSIBLE) .NE. 0 ) sho_status = .FALSE.8 jstatus = job.status .AND. .NOT. QUI$M_JOB_INACCESSIBLEC IF ( (jstatus.AND.QUI$M_JOB_RETAINED).NE. 0 ) !+J & jstatus = job.status .AND. .NOT. QUI$M_JOB_RESTARTING !+/ jflags = job.flags .AND. .NOT. jFLAG_BAT_ONLYC IF ( (jstatus .AND. .NOT. QUI$M_JOB_RESTARTING).EQ. 0 !*N & .OR. (jstatus .AND. .NOT. QUI$M_JOB_RESTARTING) !V5+!*L & .EQ. QUI_M_JOB_PENDING !V5+K & ) THEN !v5*C special handling for pending jobC IF ( (jstatus .AND. QUI$M_JOB_RESTARTING).NE. 0 ) THEN !+C CALL STR$TRIM( status, 'Restart pending', statln) !+C ELSE !+0 CALL STR$TRIM( status, 'Pending', statln)C END IF !+C IF ( prt.compltd_blks .GT. 0 ) THEN !+C CALL SYS$FAO( ' at block !SL', !+J & ln, status(statln+1:), %VAL(prt.compltd_blks))!+C statln = statln + ln !+C END IF !+NC note: form & char could be misleading on generic queue !v5-G IF ( (que.flags .AND. QUI$M_QUEUE_GENERIC).EQ. 0 !not generic !v5-ND & .AND. job.entry_num .EQ. -1 !v5--always fail !V5+N & ) THEN !v5-G IF ( prt.frmnamlen .GT. 0 !v5-N & .AND. ( prt.frmstklen .NE. dev.frmstklen !v5-N & .OR. prt.form_stock(:prt.frmstklen) !v5-N & .NE. dev.form_stock(:dev.frmstklen) ) ) THEN !v5-@ status(statln+1:) = ', form=' !v5-N & // prt.form_name(:prt.frmnamlen) !v5-@ statln = statln + LEN(',_form=') + prt.frmnamlen !v5-G END IF !v5-G IF ( Compare_QChar( job.characteristics, !v5-N & que.characteristics) .AND. 1 ) THEN !v5-@ status(statln+1:) = ' (char)' !v5-@ statln = statln + LEN('_(char)') !v5-G END IF !v5-G IF ( (job.flags .AND. QUI$M_JOB_LOWERCASE).NE. 0 !v5-N & .AND. (que.status .AND. QUI$M_QUEUE_LOWERCASE).EQ. 0 !v5-N & ) THEN !v5-@ status(statln+1:) = ' (lowercase)' !v5-@ statln = statln + LEN('_(lowercase)') !v5-G END IF !v5-G IF ( dev.max_blocks .GT. 0 !v5-N & .AND. prt.blocks .GT. dev.max_blocks ) THEN !v5-@ status(statln+1:) = ' (too big)' !v5-@ statln = statln + LEN('_(too_big)') !v5-G ELSE IF ( dev.min_blocks .GT. 0 !v5-N & .AND. prt.blocks .LT. dev.min_blocks ) THEN !v5-@ status(statln+1:) = ' (too small)' !v5-@ statln = statln + LEN('_(too_small)') !v5-G END IF !v5-G END IF !v5-LD preason = job.pend_reason .AND. .NOT. jPEND_IGNORE !V5+LD IF ( preason .NE. 0 ) THEN !V5+LD status(statln+1:) = ' (' !V5+LD statln = statln + LEN('_(') !V5+LD pos = -1 !V5+LD DO WHILE ( pos .LT. 32 ) !V5+LD IF ( LIB$FFS( pos+1, 32-(pos+1), preason, pos) ) THEN !V5+LD CALL STR$TRIM( disp, pend_reason(pos), ln) !V5+LD IF ( ln .EQ. 0 )  !V5+LD & CALL SYS$FAO( 'unknown reason #!UL', !V5+LD & ln, disp, %VAL(pos)) !V5+LD status(statln+1:) = disp(:ln) // ',' !V5+LD statln = statln + ln + LEN(',') !V5+LD END IF !V5+LD END DO !V5+LD st atus(statln:statln) = ')' !change last comma !V5+LD END IF !V5+ ELSEC job is not pending status = ' ' statln = 0 pos = -1 DO WHILE ( pos .LT. 32 )@ IF ( LIB$FFS( pos + 1, 32 - (pos+1), jstatus, pos) ) THEN' IF ( pos .EQ. QUI$V_JOB_TIMED ) THEN* CALL SYS$FAO( 'holding until !17%D',: & ln, disp, job.after_time)/ ELSE IF ( pos .EQ. QUI$V_JOB_ABORTING ) THEN) IF ( prt.compltd_blks .GT. 0 ) THEN) CALL SYS$FAO( 'aborting at block !SL',F & ln, disp, %VAL(prt.compltd_blks)) ELSE' CALL STR$TRIM( disp, 'aborting', ln) END IF7 jstatus = jstatus .AND. .NOT. QUI$M_JOB_EXECUTING0 ELSE IF ( pos .EQ. QUI$V_JOB_EXECUTING ) THEN) IF ( prt.compltd_blks .LE. 0 ) THEN- CALL STR$TRIM( disp, 'printing', ln) ELSE/ CALL SYS$FAO( 'printing at block !SL',E  & ln, disp, %VAL(prt.compltd_blks)) END IF/ ELSE IF ( pos .EQ. QUI$V_JOB_RETAINED ) THEN% IF ( job.compltn_stat(1) ) THEN: CALL STR$TRIM( disp, 'Retained on completion',ln)1 ELSE IF ( job.compltn_stat(1) .NE. 0 ) THEN6 CALL STR$TRIM( disp, 'Retained on error', ln) sho_status = .TRUE. ELSE- CALL STR$TRIM( disp, 'Retained', ln) END IF* ELSE IF ( pos .EQ. QUI$V_JOB_RESTARTING@ &  .AND. (jstatus .AND. (QUI$M_JOB_ABORTINGH & .OR. QUI$M_JOB_EXECUTING)) .NE. 0 ) THEN- CALL STR$TRIM( disp, '(restarted)', ln) ELSE7 CALL STR$TRIM( disp, job_status_labels(pos), ln) IF ( ln .EQ. 0 )? & CALL SYS$FAO( 'unknown status #!UL',< & ln, disp, %VAL(pos)) END IF IF ( statln .GT. 0 ) THEN& status(statln+1:statln+2) = ', ' statln = statln + 2 END IF status(statln+1:) = disp(:ln) statln = statln + ln END IF END DO@ IF ( statln .GT. 0 ) !make first character uppercaseH & status(1:1) = CHAR( ICHAR(status(1:1)) .AND. .NOT. '20'x ) END IF IF ( no_priv ) THEN CALL STR$TRIM( fmt,H & '!15 !+!12AS!6UL!8SL !AS', fmtlen)9 ELSE IF ( job.jobnamlen .GT. 15 .AND. do_job_full ) THENLC note: 2nd line needs 18 leading spaces (16 + indentation of 2) ; CALL STR$TRIM( fmt, '!AS -!/!18!12AS!6UL!8SL !AS',! & fmtlen) ELSE< CALL STR$TRIM( fmt, '!15AS !12AS!6UL!8SL !AS', fmtlen) END IF& CALL SYS$FAO( fmt(:fmtlen), ln, disp,2 & job.job_name(:job.jobnamlen),2 & job.username(:job.usrnamlen),; & %VAL(job.entry_num), %VAL(prt.blocks),& & status(:statln) ) old_indent = Set_Indent( 2) CALL BufOut( disp(:ln), 3) CALL Set_Indent( 4 - 1) IF ( sho_status ) THEN9C show completion status of job retained on error CALL Set_Indent( 4) DO i = 1, cMPLTN_VCTR_SIZ( IF ( job.compltn_stat(i) .NE. 0 ) THEN ln = 01 CALL SYS$GETMSG( %VAL(job.compltn_stat(i)),< & ln, disp, %VAL('0F'x), ). IF ( i .GT. 1 .AND. disp(1:1) .EQ. '%' )+ & disp(1:1) = '-' CALL BufOut( disp(:ln), 3) END IF END DO CALL Set_Indent( 4 - 1) END IF, IF ( do_job_full .AND. .NOT. no_priv ) THEN/ CALL SYS$FAO( ' Submitted !17%D', ln, disp,( & job.submit_time) CALL BufOut( disp(:ln), 0)# IF ( job.priority .NE. 0 ) THEN0 CALL SYS$FAO( ' /PRIORITY=!UB', ln, disp,/ & %VAL(job.priority) )! CALL BufOut( disp(:ln), 0) END IF= p = Fmt_BitMask( job.characteristics, q_CHAR_MASK_SIZE*8,$ & disp, ln) IF ( p .EQ. 1 ) THEN6 CALL BufOut( ' /CHARACTERISTIC='//disp(:ln), 0) ELSE IF ( p .GT. 1 ) THEN= CALL BufOut( ' /CHARACTERISTICS=('//disp(:ln)//')', 4) END IF$ IF ( prt.frmnamlen .GT. 0 ) THEN CALL STR$TRIM( disp,H & ' /FORM='//prt.form_name(:prt.frmnamlen), ln) IF ( prt.frmstklen .GT. 06 & .AND. prt.form_stock(:prt.frmstklen)= & .NE. prt.form_name(:prt.frmnamlen) ) THEN disp(ln+1:) = '(stock='F & // prt.form_stock(:prt.frmstklen) // ')'6 ln = ln + LEN('(stock=') + prt.frmstklen + LEN(')') END IF! CALL BufOut( disp(:ln), 0) END IF9 IF ( (jflags .AND. QUI$M_JOB_LOWERCASE) .NE. 0 ) THEN% CALL BufOut( ' /LOWERCASE', 0) END IF7 IF ( (jflags .AND. QUI$M_JOB_RESTART) .NE. 0 ) THENLC DO NOTHING--/restart is the default !v5-LD IF ( str.rstrtlen .GT. 0 ) THEN !V5+LD  CALL BufOut( ' /RESTART=' !V5+LD & //str.restart_queue(:str.rstrtlen), 0) !V5+LD END IF !V5+ ELSE% CALL BufOut( ' /NORESTART', 0) END IF6 IF ( (jflags .AND. QUI$M_JOB_NOTIFY) .NE. 0 ) THEN" CALL BufOut( ' /NOTIFY', 0) END IF$ IF ( prt.job_count .GT. 1 ) THEN1 CALL SYS$FAO( ' /JOB_COUNT=!SL', ln, disp,0 & %VAL(prt.job_count) )! CALL BufOut( disp(:ln), 0) END IFA IF ( (jflags .AND. QUI$M_JOB_FILE_PAGINATE_EXP) .NE. 0 ) THEN@ IF ( (jflags .AND. QUI$M_JOB_FILE_PAGINATE) .NE. 0 ) THEN CALL BufOut( ' /FEED', 0) ELSE CALL BufOut( ' /NOFEED', 0) END IF END IF= IF ( (jflags .AND. QUI$M_JOB_FILE_FLAG_EXP) .NE. 0 ) THEN@ IF ( (jflags .AND. QUI$M_JOB_FILE_FLAG_ONE) .NE. 0 ) THEN CALL BufOut( ' /FLAG=ONE', 0)A ELSE IF ( (jflags .AND. QUI$M_JOB_FILE_FLAG) .NE. 0 ) THEN CALL BufOut( ' /FLAG', 0) ELSE CALL BufOut( ' /NOFLAG', 0) END IF END IF> IF ( (jflags .AND. QUI$M_JOB_FILE_BURST_EXP) .NE. 0 ) THENA IF ( (jflags .AND. QUI$M_JOB_FILE_BURST_ONE) .NE. 0 ) THEN! CALL BufOut( ' /BURST=ONE', 0)A ELSE IF ( (jflags .AND. QUI$M_JOB_FILE_BURST).NE. 0 ) THEN CALL BufOut( ' /BURST', 0) ELSE CALL BufOut( ' /NOBURST', 0) END IF END IF@ IF ( (jflags .AND. QUI$M_JOB_FILE_TRAILER_EXP) .NE. 0 ) THENA IF ( (jflags .AND. QUI$M_JOB_FILE_TRAILER_ONE).NE.0 ) THEN# CALL BufOut( ' /TRAILER=ONE', 0)A ELSE IF ( (jflags .AND. QUI$M_JOB_FILE_TRAILER).NE.0) THEN CALL BufOut( ' /TRAILER', 0) ELSE! CALL BufOut( ' /NOTRAILER', 0) END IF END IF" IF ( str.notelen .GT. 0 ) THENA CALL Fmt_Strings( str.note_text, str.notelen, 1, disp, ln), CALL BufOut( ' /NOTE='//disp(:ln), 0) END IF$ IF ( str.oprqstlen .GT. 0 ) THEN< CALL Fmt_Strings( str.oper_request, str.oprqstlen, 1,( & disp, ln)0 CALL BufOut( ' /OPERATOR='//disp(:ln), 0) END IF> p = Fmt_Strings( str.parameter, str.parm_len, 8, disp, ln) IF ( p .EQ. 1 ) THEN1 CALL BufOut( ' /PARAMETER='//disp(:ln), 0) ELSE IF ( p .GT. 1 ) THEN8 CALL BufOut( ' /PARAMETERS=('//disp(:ln)//')', 4) END IF END IF !full CALL Buf_Flush( 0)C display job's file(s)$ IF ( do_files .AND. .NOT. no_priv )* & CALL XShoQ_Job_Files( pRINT) CALL Set_Indent( old_indent) Show_Print_Job = sts RETURN END !of Show_Print_Job) SUBROUTINE Label_Jobs ( is_print ) !3 ! Label the columns for brief print job listing. ! implicit noneC called by:;* function Show_Batch_Queue, Show_Device_Queue C global:B INCLUDE 'XShoQue.F' !options & dynamic arrays C input: LOGICAL is_print C local:% CHARACTER title *128, fmt *80 INTEGER *2 tlen, flen INTEGER save_indentC functions: INTEGER Set_Indent IF ( is_print ) THEN IF ( compress ) THENA CALL STR$TRIM( fmt, ' !15AS !12AS !5AS !6AS !AS', flen) ELSE= CALL STR$TRIM( fmt, '!/ !15AS !12AS !5AS !6AS !AS'H & //'!/ !15AS !12AS !-!5AS !-!6AS !-!6AS'," & flen) END IF ELSE IF ( compress ) THEN= CALL STR$TRIM( fmt, ' !15AS !12AS !5AS !+!AS', flen) ELSE9 CALL STR$TRIM( fmt, '!/ !15AS !12AS !5AS !+!AS'@ & //'!/ !15AS !12AS !-!5AS !-!6AS'," & flen) END IF END IF' CALL SYS$FAO( fmt(:flen), tlen, title,H & 'Jobname', 'Username', 'Entry', 'Blocks', 'Status',+ & '-------', '--------') save_indent = Set_Indent( 0) CALL BufOut( title(:tlen), 3) CALL Set_Indent( save_indent) RETURN END !of Label_JobsH SUBROUTINE Intervening_Jobs ( is_print, job_count, num_of_blocks) !5 ! Display a count of the number of jobs not shown. ! implicit noneC called by:;* function Show_Batch_Queue, Show_Device_Queue C input: INTEGER is_print INTEGER job_count INTEGER *4 num_of_blocks C local: CHARACTER *60 buf INTEGER *2 ln INTEGER save_indentC functions: INTEGER Set_Indent IF ( job_count .GT. 0 ) THEN IF ( is_print ) THEN@ CALL SYS$FAO( '!_(!SL intervening job!%S; !SL block!%S)',H & ln, buf, %VAL(job_count), %VAL(num_of_blocks)) ELSE2 CALL SYS$FAO( '!_(!SL intervening job!%S)',4 & ln, buf, %VAL(job_count)) END IF save_indent = Set_indent( 0) CALL BufOut( buf(:ln), 3)! CALL Set_Indent( save_indent) END IF RETURN END !of Intervening_Jobs7 INTEGER *4 FUNCTION XShoQ_Job_Files ( is_print ) !2 ! Display the file(s) for a batch or print job. ! implicit noneC called by:6* function Show_Batch_Job, Show_Print_JobC constant: INCLUDE '($QUIdef)/nolist' INCLUDE '($JBCMSGdef)/nolist'7 INCLUDE 'f_inc:Itm.F' !itemlist defs? INCLUDE 'XShoQue_Def.F' !structure definitions C global:B INCLUDE 'XShoQue.F' !options & dynamic arrays C input: LOGICAL is_print C local:E RECORD /itmlst/ f_lookup(12) !V5* RECORD /f_cmn/ file RECORD /f_dev/ pfil$ CHARACTER disp *80, misc *20 INTEGER *2 ln, msclen INTEGER p, old_indent/ INTEGER *4 search, flags, iosb(2), stsC functions: INTEGER Set_Indent,& & LIB$MATCH_COND INTEGER *4 SYS$GETQUIW search = 0( f_lookup(1).itm_length = IT M_S_LONGWORD+ f_lookup(1).itm_code = QUI$_SEARCH_FLAGS& f_lookup(1).itm_bufadr = %LOC(search)- f_lookup(2).itm_length = LEN(file.file_spec)1 f_lookup(2).itm_code = QUI$_FILE_SPECIFICATION. f_lookup(2).itm_bufadr = %LOC(file.file_spec). f_lookup(2).itm_retlen = %LOC(file.filspclen)( f_lookup(3).itm_length = ITM_S_LONGWORD) f_lookup(3).itm_code = QUI$_FILE_FLAGS* f_lookup(3).itm_bufadr = %LOC(file.flags)( f_lookup(4).itm_length = ITM_S_LONGWORD* f_lookup(4).itm_code = QUI$_FILE_ST ATUS+ f_lookup(4).itm_bufadr = %LOC(file.status) p = 4' IF ( is_print .AND. do_job_full ) THEN. f_lookup(p+1).itm_length = ITM_S_LONGWORD0 f_lookup(p+1).itm_code = QUI$_FILE_COPIES5 f_lookup(p+1).itm_bufadr = %LOC(pfil.copy_count). f_lookup(p+2).itm_length = ITM_S_LONGWORD5 f_lookup(p+2).itm_code = QUI$_FILE_COPIES_DONE8 f_lookup(p+2).itm_bufadr = %LOC(pfil.copy_cnt_done). f_lookup(p+3).itm_length = ITM_S_LONGWORD6 f_lookup(p+3).itm_code = QUI$_FIL E_COPIES_CHKPT9 f_lookup(p+3).itm_bufadr = %LOC(pfil.copy_cnt_chkpt). f_lookup(p+4).itm_length = ITM_S_LONGWORD/ f_lookup(p+4).itm_code = QUI$_FIRST_PAGE5 f_lookup(p+4).itm_bufadr = %LOC(pfil.first_page). f_lookup(p+5).itm_length = ITM_S_LONGWORD. f_lookup(p+5).itm_code = QUI$_LAST_PAGE4 f_lookup(p+5).itm_bufadr = %LOC(pfil.last_page)/ f_lookup(p+6).itm_length = LEN(pfil.setup)7 f_lookup(p+6).itm_code = QUI$_FILE_SETUP_MODULES0 f_lookup(p+6) .itm_bufadr = %LOC(pfil.setup)3 f_lookup(p+6).itm_retlen = %LOC(pfil.setuplen) p = p + 6 END IFLD IF ( do_job_full ) THEN !V5+LD f_lookup(p+1).itm_length = 3 * ITM_S_WORD !fid is 6 bytes !V5+LD f_lookup(p+1).itm_code = QUI$_FILE_IDENTIFICATION !V5+LD f_lookup(p+1).itm_bufadr = %LOC(file.fid) !V5+LD p = p + 1 !V5+LD  END IF !V5++ f_lookup(p+1).itm_code = ITM_K_END_OF_LIST sts = 1 DO WHILE ( sts )4 CALL LIB$MOVC5( 0, %VAL(0), 0, f_CMN_SIZE, file)% IF ( is_print .AND. do_job_full )A & CALL LIB$MOVC5( 0, %VAL(0), 0, f_DEV_SIZE, pfil)C retreive file info@* $getquiw(efn,func,nullarg,itmlst,iosb,astadr,astprm)3 sts = SYS$GETQUIW( , %VAL(QUI$_DISPLAY_FILE), ,5 & %REF(f_lookup ), iosb, ,) IF ( sts ) sts = iosb(1) IF ( .NOT. sts ) THENA IF ( LIB$MATCH_COND( sts, JBC$_NOMOREFILE,JBC$_NOSUCHFILE): & .EQ. 0 ) CALL PutMsg( 'XSHOW', sts, 0)< sts = sts .OR. '10000000'x !message seen ELSE" old_indent = Set_Indent( 6)7 CALL BufOut( file.file_spec(:file.filspclen), 1) CALL Set_Indent( 8-1)LD IF ( do_job_full .AND. file.fid(1) .NE. 0 ) THEN !V5+LD CALL Fmt_File _ID( file.fid, disp, ln) !V5+LD CALL BufOut( ' id='//disp(:ln), 0) !V5+LD END IF !V5+% IF ( file.status .NE. 0 ) THENH* IF ( (file.status .AND. QUI$M_FILE_CHECKPOINTED).NE.0 )9* & CALL BufOut( ' (checkpointed)', 0)7 IF ( (file.status .AND. QUI$M_FILE_EXECUTING) .NE. 0 & ) THEN IF ( is_print ) THEN' CALL BufOut( ' (printing)', 0) ELSE( CALL BufOut( ' (executing)', 0) ENDIF ENDIF END IF IF ( do_job_fullC & .AND. (file.flags .AND. QUI$M_FILE_DELETE) .NE. 0 )/ & CALL BufOut( ' /DELETE', 0)- IF ( do_job_full .AND. is_print ) THEN3 flags = file.flags .AND. .NOT. QUI$M_FILE_DELETE% IF ( pfil.copy_count .GT. 1 ) THEN- CALL SYS$FAO( ' /COPIES=!SL', ln, disp,8 & %VAL(pfil.copy_count) ) CALL BufOut( disp(:ln), 0) END IF IF ( pfil.last_page .NE. 06 & .AND. pfil.first_page .EQ. 0 ) THEN, CALL SYS$FAO( ' /PAGES=!SL', ln, disp,7 & %VAL(pfil.last_page) ) CALL BufOut( disp(:ln), 0)" ELSE IF ( pfil.last_page .NE. 09 & .OR. pfil.first_page .NE. 0 ) THEN' IF ( pfil.last_page .EQ. 0 ) THEN+ CALL STR$TRIM( misc, '""', msclen) ELSE+ CALL SYS$FAO( '!SL', msclen, misc,: & %VAL(pfil.last_page) ) END IF2 CALL SYS$FAO( ' /PAGES=(!SL,!AS)', ln, disp,G & %VAL(pfil.first_page), misc(:msclen) ) CALL BufOut( disp(:ln), 0) END IF IF ( pfil.setuplen .GT. 0 )/ & CALL BufOut( ' /SETUP=('H & //pfil.setup(:pfil.setuplen)//')', 4)1 IF ( (flags .AND. QUI$M_FILE_PASSALL) .NE. 0 )3 & CALL BufOut( ' /PASSALL', 0)5 IF ( (flags .AND. QUI$M_FILE_PAGE_HEADER) .NE. 0 )2 & CALL BufOut( ' /HEADER', 0)5 IF ( (flags .AND. QUI$M_FILE_DOUBLE_SPACE).NE. 0 )1 & CALL BufOut( ' /SPACE', 0): IF ( (flags .AND. QUI$M_FILE_PAGINATE_EXP).NE. 0 ) THEN: IF ( (flags .AND. QUI$M_FILE_PAGINATE) .NE. 0 ) THEN" CALL BufOut( ' /FEED', 0) ELSE$ CALL BufOut( ' /NOFEED', 0) END IF END IF6 IF ( (flags .AND. QUI$M_FILE_FLAG_EXP).NE. 0 ) THEN6 IF ( (flags .AND. QUI$M_FILE_FLAG) .NE. 0 ) THEN" CALL BufOut( ' /FLAG', 0) ELSE$ CALL BufOut( ' /NOFLAG', 0) END IF END IF7 IF ( (flags .AND. QUI$M_FILE_BURST_EXP).NE. 0 ) THEN7 IF ( (flags .AND. QUI$M_FILE_BURST) .NE. 0 ) THEN# CALL BufOut( ' /BURST', 0) ELSE% CALL BufOut( ' /NOBURST', 0) END IF END IF9 IF ( (flags .AND. QUI$M_FILE_TRAILER_EXP).NE. 0 ) THEN9 IF ( (flags .AND. QUI$M_FILE_TRAILER) .NE. 0 ) THEN% CALL BufOut( ' /TRAILER', 0) ELSE' CALL BufOut( ' /NOTRAILER', 0) END IF END IF! END IF !is_print & do_full CALL Buf_Flush( 0)# CALL Set_Indent( old_indent) END IF !sts ok END DO< IF ( LIB$MATCH_COND( sts, JBC$_NOMOREFILE, JBC$_NOSUCHFILE) & .GT. 0 ) sts = 1 XShoQ_Job_Files = sts RETURN END !of XShoQ_Job_Files4 INTEGER FUNCTION Compare_QChar ( p_ch, q_ch ) !) ! Compare two bitmasks (byte aligned).( ! Result: 0 = 'p' and 'q' are equal,I ! 1 = 'p' has bits set that 'q' doesn't (but not vice versa),: ! 2 = 'q' has bits set that 'p' doesn't ( " ),; ! 3 = each has bits set that the other doesn't. ! implicit noneC constant:< INCLUDE 'XShoQue_Def.F' !'q_CHAR_MASK_SIZE' C input:@ BYTE p_ch(q_CHAR_MASK_SIZE), q_ch(q_CHAR_MASK_SIZE) C local: INTEGER i, result BYTE xor result = 0 i = 09 DO WHILE ( i .LT. q_CHAR_MASK_SIZE .AND. result .NE. 3 ) i = i + 1 xor = p_ch(i) .XOR. q_ch(i) IF ( xor .NE. 0 ) THEN: IF ( (p_ch(i) .AND. xor).NE. 0 ) result = result .OR. 1: IF ( (q_ch(i) .AND. xor).NE. 0 ) result = result .OR. 2 END IF END DO Compare_QChar = result RETURN END !of Compare_QCharL SUBROUTINE Display_Job_Summary ( job_counts, skipped_jobs ) !V5+E !  !V5+E ! Display a one-line summary of the jobs in a queue. !V5+E ! Each job falls into one of six categories: !V5+E ! "executing", "pending", "waiting", "holding", !V5+E ! "retained", or "'other'". !V5+E ! !V5+E implicit none !V5+LC constant:  !V5+E PARAMETER jOB_STAT_CNT = 6 !# of status categories !V5+E CHARACTER *10 job_category(jOB_STAT_CNT) / !V5+L & 'executing', 'pending', 'waiting', !V5+L & 'holding', 'retained', '''other''' / !V5+E INTEGER *2 job_cat_len(jOB_STAT_CNT) / 9,3*7,8,7 / !V5+LC input: !V5+E INTEGER job_counts(jOB_STAT_CNT), !V5+L & skipped_jobs !V5+LC local: !V5+E CHARACTER buf *128 !V5+E INTEGER *2 ln, ltmp !V5+E INTEGER total_jobs, nonzero, shown, !V5+L & cat_indx, old_indent  !V5+LC functions: !V5+E INTEGER Set_Indent !V5+ !V5+PC simplify by lumping skipped jobs with 'other' (which is expected to be 0)E IF ( skipped_jobs .GT. 0 ) !V5+L & job_counts(jOB_STAT_CNT) = job_counts(jOB_STAT_CNT) !V5+L & + skipped_jobs !V5+LC figure out how many jobs there and how many different kinds !V5+E total_jobs = 0 !V5+E nonzero = 0 !V5+E DO cat_indx = 1, jOB_STAT_CNT !V5+E IF ( job_counts(cat_indx) .GT. 0 ) THEN !V5+E total_jobs = total_jobs + job_counts(cat_indx) !V5+E nonzero = nonzero + 1 !V5+E END IF !V5+E END DO !V5+LC display "summary" 'header' !V5+E old_indent = Set_Indent( 2) !V5+E CALL BufOut( 'Summary:', 0) !V5+E CALL Set_Indent( LEN('Summary:')) !V5+LC create rest of summary line !V5+E IF ( total_jobs .EQ. 0 ) THEN !V5+E CALL STR$TRIM( buf, ' no jobs', ln) !V5+E ELSE !V5+E ln = 0 !V5+E shown = 0 !V5+E DO cat_indx = 1, jOB_STAT_CNT !V5+E IF ( job_counts(cat_indx) .GT. 0 ) THEN !V5+LC separate from previous job count if necessary !V5+> IF ( shown .GT. 0 ) THEN !V5+> IF ( nonzero .NE. 2 ) THEN !V5+> buf(ln+1:ln+1) = ',' !V5+> ln = ln + 1 !V5+> END IF !V5+> IF ( shown .EQ. nonzero - 1 ) THEN !V5+> buf(ln+1:) = ' and'  !V5+> ln = ln + LEN('_and') !V5+> END IF !V5+> END IF !V5+LC format count !V5+> CALL SYS$FAO( ' !SL !AS', ltmp, buf(ln+1:), !V5+L & %VAL(job_counts(cat_indx)), !V5+L & job_category(cat_indx)(:job_cat_len(cat_indx)) ) !V5+> ln = ln + ltmp !V5+> shown = shown + 1 !V5+E END IF !V5+E END DO !V5+LC complete summary line !V5+E buf(ln+1:) = ' jobs' !V5+E ln = ln + LEN('_job') !V5+E IF ( total_jobs .GT. 1 ) ln = ln + 1 !include 's' !V5+E END IF !V5+LC display summary line !V5+E CALL BufOut( buf(:ln), 4) !V5+E CALL Buf_Flush( 0) !V5+E CALL Set_Indent( old_indent) !V5+ !V5+E RETURN  !V5+L END !of Display_Job_Summary !V5+ww {ՒH* Dyn_Inp.For -- Dynamic Input routines & other miscellaneous routinesJ* Pat Rankin, May'88* i*4 Cli_Present ( label )/* i*4 Cli_Get_Value ( label, result, reslen )2* i*4 Cli_Parse_Command ( tables, verb, prompt )&* i*4 Get_Cli_Number ( key, result )>* i*4 Get_Inp_List ( qualif, list_size, list_adr, list_cnt )<* i*4 Get_Inp_Element ( size, list, indx, result, reslen )8* i*4 Add_Inp_Element ( size, list _adr, indx, string )4* i*4 Put_Inp_Element ( size, list, indx, string )8* i*4 Search_Inp_List ( size, list, target, wildcard )4* i*4 Expand_Inp_List ( list_size, list, new_adr )* i*4 Output ( string )* " Block_Output ( string )* " Flush_Output ( )+* " Open_Output ( default_name, width )2* log Disable_Installed_Privs ( disabled_privs )%* i*4 PutMsg ( facility, sts, stv ).* i*4 Parse_Node ( infile, outfile, outlen )#* log Node_Available ( nodename )K* i*4 Parse_Keywords( qual_name, keywrd_count, keywords, synonyms, masks)*0 INTEGER *4 FUNCTION Cli_Present ( label )/ ! Call CLI$PRESENT with signalling disabled. implicit none C input: CHARACTER *(*) labelC functions: INTEGER *4 CLI$PRESENT EXTERNAL LIB$SIG_TO_RET$ CALL LIB$ESTABLISH( LIB$SIG_TO_RET)" Cli_Present = CLI$PRESENT( label) RETURN END !of Cli_PresentB INTEGER *4 FUNCTION Cli_Get_Value ( label, result, reslen )1 ! Call CLI$GET_VALUE with signalling disabled. implicit none C input: CHARACTER *(*) label C output: CHARACTER *(*) result INTEGER *2 reslenC functions: INTEGER *4 CLI$GET_VALUE EXTERNAL LIB$SIG_TO_RET$ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) reslen = 06 Cli_Get_Value = CLI$GET_VALUE( label, result, reslen) RETURN END !of Cli_Get_ValueE INTEGER *4 FUNCTION Cli_Parse_Command ( tables, verb, prompt ) !? ! Fetch use r's command line and parse it. If he used "RUN",= ! there was no chance to supply one, so prompt for it now. ! implicit noneC constant:7 INCLUDE '($FSCNdef)/nolist' !filescan defs7 INCLUDE '($CliVERBdef)/nolist' !cli verb defsA*- INCLUDE '($CliSERVdef)/nolist' !cli service defs> PARAMETER CLI$K_GETCMD = '00000001'x !get command line9 INCLUDE 'f_inc:Dsc.F' !descriptor defs3 STRUCTURE /clirq/ !cli reques t blockA BYTE rqtype/0/, rqindx/0/, rqflags/0/, rqstat /0/ INTEGER *4 %FILL(1) /0/G RECORD /dsc_z/ rdesc !descriptor initialized to 0's" INTEGER *4 %FILL(3) /3*0/ END STRUCTURE !clirq> STRUCTURE /fscn/ !short itemlist for $filescan' INTEGER *2 len /0/, code /0/. INTEGER *4 adr /0/, end_of_list /0/ END STRUCTURE !fscn C input:B EXTERNAL tables !command tables [set command/obj]A C HARACTER *(*) verb, prompt !command verb and prompt strings C local:? RECORD /dsc_d/ parse !descriptor for dynamic stringA RECORD /clirq/ cmd !command interface request block9 RECORD /fscn/ fscn !item list for $filescan5 INTEGER *4 sts !return status valueC functions:( INTEGER *4 SYS$CLI, CLI$DCL_PARSE/ EXTERNAL LIB$SIG_TO_RET, LIB$GET_INPUT@ CALL LIB$ESTABLISH( LIB$SIG_TO_RET) !suppress error signals C get command line? cmd.rqtype = CLI$K_GETCMD !request is 'get command line' sts = SYS$CLI( cmd,,)A IF ( sts ) THEN !ok => cli available & verb wasn't "RUN"HC invoked via symbol => have command line (which might be empty)?C [might also be invoked via mcr or dcl; that's ok]D IF ( cmd.rqstat .EQ. CLI$K_VERB_MCR ) THEN !strip image name -@ fscn.code = FSCN$_FILESPEC !+ from MCR invocation& CALL SYS$FILESCAN( cmd.rdesc, fscn,)< cm d.rdesc.d_len = cmd.rdesc.d_len - fscn.len !shrink size< cmd.rdesc.d_adr = cmd.rdesc.d_adr + fscn.len !advance ptr END IF1C prepend verb and parse the command line2 CALL STR$CONCAT( parse, verb, ' ', cmd.rdesc)( sts = CLI$DCL_PARSE( parse, tables)? ELSE ! RUN (might be "no cli present" [CLI$_INVREQTYP])HC invoked via run => get a substitute command line from the user1 sts = CLI$DCL_PARSE(, tables, LIB$GET_INPUT,6 & LIB$GET_INPUT, prompt) END IF Cli_Parse_Command = sts RETURN END !of Cli_Parse_Command9 INTEGER *4 FUNCTION Get_Cli_Number ( key, result ) != ! Use CLI routine to obtain a parameter or qualifier value< ! and convert the resulting string into a binary integer. ! implicit none C input: CHARACTER *(*) key C output: INTEGER *4 result C local: CHARACTER *32 value INTEGER *2 ln INTEGER *4 stsC functions:- INTEGER *4 Cli_Get_Value, OTS$CVT_TI_L result = 0% sts = Cli_Get_Value( key, value, ln)4 IF ( sts ) sts = OTS$CVT_TI_L( value(:ln), result) Get_Cli_Number = sts RETURN END !of Get_Cli_Number INTEGER *4 FUNCTION@ & Get_Inp_List ( qualif, list_size, list_adr, list_cnt ) !9 ! Retreive a list that's been parsed via cli routines.< ! If the first element is "-" then the item count will be ! negated. ! implicit none C input: CHARACTER *(*) qualifC input/output: INTEGER *4 list_size, & list_adr C output: INTEGER *4 list_cnt C local: CHARACTER *512 buffer INTEGER *2 buflen LOGICAL negate INTEGER *4 sts, clistsC functions:- INTEGER *4 Cli_Present, Cli_Get_Value,' & Add_Inp_Element INTRINSIC LEN list_cnt = 0 sts = Cli_Present( qualif) IF ( sts ) THEN4 clists = Cli_Get_Value( qualif, buffer, buflen); negate = ( (clists .AND. 1) .EQ. 1 .AND. buflen .GT. 06 & .AND. buffer(:buflen) .EQ. '-' )9 sts = clists !potential return status" DO WHILE ( sts .AND. clists ) list_cnt = list_cnt + 1- sts = Add_Inp_Element( list_size, list_adr,@ & list_cnt, buffer(:buflen))1 clists = Cli_Get_Value( qualif, buffer, buflen) END DO( IF ( negate ) list_cnt = -list_cnt END IF Get_Inp_List = sts RETURN END !of Get_Inp_List INTEGER *4 FUNCTION@ & Get_Inp_Element ( size, list, indx, result, reslen ) !; ! Retreive a string from a dynamic array of descriptors. ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsD PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size RECORD /dsc/ list(*) INTEGER indx C output: CHARACTER *(*) result INTEGER *2 reslen C local: INTEGER *4 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS, LEN, MIN1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSEC result = list(indx)1 sts = STR$COPY_DX( result, %REF(list(indx)))1 reslen = MIN( list(indx).d_len, LEN(result)) END IF Get_Inp_Element = sts RETURN END !of Get_Inp_Element INTEGER *4 FUNCTION: & Add_Inp_Element ( size, list_adr, indx, string ) !@ ! Store a string in a dynamic array of descriptors, expanding ! it if necessary. ! implicit noneC constant:D PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size, list_adr INTEGER indx CHARACTER *(*) string C local: INTEGER *4 stsC functions:2 INTEGER *4 Expand_Inp_List, Put_Inp_Element INTRINSIC ABS sts = 1 IF ( ABS(indx) .GT. size ) THEN+ sts = Expand_Inp_List( size, list_adr); IF ( sts .AND. ABS(indx) .GT. size ) sts = SS$_SUBRNG END IF IF ( sts )G & sts = Put_Inp_Element( size, %VAL(list_adr), ABS(indx), string) Add_Inp_Element = sts RETURN END !of Add_Inp_ElementG INTEGER *4 FUNCTION Put_Inp_Element ( size, list, indx, string ) !6 ! Store a string in a dynamic array of descriptors. ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F'  !($DSCdef) descriptorsD PARAMETER SS$_SUBRNG = '000004AA'x !subscript out of range C input: INTEGER *4 size RECORD /dsc/ list(*) INTEGER indx CHARACTER *(*) string C local: INTEGER *4 stsC functions: INTEGER *4 STR$COPY_DX INTRINSIC ABS1 IF ( indx .GT. ABS(size) .OR. indx .LT. 1 ) THEN sts = SS$_SUBRNG ELSEC list(indx) = string1 sts = STR$COPY_DX( %REF(list(indx)), string) END IF Put_Inp_Element = sts RETURN END !of Put_Inp_ElementH INTEGER FUNCTION Search_Inp_List ( size, list, target, wildcard ) !C ! Search an array of dyanamic string descriptors for a specifiedB ! string; return its index if found, 0 otherwise. [If the listF ! size is negative then return the negative of the index if found.] ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptors C input: INTEGER *4 size RECORD /dsc/ list(*) CHARACTER *(*) target LOGICAL wildcard C local:K RECORD /dsc_d/ last_target !pre-initialized dynamic string descriptor INTEGER indx, abs_size LOGICAL found, reverse DATA indx /0/! SAVE indx !, last_targetC functions: INTEGER *4 STR$MATCH_WILD5 INTEGER STR$COMPARE, STR$CASE_BLIND_COMPARE INTRINSIC ABS5 IF ( STR$COMPARE( target, last_target) .NE. 0 ) THEN found = .FALSE.  reverse = ( size .LT. 0 ) abs_size = ABS(size) indx = 05*(old) IF ( reverse ) indx = 1 !skip "-"6 DO WHILE ( indx .LT. abs_size .AND. .NOT. found ) indx = indx + 1K found = LEN(target) .NE. 0 !(require explicit match for null string)D & .AND. STR$COMPARE( target, list(indx)) .EQ. 0 IF ( .NOT. found )H & found = STR$CASE_BLIND_COMPARE( target, list(indx)) .EQ.0# IF ( .NOT. found .AND. wildcard )H &  found = STR$MATCH_WILD( target, list(indx)).AND.1 END DO! IF ( .NOT. found ) indx = 0! IF ( reverse ) indx = -indx;C save target (and result) for comparison next time+ CALL STR$COPY_DX( last_target, target) END IF Search_Inp_List = indx RETURN END !of Search_Inp_List> INTEGER *4 FUNCTION Expand_Inp_List ( list_size, list ) !2 ! Expand a dynamic array of string descriptors. ! implicit noneC constant:? INCLUDE 'f_inc:Dsc.F' !($DSCdef) descriptorsD PARAMETER eLEMENT_SIZE = 8, !size of descriptor0 & eXPANSION_INCREMENT = 10 C input:C input/output: INTEGER *4 list_size INTEGER *4 list C local:K RECORD /dsc_d/ empty_dynamic !pre-initialized dynamic string descriptor INTEGER loop/ INTEGER *4 new_adr, new_size, old_size,% & address, stsC functions:* INTEGER *4 LIB$GET_VM, LIB$FREE_VM,K & OTS$MOVE3 !MOVC3 but without 65535 byte limit INTRINSIC MINF new_size = list_size + eXPANSION_INCREMENT !increase by 10 slots4 sts = LIB$GET_VM( new_size * eLEMENT_SIZE, new_adr) IF ( sts ) THEN old_size = list_size IF ( old_size .GT. 0 ) THEN1 sts = OTS$MOVE3( %VAL(old_size * eLEMENT_SIZE),: & %VAL(list), %VAL(new_adr)) IF ( sts )G & sts = LIB$FREE_VM( old_size * eLEMENT_SIZE, %VAL(list)) END IF%C fill in empty (new) entries0 address = new_adr + old_size * eLEMENT_SIZEA DO loop = 1, eXPANSION_INCREMENT ! old_size + 1, new_size: CALL OTS$MOVE3( %VAL(eLEMENT_SIZE), %REF(empty_dynamic),- & %VAL(address))" address = address + eLEMENT_SIZE END DO list_size = new_size list = new_adr END IF Expand_Inp_List = sts RETURN END !of Expand_Inp_List, INTEGE R *4 FUNCTION Output ( string ) ! ! Write out a string. ! implicit noneC constant:E INCLUDE '($SSdef)/nolist' !system service status codes: INCLUDE '($RMSdef)/nolist' !RMS status codes@ INCLUDE '($FABdef)/nolist' !file-access-block defsB INCLUDE '($RABdef)/nolist' !record-access-block defs> INCLUDE '($NAMdef)/nolist' !file name block defs5 INCLUDE '($DEVdef)/nolist' !device defsD INCLUDE '($DVIdef )/nolist' !device & volume info codes; BYTE fAB_PROTOTYPE(2) / FAB$C_BID, FAB$C_BLN /; BYTE rAB_PROTOTYPE(2) / RAB$C_BID, RAB$C_BLN /; BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN /! PARAMETER rETRY_LIMIT = 10C additional entries below:D INTEGER *4 Block_Output, !use $write instead of $putJ & Flush_Output, !update output with $flushO & Open_Output, !exp licitly open an output fileM & Close_Output ! " close the " "C global input:6 COMMON /output_usropn/ usropn_routine, usropn_contextI INTEGER *4 usropn_routine /0/, !address of routine to process -P & usropn_context /0/ !+ fab/rab/nam prior to $create. C input:: CHARACTER *(*) string, !string to output@ & default_name !for Open_Output C output:: INTEGER width !from Open_Output C local: RECORD /fabdef/ fab RECORD /rabdef/ rab RECORD /namdef/ nam# CHARACTER *255 filename, buf *40- INTEGER *2 filnamlen, ln, retry_count INTEGER *4 len_tmp INTEGER *2 len_word BYTE len_byte. EQUIVALENCE ( len_tmp, len_word, len_byte )? INTEGER *4 sts, clists, removed_privs(2), arglist(0:4)" LOGICAL is_open /.FALSE./ SAVE is_open !, rabC functions:- INTEGER *4 Cli_Present, Cli_Get_Value,% & OTS$CVT_TI_L,1 & SYS$CREATE, SYS$CONNECT,8 & SYS$PUT, SYS$WRITE, SYS$FLUSH,3 & SYS$CLOSE, SYS$DISCONNECT,& & LIB$PUT_OUTPUT" INTRINSIC LEN, MIN, ICHAR IF ( is_open ) THENC set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_word! rab.rab$l_rbf = %LOC(string)&C write record & c heck results retry_count = 0+ DO WHILE ( SYS$PUT( rab) .EQ. RMS$_RSA: & .AND. retry_count .LT. rETRY_LIMIT )A CALL SYS$WAIT( rab) !if record stream active, wait & repeat retry_count = retry_count + 1 END DO sts = rab.rab$l_sts@ IF ( sts .EQ. RMS$_EXT !did we fail to extend?J & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota?A & sts = SYS$PUT( rab) !if so, try again ELSEEC   [ no explicit open was performed (or it was unsuccessful) ]" sts = LIB$PUT_OUTPUT( string) END IF Output = sts RETURN**$ ENTRY Block_Output ( string ) !B ! Use block i/o instead of record i/o; asynchronous contortions9 ! are not performed. Validity checks are left to RMS. !C set up record buffer len_tmp = LEN(string) rab.rab$w_rsz = len_word rab.rab$l_rbf = %LOC(string)!C write block & check results sts = SYS$WRITE( rab)< IF ( sts  .EQ. RMS$_EXT !did we fail to extend?F & .AND. rab.rab$l_stv .EQ. SS$_EXDISKQUOTA ) !due to quota?= & sts = SYS$WRITE( rab) !if so, try again Block_Output = sts Output = sts RETURN** ENTRY Flush_Output ( ) ! ! Update output with $FLUSH. ! sts = SYS$FLUSH( rab) Flush_Output = sts RETURN**0 ENTRY Open_Output ( default_name, width ) !7 ! Open output file and determine desired line width.< ! If th e width has not been specified on the command lineA ! then use the default value: tty width for terminals, 80 forE ! mailbox or network channels, 132 otherwise (ie, for disk files). !C ! Be sure not to risk compromising system security if this image@ ! has been installed with SYSPRV. (/output=sys$system:xxxx!) !=C retreive filename from command line: /output='filename' filnamlen = 0# IF ( Cli_Present( 'OUTPUT') ) THEN; clists = Cli_Get_Value( 'OUTPUT', filename, f ilnamlen) END IF"C initialize File Access BlockF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...A fab.fab$l_fop = FAB$M_MXV .OR. FAB$M_SQO .OR. FAB$M_TEF !options6 fab.fab$b_fac = FAB$M_PUT !write access/!-note: shr.shrget is incompatable with fop.tefB!- fab.fab$b_shr = FAB$M_SHRGET !others can readH!-!- & .OR. FAB$M_SHRPUT .OR. FAB$M_UPI .OR. FAB$M_MSEA fab.fab$b_rat = FAB$M_CR !implied carriage  return9 fab.fab$b_rfm = FAB$C_VAR !variable length IF ( filnamlen .GT. 0 ) THEN; len_tmp = MIN( filnamlen, '00FF'x) !max length is 2558 fab.fab$b_fns = len_byte !file name size; fab.fab$l_fna = %LOC(filename) !file name address* ELSE IF ( LEN(default_name) .EQ. 0 ) THEN& fab.fab$b_fns = LEN('SYS$OUTPUT')' fab.fab$l_fna = %LOC('SYS$OUTPUT') END IF; fab.fab$b_dns = LEN(default_name) !default name size> fab.fab$l_dna = %LOC(de fault_name) !default name address; fab.fab$l_nam = %LOC(nam) !link NAM with FAB C initialize file NAMe blockM CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !NAM (for device name)!* nam.nam$b_nop = NAM$M_PWD.* len_tmp = MIN( LEN(realname), '00FF'x) * nam.nam$b_rss = len_byte&* nam.nam$l_rsa = %LOC(realname)$C initialize Record Access BlockF CALL LIB$MOVC5( 2, rAB_PROTOTYPE, 0, RAB$C_BLN, rab) !bid,bln,0...; rab.rab$l_rop = 0  !no special record options- rab.rab$l_fab = %LOC(fab) !link to FAB" IF ( usropn_routine .NE. 0 ) THENFC kludge to transparently provide useropen-like functionality;IC issue a call-back prior to $create (return status ignored):CC call 'usropn_routine'( usropn_context, fab, rab, nam)0 arglist(0) = 4 !4 args in list arglist(1) = usropn_context arglist(2) = %LOC(fab) arglist(3) = %LOC(rab) arglist(4) = %LOC(nam)3 CALL LIB$CALLG( arglist, %VAL(usropn_routine)) END IFHC disable any privileges that this image was installed with that the0C user doesn't have in his/her own right- CALL Disable_Installed_Privs( removed_privs) sts = SYS$CREATE( fab) IF ( sts ) THEN sts = SYS$CONNECT( rab)+ IF ( .NOT. sts ) CALL SYS$CLOSE( fab)@* [ if ( sts ) define/user_mode sys$output 'realname' ] END IF! is_open = ( (sts.AND.1) .EQ. 1 )6C if any pri vileges were removed, restore them now< IF ( removed_privs(1) .NE. 0 .OR. removed_privs(2) .NE. 0 )B & CALL SYS$SETPRV( %VAL(1), removed_privs, %VAL(0),) width = 0, IF ( sts .AND. Cli_Present( 'WIDTH') ) THEN. clists = Cli_Get_Value( 'WIDTH', buf, ln)" IF ( clists .AND. ln .GT. 0 ); & clists = OTS$CVT_TI_L( buf(:ln), width) END IF# IF ( sts .AND. width .LE. 0 ) THEN7 IF ( (fab.fab$l_dev .AND. DEV$M_TRM) .NE. 0 ) THEN ln = ICHAR(nam.nam$t_dvi(1:1)): CALL LIB$GETDVI( DVI$_DEVBUFSIZ,, nam.nam$t_dvi(2:1+ln),( & width,,)! IF ( width .LE. 0 ) width = 80? ELSE IF ( (fab.fab$l_dev .AND. (DEV$M_MBX .OR. DEV$M_NET))" & .NE. 0 ) THEN width = 80 ELSE width = 132 END IF END IF Open_Output = sts RETURN** ENTRY Close_Output ( ) ! ! Close the file. ! sts = SYS$DISCONNECT( rab) CALL SYS$CLOSE( fab) if ( sts ) sts = fab.fab$l_sts4 if ( sts .eq. RMS$_NORMAL ) sts = 1 !SS$_NORMAL is_open = .false. Close_Output = sts RETURNL END !of Output, Block_Output, Flush_Output, Open_Output & Close_OutputB LOGICAL FUNCTION Disable_Installed_Privs ( disabled_privs ) !> ! Disable any privileges that this image has been installed, ! with that the user didn't already have. ! implicit noneC constant:< INCLUDE '($JPIdef)/nolist' !job & process info= INCLUDE 'f_inc:Itm.F'  !item list structure C output:8 INTEGER *4 disabled_privs(2) !privilege mask C local:3 RECORD /itmlst/ privs(3) !item list* INTEGER *4 procpriv(2), imagpriv(2) LOGICAL disable% privs(1).itm_length = ITM_S_QUADWORD# privs(1).itm_code = JPI$_CURPRIV% privs(1).itm_bufadr = %LOC(procpriv)% privs(2).itm_length = ITM_S_QUADWORD$ privs(2).itm_code = JPI$_IMAGPRIV% privs(2).itm_bufadr = %LOC(imagpriv)( privs(3).itm_code = ITM_K_END_OF_LIST imagpriv(1) = 0 imagpriv(2) = 0 CALL SYS$GETJPIW(,,, privs,,,)8 disabled_privs(1) = imagpriv(1) .AND. .NOT. procpriv(1)8 disabled_privs(2) = imagpriv(2) .AND. .NOT. procpriv(2)% disable = ( disabled_privs(1) .NE. 0. & .OR. disabled_privs(2) .NE. 0 ) IF ( disable )C & CALL SYS$SETPRV( %VAL(0), disabled_privs, %VAL(0),)" Disable_Installed_Privs = disable RETURN% END !of Disable_Installed_Privs8 INTEGER *4 FUNCTION  PutMsg ( facility, sts, stv ) !! ! Rudimentary message routine. ! implicit none C input: CHARACTER *(*) facility INTEGER *4 sts, stv C local INTEGER *4 msgvec(0:4) INTEGER *4 SYS$PUTMSG' msgvec(0) = 1 !1 arg follows msgvec(1) = sts msgvec(2) = 0 IF ( %LOC(stv) .NE. 0 ) THEN, msgvec(0) = 2 !make that two args msgvec(2) = stv END IF msgvec(3) = 0 msgvec(4) = 0) PutMsg = SYS$PUTMSG( msgvec,, facility,) RETURN END !of PutMsgB INTEGER *4 FUNCTION Parse_Node ( in_name, outname, outlen ) !F ! Use RMS to extract a node name (let it handle any logical names). ! implicit noneC constant: INCLUDE '($RMSdef)/nolist' INCLUDE '($FABdef)/nolist' INCLUDE '($NAMdef)/nolist'; BYTE fAB_PROTOTYPE(2) / FAB$C_BID, FAB$C_BLN /; BYTE nAM_PROTOTYPE(2) / NAM$C_BID, NAM$C_BLN / INTEGER *4 fILE_NAME_BITS? PARAMETER ( fILE_NAME_BITS = NAM$M_NODE .OR. NAM$M_EXP_DEVF & .OR. NAM$M_EXP_DIR .OR. NAM$M_EXP_NAMEH & .OR. NAM$M_EXP_TYPE .OR. NAM$M_EXP_VER ) C input: CHARACTER *(*) in_name C output: CHARACTER *(*) outname INTEGER *2 outlen C local: RECORD /fabdef/ fab RECORD /namdef/ nam CHARACTER *256 work_string INTEGER len_tmp, pos BYTE len_byte$ EQUIVALENCE ( len_tmp, len_byte ) INTEGER *4 stsC functions:  INTEGER *4 SYS$PARSE) INTRINSIC LEN, MIN, INDEX, ZEXTF CALL LIB$MOVC5( 2, fAB_PROTOTYPE, 0, FAB$C_BLN, fab) !bid,bln,0...C len_tmp = MIN( LEN(in_name), '00FF'x) !max length is 2558 fab.fab$b_fns = len_byte !file name size; fab.fab$l_fna = %LOC(in_name) !file name address> fab.fab$l_nam = %LOC(nam) !pointer to NAM blockF CALL LIB$MOVC5( 2, nAM_PROTOTYPE, 0, NAM$C_BLN, nam) !bid,bln,0...C len_tmp = MIN( LEN(work_string) , '00FF'x) !max length is 255> nam.nam$b_ess = len_byte !expanded string size> nam.nam$l_esa = %LOC(work_string) !expanded string areaD nam.nam$b_nop = NAM$M_SYNCHK !options: syntax check only sts = SYS$PARSE( fab) IF ( sts ) THEN8 IF ( (nam.nam$l_fnb .AND. NAM$M_NODE) .NE. 0 ) THEN len_tmp = ZEXT(nam.nam$b_node)= pos = INDEX( work_string(:len_tmp), '"') !find quote IF ( pos .GT. 0 ) THEN= len_tmp = pos - 1 !drop ac cess control string ELSE: len_tmp = len_tmp - 2 !drop punctuation ("::") END IF3 ELSE IF ( (nam.nam$l_fnb .AND. fILE_NAME_BITS)2 & .EQ. NAM$M_EXP_NAME ) THENBC no punctuation present -- use name field as nodename len_tmp = ZEXT(nam.nam$b_name)( CALL STR$COPY_R( work_string, len_tmp,5 & %VAL(nam.nam$l_name)) ELSEGC missing node name: return "RMS-W-NOD, error in node name"> sts = RMS$_NOD .AND. .NOT. '00000007'x !set severity to "W"> len_tmp = ZEXT(nam.nam$b_esl) !return entire string anyway END IF$ outname = work_string(:len_tmp) outlen = len_tmp ELSE outname = in_name outlen = LEN(in_name) END IF$ outlen = MIN( outlen, LEN(outname)) Parse_Node = sts RETURN END !of Parse_Node/ LOGICAL FUNCTION Node_Avail ( nodename ) !A ! Determine whether the specified node is part of the cluster.D ! Used by XSHOQUE to decide whether to display 'host unavailable'# ! when it shows a stopped queue. ! implicit noneC constant: INCLUDE '($SYIdef)/nolist' C input: CHARACTER *(*) nodename C local: LOGICAL avail INTEGER *4 sts, member INTEGER standalone /0/ SAVE standaloneC functions: INTEGER *4 LIB$GETSYI IF ( standalone ) THEN:C known to be non-clustered, so always return True avail = .TRUE.= ELSE IF ( LEN(noden ame) .EQ. 0 .OR. nodename .EQ. ' ' ) THENNC assumed non-cluster, so return True unless we're sure it's a cluster avail = (standalone .NE. 2) ELSE member = 07 sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, ,& & nodename)' avail = ( (member .AND. 1).EQ. 1 )OC additional code added to support standalone system w/ SCSNODE defined" IF ( standalone .EQ. 0 ) THEN IF ( avail ) THEN4 standalone = 2 !now known to be a cluster0 ELSE !check whether we're part of a cluster9 sts = LIB$GETSYI( SYI$_CLUSTER_MEMBER, member,,, ,) IF ( member ) THEN standalone = 2 ELSE; standalone = 1 !not a cluster (Should compare nodename-; avail = .TRUE. !assume ok (+ w/ our system's name.) END IF END IF END IF END IF Node_Avail = avail RETURN END !of Node_AvailD INTEGER *4 FUNCTION Parse_Keywords( qual_name, keywrd_count,E &   keywords, synonyms, masks) !; ! Parse for a set of keywords and set up a mask longword. ! based on their corresponding mask values. ! implicit noneC constant:8 INCLUDE 'f_inc:Cli.F' !command interface defs C input: CHARACTER *(*) qual_name INTEGER keywrd_count. CHARACTER *(*) keywords(0:*), synonyms(0:*) INTEGER *4 masks(0:*) C local: CHARACTER *32 qual_tmp INTEGER *2 ln INTEGER idx0 I!NTEGER *4 exp_incl, exp_excl, imp_excl,- & result, sts, tmpstsC functions: INTEGER *4 Cli_Present INTEGER LIB$MATCH_COND result = 0 sts = Cli_Present( qual_name) IF ( sts ) THEN4 exp_incl = 0 !explicitly included4 exp_excl = 0 !explicitly excluded4 imp_excl = 0 !implicitly excluded DO idx = 0, keywrd_count2 CALL STR$TRIM( qual_tmp, keywords(idx), ln)8 sts = Cli_P "resent( qual_name//'.'//qual_tmp(:ln))= IF ( LIB$MATCH_COND( sts, CLI$_ABSENT, CLI$_DEFAULTED) & .GT. 0 ) THEN!C check for synonym. CALL STR$TRIM( qual_tmp, synonyms(idx), ln) IF ( ln .GT. 0 ) THEN: tmpsts = Cli_Present( qual_name//'.'//qual_tmp(:ln))0 IF ( LIB$MATCH_COND( tmpsts, CLI$_PRESENT,E & CLI$_NEGATED, CLI$_DEFAULTED)/ & .GT. 0 ) sts = tmpsts END IF END I#F IF ( sts ) THEN& exp_incl = exp_incl .OR. masks(idx)> exp_excl = exp_excl .AND. .NOT. masks(idx) !clear NOALLA ELSE IF ( LIB$MATCH_COND( sts, CLI$_NEGATED) .GT. 0 ) THEN& exp_excl = exp_excl .OR. masks(idx)" ELSE IF ( idx .NE. 0 ) THEN& imp_excl = imp_excl .OR. masks(idx) END IF END DO IF ( exp_incl .NE. 0 ) THEN- result = exp_incl .AND. .NOT. exp_excl$ ELSE IF ( exp_excl .NE. 0 ) THEN result = .NOT. exp_excl ELSE result = .NOT. imp_excl END IF END IF Parse_Keywords = result RETURN END !of Parse_Keywordsww_|Ւ /* fh2defI *% * Ods-2 file header definitions  * */E#ifndef FAT$S_FATDEF# include "FATdef.H"#endif#define FH2$C_LEVEL1 257F#define FH2$C_LEVEL2 512X#define FH2$M_NOBACKUP 2 #define FH2$M_WRITEBACK 4%#define FH2$M_READCHECK 8S#define FH2$M_WRITCHECK 16#define FH2$M_CONTIGB 32#define FH2$M_LOCKED 64#define FH2$M_CONTIG 0x0080#define FH2$M_BADACL 0x0800#define FH2$M_SPOOL 0x1000#define FH2$M_DIRECTORY 0x2000#define FH &@|Ւ/* Format.For -- formatting routines for XShow*-* sub Fmt_UIC ( uic, code, result, reslen ):* sub Fmt_Protctn ( prot_mask, options, result, reslen )1* sub Fmt_Cpu_Time ( cpu_time, result, reslen )+* sub Fmt_File_ID ( fid, result, reslen ),* i Fmt_BitMask ( array, size, buf, ln )4* i Fmt_Strings ( array, length, size, buf, ln ) * i BufOut ( outstr, flags )* " Buf_Flush ( flags )!* " Set_Indent ( new_indent ) * " Set_Margin ( new_w'idth )* i BufBrk_Index ( string )*7 SUBROUTINE Fmt_UIC ( uic, code, result, reslen ) !B ! Format User-Identification-Code (longword uic or identifier). ! implicit none c input: INTEGER *4 uic INTEGER code c output: CHARACTER *(*) result INTEGER *2 reslen c local:" CHARACTER buf *24, fmt *12 INTEGER *2 ln, flen% LOGICAL identifier, numericc functions:* INTEGER STR$FIND_FIRST_NOT_IN_SET (' identifier = ( (code .AND. 1) .NE. 0 )' numeric = ( (code .AND. 2) .NE. 0 ) reslen = 0 IF ( identifier ) THENFc format as an alpha-numeric user id code or rights identifier5 CALL SYS$FAO( '!%I', reslen, result, %VAL(uic) )Nc if all we got was a numeric result then make sure we don't repeat it0 IF( numeric .AND. result(1:1) .EQ. '%' .OR.H & STR$FIND_FIRST_NOT_IN_SET( result(:reslen), '[0123,4567]')* & .EQ. 0 ) numeric = .FALSE.) END IF IF ( numeric ) THENAc format as a numeric uic or hexidecimal identifier value ln = 0 IF ( uic .GT. 0 ) THEN" CALL STR$TRIM( fmt, '!%U', flen) ELSE& CALL STR$TRIM( fmt, '%x!08UL', flen) END IFF IF ( identifier ) THEN !if both, parenthesize numeric result fmt = '('//fmt(:flen)//')' flen = 1 + flen + 1 END IF3 CALL SYS$FAO( fmt(:flen), ln, buf, %VAL(uic) )! result(reslen+1:) = buf(:ln) reslen = reslen + ln* END IF RETURN END !Fmt_UICD SUBROUTINE Fmt_Protctn ( prot_mask, options, result, reslen ) !C ! Format file protection mask (standard four access modes only). ! implicit none c input: INTEGER *2 prot_maskM INTEGER options !so far, only single character category name c output: CHARACTER *(*) result INTEGER *2 reslen c local: CHARACTER *48 buf, INTEGER *2 ln, ltmp, i, mask, prot@ CHARACTER pty +pe(4) *6 /'SYSTEM','OWNER','GROUP','WORLD'/,C & trail(4) *1 / 3*',',')' /, punct *1 /':'/,D & disp(0:15) *4 / 'RWED', 'WED', 'RED', 'ED' ,D & 'RWD' , 'WD' , 'RD' , 'D' ,D & 'RWE' , 'WE' , 'RE' , 'E' ,E & 'RW' , 'W' , 'R' , ' ' /& SAVE ptype, trail, punct, dispc functions: INTRINSIC IAND, ISHFT CALL STR$TRIM( ,buf, '(', ln) prot = prot_mask DO i = 1, 4 mask = IAND( prot, '000F'x) prot = ISHFT( prot, -4)/ CALL STR$TRIM( buf(ln+1:), ptype(i), ltmp)D IF ( options .AND. 1 ) ltmp = 1 !single character type name ln = ln + ltmp IF ( mask .NE. '0F'x ) THEN5 CALL STR$TRIM( buf(ln+1:), punct//disp(mask), ltmp) ln = ln + ltmp END IF buf(ln+1:ln+1) = trail(i) ln = ln + 1 END DO) CALL STR$TRIM( result, buf(:ln), reslen) RETURN END !F-mt_Protctn; SUBROUTINE Fmt_Cpu_Time ( cpu_time, result, reslen ) !@ ! Format cpu time (10-millisecond units [ie, 1/100 seconds]).7 ! First convert it into standard quadword delta timeA ! (100-nanosecond units [ie, 10**-7 seconds]); then format it;E ! finally, clean it up a bit (drop "0" days, drop ".00" fraction). ! implicit none c input: INTEGER *4 cpu_time c output: CHARACTER *(*) result INTEGER *2 reslen c local: CHARACTER * .32 buf INTEGER *2 ln, pos INTEGER *4 scale,1 & cputmp(2) !quadwordc functions: INTEGER LIB$SKPC IF ( cpu_time .NE. 0 ) THEN<c convert to quadword delta time (which is negative)F scale = -(10**7/100) !conversion factor: 1/100th's to quadtimeNc (if it looks negative, when its actually a large unsigned value,Lc change sign of scale factor to compensate during signed mult)K IF ( cpu_time ./LT. 0 ) scale = -scale !extend range of longword timeJ CALL LIB$EMUL( cpu_time, scale, 0, cputmp) !cputmp:=cpu_time*scale+0c format the delta time* CALL SYS$FAO( '!%D', ln, buf, cputmp) ELSECc delta value of zero (instead of base date of 17-NOV-1858)( CALL STR$TRIM( buf, '00:00:00', ln) END IF= IF ( buf(1:5) .EQ. ' 0 ' ) THEN !drop zero day field) CALL STR$TRIM( buf, buf(5+1:ln), ln) ELSE# pos = LIB$SKPC( ' ', buf(:ln))> IF 0( buf(5:5) .EQ. ' ' .AND. pos .LT. 5 ) buf(5:5) = '-' IF ( pos .GT. 0 ) THEN buf = buf(pos:ln) ln = ln - (pos - 1) END IF END IF< IF ( ln .GT. 3 .AND. buf(ln-2:ln) .EQ. '.00' ) ln = ln - 3) CALL STR$TRIM( result, buf(:ln), reslen) RETURN END !of Fmt_Cpu_Time5 SUBROUTINE Fmt_File_ID ( fid, result, reslen ) !? ! Format a 3-word file id (disk format assumed; tape differs: ! slightly). The file number is comprised of the first, ! two1 bytes (low word) and the last byte. !) ! nnnn,iiii,NNvv -> NNnnnn,iiii,vv ! implicit none STRUCTURE /file_id/ UNION MAP INTEGER *2 fid(3) END MAP MAP INTEGER *2 fid_num, fid_seq BYTE fid_rvn, fid_nmx END MAP END UNION END STRUCTURE !file_id STRUCTURE /fid_cvt/ UNION MAP INTEGER *4 file_number END MAP MAP INTEGER *2 fid_num BYTE fid_nmx, %fill END MAP END UNION END STRUCTU2RE !fid_cvt c input: RECORD /file_id/ fid c output: CHARACTER *(*) result INTEGER *2 reslen c local: RECORD /fid_cvt/ wrk3 wrk.file_number = 0 !clear all 4 bytes2 wrk.fid_num = fid.fid_num !load low 2 bytes/ wrk.fid_nmx = fid.fid_nmx !load 3rd byte/ CALL SYS$FAO( '(!UL,!UW,!UB)', reslen, result,L & %VAL(wrk.file_number), !extended numberN & %VAL(fid.fid_seq), %VAL(fid.fid_rvn) ) 3!sequence & volume RETURN END !of Fmt_File_ID< INTEGER FUNCTION Fmt_BitMask ( array, size, buf, ln ) !E ! Format, as a comma separated list, all set bits in a byte array.$ ! [for queue/job characteristics] ! implicit none c input: INTEGER size INTEGER *4 array(*) c output: CHARACTER *(*) buf INTEGER *2 ln c local:2 INTEGER idx, pos, extra, limit, count INTEGER *2 ltmp LOGICAL got_bits4c functions: INTEGER LIB$FFS! INTRINSIC IAND, LEN, MIN buf = ' ' ln = 0 count = 0 got_bits = .FALSE.'c find out whether any bits are set idx = 03 DO WHILE ( idx .LT. size/32 .AND. .NOT. got_bits ) idx = idx + 1% got_bits = ( array(idx) .NE. 0 ) END DO extra = IAND( size, 31). IF ( extra .NE. 0 .AND. .NOT. got_bits ) THEN idx = idx + 1: got_bits = LIB$FFS( 0, extra, array(idx), pos) .NE. 0 END IF2c if so, format them5 as a comma separated list IF ( got_bits ) THEN- DO WHILE ( idx .LE. (size + 32 - 1)/32 ) pos = -1 limit = 32: IF ( extra .NE. 0 .AND. idx .GT. size/32 ) limit = extra DO WHILE ( pos .LT. limit )/ IF ( LIB$FFS( pos + 1, limit - (pos + 1),8 & array(idx), pos) ) THEN count = count + 1 IF ( ln .LT. LEN(buf) ) THEN. CALL SYS$FAO( '!UB,', ltmp, buf(ln+1:),A & %VAL((idx-1)*32 + pos) ) l6n = ln + ltmp END IF END IF END DO idx = idx + 1 END DOA ln = MIN( ln - 1, LEN(buf) ) !(remove trailing comma) END IF Fmt_BitMask = count RETURN END !of Fmt_BitMaskD INTEGER FUNCTION Fmt_Strings ( array, length, size, buf, ln ) !C ! Format an array into a comma separated list of quoted strings. ! [for job parameters] ! implicit none c input: INTEGER size CHARACTER *(*) array(*) INTEGER *2 7 length(*) c output: CHARACTER *(*) buf INTEGER *2 ln c local: INTEGER idx, countc functions: INTRINSIC LEN, MIN count = size"c ignore trailing null strings5 DO WHILE ( count .GT. 0 .AND. length(count) .EQ. 0 ) count = count - 1 END DOc concatenate the list ln = 0 idx = 03 DO WHILE ( idx .LT. count .AND. ln .LT. LEN(buf) ) idx = idx + 19 buf(ln+1:) = '"' // array(idx)(:length(idx)) // '",'" ln = ln + 18 + length(idx) + 2 END DOG IF ( ln .GT. 0 ) ln = MIN( ln - 1, LEN(buf) ) !remove trailing comma Fmt_Strings = count RETURN END !of Fmt_Strings0 INTEGER FUNCTION BufOut ( outstr, flags ) !F ! Buffered output routine. (Optionally breaking long strings after- ! commas adds a great deal of complexity.) ! implicit nonec constant:A PARAMETER fLUSH_BUF = 1, oUTPUT_NOW = 2, cOMMA_BREAK = 4c alternate entry points:4 INTEGER Buf9_Flush, Set_Indent, Set_Margin c input: CHARACTER *(*) outstr INTEGER flags' INTEGER new_indent, new_width c local:' CHARACTER *512 buffer, dash *1 /'-'/> INTEGER *2 buflen /0/, offset, p, pos, next, adjust5 INTEGER indent /0/, width /80/, old_indent0 SAVE buffer, buflen, indent, width, dashc functions: INTEGER BufBrk_Index INTRINSIC LEN, MIN, MAX pos = 0( IF ( (flags .AND. cOMMA_BREAK) .NE. 0 )+ : & pos = BufBrk_Index( outstr)% IF ( pos .EQ. 0 ) pos = LEN(outstr)@ IF ( buflen .GT. indent .AND. ( (flags .AND. fLUSH_BUF) .NE. 0H & .OR. buflen + pos .GE. width ) ) THEN" CALL Output( buffer(:buflen)) buffer = ' ' buflen = indent END IF1 p = 1 !start of outstr DO WHILE ( p .LE. LEN(outstr) ) pos = 0 offset = 0* IF ( (flags .AND. cOMMA_BREAK) .NE. 0? & .AND. (buflen +; LEN(outstr) - p) .GE. width ) THEN" next = BufBrk_Index( outstr(p:)) DO WHILE ( next .GT. pos> & .AND. buflen + next + 1 .LE. width ) pos = next0 next = pos + BufBrk_Index( outstr(p+pos:)) END DO IF ( pos .EQ. 0 ) pos = next offset = 1 END IF3 IF ( pos .EQ. 0 ) pos = LEN(outstr) - (p - 1), IF ( (buflen + pos + offset) .GT. width6 & .AND. buflen .GT. indent + offset ) THEN CALL Output( buffer(:buflen)) buffer =< ' ' buflen = indent + offset END IF, IF ( (buflen + pos + offset) .GE. width' & .OR. offset .GT. 0 ) THEN CALL Output( buffer(:buflen)A & // outstr(p:p+pos-1)// dash(:offset)) buffer = ' ' buflen = indent + offset4 IF ( outstr(p+pos:p+pos) .EQ. ' ' ) pos = pos + 1 ELSE' buffer(buflen+1:) = outstr(p:p+pos-1) buflen = buflen + pos END IF p = p + pos END DOA IF ( ( (flags .AND. oUTPUT_NOW).NE. 0 .AND. buf=len .GT. indent )' & .OR. buflen .GE. width ) THEN" CALL Output( buffer(:buflen)) buffer = ' ' buflen = indent END IF BufOut = buflen - indent RETURN** ENTRY Buf_Flush ( flags ) !+ ! Flush output buffer if it's not empty. ! Buf_Flush = buflen - indent IF ( buflen .GT. 00 & .AND. ( (flags .AND. fLUSH_BUF) .NE. 05 & .OR. buffer(:buflen) .NE. ' ' ) ) THEN# CALL Output( buffer(:buflen) ) END IF buffer = ' '> buflen = indent RETURN**& ENTRY Set_Indent ( new_indent ) !A ! Set the indentation level (and return the previous setting). ! old_indent = indent1 indent = MIN( MAX(new_indent,0), LEN(buffer)/2 ) IF ( buflen .EQ. 0 .OR.H & buflen .LE. old_indent .AND. buffer(:buflen) .EQ. ' ' ) THEN buffer = ' ' buflen = indent END IF Set_Indent = old_indent RETURN**% ENTRY Set_Margin ( new_width ) !< ! Set the right margin (and return the ?previous setting). ! Set_Margin = width. width = MIN( MAX(new_width,16), LEN(buffer) ) RETURN+ END !BufOut, Set_Indent, & Set_Margin/ INTEGER FUNCTION BufBrk_Index ( string ) !B ! Find first "," or "; " (note trailing space with semi-colon). ! implicit nonec called by:* subroutien BufOut c input: CHARACTER *(*) string c local: INTEGER indx, itmpc functions: INTRINSIC INDEX indx = INDEX( string, ',' ) itmp = INDEX( string, '; ')9 IF ( indx .EQ. 0 .OR. itmp .NE. 0 .AND. itmp .LT. indx ) & indx = itmp BufBrk_Index = indx RETURN END !of BufBrk_Indexww AF |Ւ)* XShoQue.F -- include file for XShoQueH* Pat Rankin, 5/88* LOGICAL pRINT, bATCH7 PARAMETER ( pRINT = .TRUE., bATCH = .NOT. pRINT ) COMMON /options/F & do_all_full, do_que_full, do_job_full, do_files,E & do_forms, do_chars, do_bat, do_dev, do_restart,L & do_summary, compress, batch_only, device_only, !V5*( & all_jobs B, any_job,@ & job_status_mask, show_if_mask, devtyp_mask9 INTEGER *4 do_all_full, do_que_full, do_job_full,H & do_files, do_forms, do_chars, do_bat, do_dev,L & do_summary, compress, all_jobs, !V5*B & job_status_mask, show_if_mask, devtyp_mask@ LOGICAL do_restart, batch_only, device_only, any_job COMMON /dyn_lists/4 & excl_list, excl_siz, excl_cnt,4 & C node_list, node_siz, node_cnt,4 & user_list, user_siz, user_cnt,4 & entr_list, entr_siz, entr_cnt,3 & que_list, que_siz, que_cnt,3 & jbnm_list, jbnm_siz, jbnm_cnt? INTEGER *4 excl_list, node_list, user_list, entr_list,E & excl_siz, node_siz, user_siz, entr_siz,E & excl_cnt, node_cnt, user_cnt, entr_cnt,. & que_list, jbnm_list,- & que_siz, jbnm_siz,, & que_cnt, jbnm_cntww Eic INTEGER *4 prot_mask" INTEGER *4 base_priority INTEGER *2 gentrglenE CHARACTER *660 gen_target !~4000 (124*32-1) !V5*K BYTE characteristics(q_CHAR_MASK_SIZE) !bit mask for 0..127E INTEGER *4 pending_cnt !V5+E INTEGER *4 holding_cnt !V5+E INTEGER *4 waiting_cnt !V5+E INTEGER *4 retained_cnt F !V5+E INTEGER *2 dscriplen !V5+E CHARACTER *256 description !(255) !V5+ END STRUCTURE !q_cmnE PARAMETER q_CMN_SIZE = 1024 !V5*c queues: batch specific STRUCTURE /q_bat/ INTEGER *4 job_limit INTEGER *4 cpu_default INTEGER *4 cpu_maximum INTEGER *4 wsdefault INTEGER *4 wsquota INTEGER *G4 wsextent END STRUCTURE !q_bat PARAMETER q_BAT_SIZE = 24c queues: print specific STRUCTURE /q_dev/ INTEGER *2 devnamlen$ CHARACTER *32 device_name !31 INTEGER *2 frmnamlen$ CHARACTER *32 form_name !31 INTEGER *2 frmstklen$ CHARACTER *32 form_stock !31 INTEGER *2 asnquelen, CHARACTER *32 assigned_queue !31 INTEGER *4 min_blocks INTEGER *4 max_blocks INTEGER *2 H deffrmlen, CHARACTER *32 default_form !31 INTEGER *2 defstklen, CHARACTER *32 default_stock !31 INTEGER *2 proceslen, CHARACTER *40 processor !39 INTEGER *2 libnamlen, CHARACTER *40 library !39 INTEGER *2 resetlenE CHARACTER *210 reset !? (?*32-1) !V5*E INTEGER *4 symbiont_flags !V5+ END STRUCTURE !q_dev! PARAMETER I q_DEV_SIZE = 512c jobs: batch & printC PARAMETER cMPLTN_VCTR_SIZ = 4 !size of completion vector STRUCTURE /j_cmn/ INTEGER *4 flags INTEGER *4 status INTEGER *4 entry_num INTEGER *2 jobnamlen$ CHARACTER *40 job_name !39 INTEGER *2 usrnamlen$ CHARACTER *32 username !127 INTEGER *4 after_time(2) !quadword time! INTEGER *4 intrvng_jobs2 INTEGER *4 compltn_stat(cMPLTN J_VCTR_SIZ)7 INTEGER *4 submit_time(2) !quadword timeC INTEGER *4 priority !selection priority 1..255K BYTE characteristics(q_CHAR_MASK_SIZE) !bit mask for 0..127E INTEGER *4 pend_reason !V5+ END STRUCTURE !j_cmnE PARAMETER j_CMN_SIZE = 128 + (4*cMPLTN_VCTR_SIZ) ![144] !V5*c jobs: batch specific STRUCTURE /j_bat/ INTEGER *4 job_pid INTEGER *2 logfillen% CKHARACTER *256 logfile !255 INTEGER *2 prtquelen$ CHARACTER *32 print_queue !31 INTEGER *4 cputime INTEGER *4 wsdefault INTEGER *4 wsquota INTEGER *4 wsextent INTEGER *2 clilen$ CHARACTER *40 cli !39 END STRUCTURE !j_bat! PARAMETER j_BAT_SIZE = 354c jobs: print specific STRUCTURE /j_dev/ INTEGER *4 blocks! INTEGER *4 compltd_blks! INTEGER *4 intrvng_blkLs INTEGER *4 job_count! INTEGER *4 job_cnt_done" INTEGER *4 job_cnt_chkpt INTEGER *2 frmnamlen$ CHARACTER *32 form_name !31 INTEGER *2 frmstklen$ CHARACTER *32 form_stock !31 END STRUCTURE !j_dev PARAMETER j_DEV_SIZE = 92#c jobs: long strings for /full& STRUCTURE /j_str/ !long strings INTEGER *2 notelen% CHARACTER *256 note_text !255 INTEGER *2 oprqstlen! CHARACTER *25M6 oper_request INTEGER *2 parm_len(8)! CHARACTER *256 parameter(8) INTEGER *2 chkptlen% CHARACTER *256 bat_chkpt !255E INTEGER *2 rstrtlen !V5+E CHARACTER *32 restart_queue !31 !V5+ END STRUCTURE !j_strE PARAMETER j_STR_SIZE = 2872 !V5*c files: batch & print STRUCTURE /f_cmn/ INTEGER *4 flags INTEGER *4 statuNs INTEGER *2 filspclen% CHARACTER *256 file_spec !255E INTEGER *2 fid(3) !V5+ END STRUCTURE !f_cmnE PARAMETER f_CMN_SIZE = 272 !V5*c files: print specific STRUCTURE /f_dev/ INTEGER *4 copy_count" INTEGER *4 copy_cnt_done# INTEGER *4 copy_cnt_chkpt INTEGER *4 first_page INTEGER *4 last_page INTEGER *2 setuplen, O CHARACTER *490 setup !? (?*32-1) END STRUCTURE !f_dev! PARAMETER f_DEV_SIZE = 512 c forms STRUCTURE /q_frm/ INTEGER *4 flags INTEGER *4 form_number INTEGER *2 frmnamlen$ CHARACTER *32 form_name !31 INTEGER *2 stknamlen$ CHARACTER *32 stock_name !31 INTEGER *2 descrplen% CHARACTER *256 description !255 INTEGER *4 length INTEGER *4 width UNION MAP INTEGER *4 P top_margin INTEGER *4 left_margin! INTEGER *4 right_margin" INTEGER *4 bottom_margin END MAP MAP INTEGER *4 margin(4) END MAP END UNION INTEGER *2 setuplen, CHARACTER *460 setup !? (?*32-1) INTEGER *2 pagsetlen, CHARACTER *458 page_setup !? (?*32-1) END STRUCTURE !q_frm" PARAMETER q_FRM_SIZE = 1280c characteristics STRUCTURE /q_chr/E INTEGER *4 %FILL !duQmmy, so num & name align w/ q_frm INTEGER *4 char_number INTEGER *2 chrnamlen$ CHARACTER *32 char_name !31 END STRUCTURE !q_chr PARAMETER q_CHR_SIZE = 424c either form or characteristic (common fields) STRUCTURE /frm_or_chr/ UNION MAP RECORD /q_frm/ form END MAP MAP RECORD /q_chr/ qchar END MAP MAP) INTEGER *4 %FILL !(flags)? INTEGER *4 number !form or characteristic number INTEGER *2 namlen= CHARACTER *32 name !form or characteristic name END MAP& END UNION !q_frm or q_chr or fields END STRUCTURE !frm_or_chrA PARAMETER FRM_or_CHR_SIZE = q_FRM_SIZE !MAX(q_FRM,qCHR)ww `I|Ւ-* XShoFiles.F -- include file for XShoFilesH* Pat Rankin, 7/88* COMMON /options/& & sho_acl, sho_rms" INTEGER *4 sho_acl, sho_rms COMMON /dyn_list/3 & spec_list, spec_siz, spec_cnt0 INTEGER *4 spec_list, spec_siz, spec_cntwwTp|Ւ PROGRAM XShoFiles !D ! Pat Rankin, 8/88, 11/88% ! XSHOW FILES or DIRECTORY command ! implicit none c global:B INCLUDE 'XShoFiles.F' !options & dynamic arrays c local: INTEGER optval INTEGER *4 stsc functions:@ INTEGER *4 XShoFiles_Cmd, XShoFiles_Qual, !set upO & XShow_Files, XShow_Directory !retreive & format data optval = 0U8 sts = XShoFiles_Cmd( optval) !process dcl command line IF ( sts ) & sts = XShoFiles_Qual() IF ( .NOT. sts ) THEN* ELSE IF ( optval .EQ. 1 ) THEN sts = XShow_Files() ELSE IF ( optval .EQ. 2 ) THEN sts = XShow_Directory() ELSE * ? END IF CALL EXIT( sts) END !of XShoFiles(main)3 INTEGER *4 FUNCTION XShoFiles_Cmd ( option ) !5 ! Retreive command line info & prepare it for use. ! implicit nonec called by:!* V main XShoFilesc constant:3 INCLUDE 'f_inc:Cli.F' !cli codes c global:B INCLUDE 'XShoFiles.F' !options & dynamic arrays0 DATA spec_list, spec_siz, spec_cnt /3*0/ c output: INTEGER option c local: INTEGER width INTEGER *4 stsc functions: INTEGER *4 Cli_Present,7 & Get_Inp_List, Add_Inp_Element,# & Open_Output% IF ( Cli_PresenWt( 'FILESPEC') ) THEN option = 1A sts = Get_Inp_List( 'FILESPEC', spec_siz, spec_list,spec_cnt)) ELSE IF ( Cli_Present( 'DIRSPEC') ) THEN option = 2A sts = Get_Inp_List( 'DIRSPEC', spec_siz, spec_list, spec_cnt) * ELSE?* sts = Add_Inp_Element( spec_siz, spec_list, 1, '[]')#* IF ( sts ) spec_cnt = 1 END IF+ sts = Open_Output( 'XShoFiles.Lis', width) CALL Set_Margin( width) XShoFiles_Cmd = sts RETURN END !of XShoFiles_CmdX- INTEGER *4 FUNCTION XShoFiles_Qual ( ) ! ! Process common qualifiers ! implicit nonec called by:!* main XShoFilesc constant:3 INCLUDE 'f_inc:Cli.F' !cli codes c global:B INCLUDE 'XShoFiles.F' !options & dynamic arrays c local: INTEGER *4 stsc functions: INTEGER LIB$MATCH_COND INTEGER *4 Cli_Present sts = 1 sho_acl = Cli_Present( 'ACL')) sho_rms = Cli_Present( Y'RMS_ATTRIBUTES') XShoFiles_Qual = sts RETURN END !of XShoFiles_QualG INTEGER *4 FUNCTION Format_File_Info ( as_dir, file_spec, info ) !6 ! Format and display the information retreived from ! the files's header. ! implicit nonec called by:$* function Display_Filec constant:4 INCLUDE '($FABdef)/nolist' !in lieu of $FATdef- PARAMETER FH2$M_CONTIG = '000000080'x,5 & FH2$M_DIRECTORY = '00002000'xZ STRUCTURE /file_info/$ INTEGER *2 fid(3), vers_limit- INTEGER *4 alloc, size, owner, flags* INTEGER *2 protection, revision_cnt UNION MAP INTEGER *4 creat_date(2) INTEGER *4 modif_date(2) INTEGER *4 expir_date(2) INTEGER *4 bckup_date(2) END MAP MAP INTEGER *4 dates(2,4) END MAP END UNION& INTEGER *4 acl_length, acl_part+ INTEGER *4 acl_start !(address)NC items above are common t [o both dir & file, those below are file only> INTEGER *2 did(3), rec_prot, lrl, mrs, def_ext, gbc- BYTE org, rfm, rat, bks, vfc,: & acc_mode, journalling, ru_active INTEGER *4 highwater END STRUCTURE !file_info! INTEGER *4 dIR_FLAGS_IGNORE3 PARAMETER ( dIR_FLAGS_IGNORE = FH2$M_DIRECTORY< & .OR. FH2$M_CONTIG ) CHARACTER *20 filechar(0:31)4 & / ' ', 'No Backup', 'Writeback \ Caching',? & 'Readcheck', 'Writecheck', 'Contiguous Best-try',6 & 'De-access Locked', 'Contiguous', 3*' ',D & 'Invalid Acl', 'Spooled', 'Directory', 'Bad Block(S)',B & 'Marked For Delete', 'No Charge', 'Erase On Delete', & 14*' ' /* PARAMETER mAX_ORG = 3, mAX_RFM = 6$ CHARACTER *12 file_org(0:mAX_ORG)J & / 'Sequential', 'Relative', 'Indexed', 'Direct' /, !* & rec_fmt(0:mAX_RFM)6 & ] / 'Undefined', 'Fixed', 'Variable', 'VFC',3 & 'Stream', 'Stream_LF', 'Stream_CR' /,I & rec_atr(0:3) !(indexed by 4-bit field)G & / 'Fortran CC', 'Implied CC', 'Print-file', 'Non-spanned' /! CHARACTER *20 journalling(0:7)E & / 'Only thru Rec. Unit', 'Recovery Unit', 'Before Image',C & 'After Image', 'Audit Trail', 'Never thru Rec. Unit',$ & 'Journal File', ' ' /,* & ru_active(0:7) *^14E & / 'Recovery Unit', 'After Image', 'Before Image', 5*' ' /9 PARAMETER mID_PT = 42, !margin for right columnJ & iNDENT = 3 !(items also have a leading space) c global:8 INCLUDE 'XShoFiles.F' !global options c input LOGICAL as_dir CHARACTER *(*) file_spec RECORD /file_info/ info c local: CHARACTER *256 buffer, outbuf4 INTEGER *2 buflen, outlen, old_indent, ltmp+ INTEGER *4 now(2),_ flags, pos, sts1 LOGICAL not_first /.FALSE./, need_delim SAVE not_firstc functions: INTEGER *2 Set_Indent INTEGER *4 Fmt_ACL INTEGER LIB$FFS sts = 1$ IF ( not_first ) CALL OutPut( ' ') not_first = .TRUE. old_indent = Set_Indent( 0) CALL BufOut( file_spec, 2) CALL Set_Indent( iNDENT)' IF ( sho_rms .AND. .NOT. as_dir ) THEN" CALL BufOut( ' RMS def: ', 0) outlen = 01 CALL Set_Indent( iNDENT + LEN('_RMS_def:_')`) c ORG: file organization< IF ( info.org .GE. 0 .AND. info.org .LE. mAX_ORG ) THEN4 CALL STR$TRIM( buffer, file_org(info.org), buflen)% IF ( info.org .EQ. FAB$C_IDX ) THEND* open the file to retrieve prologue & index count END IF ELSE4 CALL SYS$FAO( '(unknown %x!02XB)', buflen, buffer,- & %VAL(info.org) ) END IF3 outbuf(outlen+1:) = ' ORG=' // buffer(:buflen), outlen = outlen + LEN('_ORG=') + buflenc a RFM: record format< IF ( info.rfm .GE. 0 .AND. info.rfm .LE. mAX_RFM ) THEN3 CALL STR$TRIM( buffer, rec_fmt(info.rfm), buflen)% IF ( info.rfm .EQ. FAB$C_VFC ) THEN. CALL SYS$FAO( ', !UB-byte header', ltmp,D & buffer(buflen+1:), %VAL(info.vfc) ) buflen = buflen + ltmp* ELSE IF ( info.rfm .EQ. FAB$C_FIX ) THEN/ CALL SYS$FAO( ', !UW-byte records', ltmp,D & buffer(buflen+1:), %VAL(info.mrs) ) buflenb = buflen + ltmp END IF ELSE4 CALL SYS$FAO( '(unknown %x!02XB)', buflen, buffer,- & %VAL(info.rfm) ) END IF> IF ( info.mrs .NE. 0 .AND. info.rfm .NE. FAB$C_FIX ) THEN. CALL SYS$FAO( ', maximum !UW byte!%S', ltmp,@ & buffer(buflen+1:), %VAL(info.mrs) ) buflen = buflen + ltmp END IF4 outbuf(outlen+1:) = '; RFM=' // buffer(:buflen)- outlen = outlen + LEN(';_RFM=') + buflenGc RAT: record attributces (note: leading comma simplifies loop) IF ( info.rat .EQ. 0 ) THEN* CALL STR$TRIM( buffer, ',_None', buflen) ELSE buflen = 0 flags = info.rat pos = -1. DO WHILE ( pos .LT. 4 ) !4-bit field: IF ( LIB$FFS( pos+1, 4 - (pos+1), flags, pos) ) THEN$ CALL STR$TRIM( buffer(buflen+1:),? & ', '//rec_atr(pos), ltmp) buflen = buflen + ltmp END IF END DO !until pos.ge.4 END IF? outbuf(outlen+1:) = '; RAT= d' // buffer(1+LEN(',_'):buflen); outlen = outlen + LEN(';_RAT=') + (buflen - LEN(',_'))c BKS: bucket size IF ( info.bks .NE. 0 ) THEN2 CALL SYS$FAO( '; BKS=!UB block!%S/bucket', ltmp,@ & outbuf(outlen+1:), %VAL(info.bks) ) outlen = outlen + ltmp END IF"c GBC: global buffer count IF ( info.gbc .NE. 0 ) THEN3 CALL SYS$FAO( '; GBC=!UB global buffer!%S', ltmp,@ & outbuf(outlen+1:), %VAL(info.gbc) ) e outlen = outlen + ltmp END IF&c DXQ: default extend quantity$ IF ( info.def_ext .NE. 0 ) THEN5 CALL SYS$FAO( '; DXQ=extend by !UW block!%S', ltmp,D & outbuf(outlen+1:), %VAL(info.def_ext) ) outlen = outlen + ltmp END IF$c LRL: longest record length> IF ( info.lrl .NE. 0 .AND. info.rfm .NE. FAB$C_FIX ) THEN: CALL SYS$FAO( '; LRL=longest record: !UW byte!%S', ltmp,@ & outbuf(outlen+1:), %VAL(info.lrfl) ) outlen = outlen + ltmp END IF c rms% CALL BufOut( outbuf(:outlen), 4) CALL Set_Indent( iNDENT) END IF, CALL Fmt_File_ID( info.fid, buffer, buflen)' outbuf = ' File ID: '//buffer(:buflen)9 CALL SYS$ASCTIM( buflen, buffer(:17), info.creat_date, )1 outbuf(mID_PT:) = ' Created: '//buffer(:buflen)' CALL STR$TRIM( outbuf, outbuf, outlen)! CALL BufOut( outbuf(:outlen), 2)! IF ( info.size .LT. 10**4 ) THEN. CALL SYS$FAO( '!4SL/!SL', buflen, buffegr,< & %VAL(info.size), %VAL(info.alloc) ) ELSE- CALL SYS$FAO( '!SL/!SL', buflen, buffer,< & %VAL(info.size), %VAL(info.alloc) ) END IF' outbuf = ' Size: '//buffer(:buflen)- CALL SYS$FAO( '!17%D (!UW)', buflen, buffer,> & info.modif_date, %VAL(info.revision_cnt))1 outbuf(mID_PT:) = ' Modified: '//buffer(:buflen)' CALL STR$TRIM( outbuf, outbuf, outlen)! CALL BufOut( outbuf(:outlen), 2)/ CALL Fmt_UIC( info.owner, h -1, buffer, buflen )' outbuf = ' Owner: '//buffer(:buflen)' CALL STR$TRIM( outbuf, outbuf, outlen) IF ( outlen .GE. mID_PT ) THEN% CALL BufOut( outbuf(:outlen), 2) outbuf = ' ' END IFMc note: checking the high word is almost always sufficient resolutionEc to determine whether expiration date has been reached& IF ( info.expir_date(2) .GT. 0 ) THEN= CALL SYS$ASCTIM( buflen, buffer(:17), info.expir_date, ) CALL SYS$GETTIM( now)/ IF ( iinfo.expir_date(2) .LT. now(2) ) THEN0 buffer(buflen+1:buflen+2) = ' *' !(expired) buflen = buflen + 2 END IF ELSE/ CALL STR$TRIM( buffer, ' ', buflen) END IF1 outbuf(mID_PT:) = ' Expires: '//buffer(:buflen)' CALL STR$TRIM( outbuf, outbuf, outlen)! CALL BufOut( outbuf(:outlen), 2)7 CALL Fmt_Protctn( info.protection, 1, buffer, buflen )' outbuf = ' Protect: '//buffer(:buflen) IF ( info.bckup_date(1) .NE. 0/ & .OR. info.bckup_date(2) .NE. 0 ) TjHEN= CALL SYS$ASCTIM( buflen, buffer(:17), info.bckup_date, ) ELSE/ CALL STR$TRIM( buffer, ' ', buflen) END IF1 outbuf(mID_PT:) = 'Backed up: '//buffer(:buflen)' CALL STR$TRIM( outbuf, outbuf, outlen)! CALL BufOut( outbuf(:outlen), 2)# IF ( info.acl_length .GT. 0 ) THEN IF ( .NOT. sho_acl ) THEN CALL BufOut( 'ACL exists',2) ELSE IF ( info.acl_part .GT. 0 )H & sts = Fmt_ACL( info.acl_part, %VAL(info.acl_start))+ IF ( info.acl_kpart .LT. info.acl_length ): & CALL BufOut( '(More ACE''s exist)',2) END IF END IF=c display version limit and miscellaneous characteristics outlen = 0 need_delim = .TRUE.# IF ( info.vers_limit .EQ. 0 ) THEN IF ( as_dir ) THEN4 CALL STR$TRIM( outbuf, 'No version limit', outlen) ELSE need_delim = .FALSE. END IF ELSE IF ( as_dir ) THEN: CALL SYS$FAO( 'Version limit is !UW', outlen, outbuf,0 & %VAL(info.vlers_limit) ) ELSE? CALL SYS$FAO( 'Limited to !UW version!%S', outlen, outbuf,0 & %VAL(info.vers_limit) ) END IF flags = info.flags: IF ( as_dir ) flags = flags .AND. .NOT. dIR_FLAGS_IGNORE pos = -1 DO WHILE ( pos .LT. 32 )< IF ( LIB$FFS( pos + 1, 32 - (pos+1), flags, pos) ) THEN IF ( need_delim ) THEN outbuf(outlen+1:) = ', '! outlen = outlen + LEN(',_') END IF/ CALL STR$TRIM( buffer, filechar(pos), buflen) IF ( buflen .EQ.m 0 )F & CALL SYS$FAO( '(unknown characteristic #!UL)',? & buflen, buffer, %VAL(pos))2 outbuf(outlen+1:outlen+buflen) = buffer(:buflen) outlen = outlen + buflen need_delim = .TRUE. END IF END DO !until pos.ge.32 IF ( outlen .GT. 0 )0 & CALL BufOut( outbuf(:outlen), 4) CALL Buf_Flush( 0) CALL Set_Indent( old_indent) Format_File_Info = sts RETURN END !of Format_File_Info/ INTEnGER *4 FUNCTION Fmt_ACL( size, acl ) !( ! Format and print ACL (preliminary). ! implicit nonec constant: INCLUDE 'f_inc:Dsc.F' c input: INTEGER *4 size BYTE acl(*) c local: RECORD /dsc/ descrip CHARACTER *256 buf INTEGER *4 buflen INTEGER *2 ln, p INTEGER *4 wrkpos, sts BYTE len_byte INTEGER *2 len_word% EQUIVALENCE ( len_word, len_byte )c functions: INTEGER Rpl_SubStr INToEGER *4 SYS$FORMAT_ACL INTRINSIC INDEX, LEN len_word = 0- descrip.d_typ = 0 !unspecified descrip.d_cls = 0 sts = 1 wrkpos = 1( DO WHILE ( sts .AND. wrkpos .LT. size ) len_byte = acl(wrkpos) IF ( len_word .EQ. 0 ) THEN& wrkpos = size + 1 !done ELSE descrip.d_len = len_word( descrip.d_adr = %LOC(acl(wrkpos)) buflen = 02 sts = SYS$FORMAT_ACL( descrip, buflen, buf,' & p ,,,) IF ( sts ) THEN ln = buflen!c modify the format$ IF ( buf(:6) .EQ. '(IDENT' ) THEN4 CALL Rpl_SubStr( 1, '(IDENTIFIER=', '(Ident=',1 & buf(:ln), ln): CALL Rpl_SubStr( 1, 'EXECUTE', 'EXEC', buf(:ln), ln): CALL Rpl_SubStr( 1, 'DELETE', 'DEL', buf(:ln), ln)) ELSE IF ( buf(:6) .EQ. '(ALARM' ) THEN7 CALL Rpl_SubStr( 1, '(ALARM_JOURNAL=', '(Alarm=',1 & buf(:ln), ln)) q ELSE IF ( buf(:6) .EQ. '(DEFAU' ) THEN0 CALL Rpl_SubStr( 1, '(DEFAULT_PROTECTION',B & '(Default_Prot', buf(:ln), ln)7 CALL Rpl_SubStr( 1,'SYSTEM:', 'S:', buf(:ln), ln)7 CALL Rpl_SubStr( 1, 'OWNER:', 'O:', buf(:ln), ln)7 CALL Rpl_SubStr( 1, 'GROUP:', 'G:', buf(:ln), ln)7 CALL Rpl_SubStr( 1, 'WORLD:', 'W:', buf(:ln), ln)@ ELSE IF ( buf(:6) .EQ. '(APPLI' ) THEN !V5.1+@ CALL Rpl_SubStr( 1, '(APPLICATION', '(Appl rication', !V5.1+N & buf(:ln), ln) !V5.1+@ CALL Rpl_SubStr( 1, ',SIZE=%D',',Size=',buf(:ln),ln)!V5.1+@ CALL Rpl_SubStr( 1, ',FLAGS=',',Flags=',buf(:ln),ln)!V5.1+@ CALL Rpl_SubStr( 1, ',DATA=', ',Data=', buf(:ln),ln)!V5.1+ END IF< CALL Rpl_SubStr(-1, '%X', '%x', buf(:ln), ln) !+: CALL Rpl_SubStr( 1, ',OPTIONS=', ',Opt=', buf(:ln), ln): CALL Rpl_SubStr( 1, ',ACCESS=', ',Access=',buf(:ln),ln)"c sdisplay the result CALL BufOut( buf(:ln), 2) END IF! wrkpos = wrkpos + len_word END IF END DO Fmt_ACL = sts RETURN END !of Fmt_ACL INTEGER FUNCTION@ & Rpl_SubStr ( which, target, new_text, string, newlen ) !> ! Replace one or more occurrances of a particular substring ! within a string (in place). ! implicit none c input:" CHARACTER *(*) target, new_textC INTEGER which ! 1 => first, 0 => last, -1t => allc input/output: CHARACTER *(*) string c output: INTEGER *2 newlen c local:. INTEGER c, n, p, q, ldif, last_p INTEGER *4 length INTEGER *2 len_word# EQUIVALENCE ( len_word, length )c functions:# INTRINSIC INDEX, LEN, ZEXT length = ZEXT(LEN(string))# ldif = LEN(target) - LEN(new_text): c = 0 !number of replacements performed+ n = 0 !number of matches last_p = 0 p = IuNDEX( string, target)? DO WHILE ( p .GT. 0 .AND. ( which .LE. 0 .OR. n .LT. which ) ) n = n + 10 IF ( n .EQ. which .OR. which .EQ. -1 ) THEN1 string(p:) = new_text // string(p+LEN(target):) length = length - ldif c = c + 1 END IF last_p = p q = p + LEN(new_text)# p = INDEX( string(q:), target)# IF ( p .GT. 0 ) p = q + p - 1 END DO- IF ( which .EQ. 0 .AND. last_p .GT. 0 ) THEN> string(last_p:) = new_text // string(last_p+LEN(target):)  length = length - ldif c = c + 1 END IF newlen = len_word Rpl_SubStr = c RETURN END !of Rpl_SubStrwwwn |Ւ8/* XShoFiles1.C -- routines for XSHOW FILES & DIRECTORYK * Pat Rankin, 8/88, 11/88 */3#include "C.H" /* miscellaneous */6#include "FH2def.H" /* file header defs */9#include /* string descriptors */9#include /* function prototypes */;#include /* RMS File Access Block */;#include /* RMS NAMe xblock defs */6#include /* rms status codes */A#include /* system service status codes */#define AS_DIR TRUE#define AS_FILE !AS_DIR+extern Ulong SYS$PARSE(), SYS$SEARCH();Ulong Access_File(), Display_File();static void release_nam();@/* global data structure compatable with Fortran common block */Jextern struct { /* COMMON /dyn_list/ */J char *spec_list; y /* INTEGER *4 spec_list */J long spec_siz, /* INTEGER *4 spec_siz, */< spec_cnt; /* & spec_cnt */ } dyn_list; /*\% * Process file specifications. \*/Ulong XShow_Files ( ){G struct fh2def header; /* ods-2 file header */K struct FAB fab; /* RMS File Access Block */& struct NAM *nam_p, *prev_nam; Desc z acl;- char spec_buf[NAM$C_MAXRSS+1];L _Descrip(filespec,spec_buf); /* filename specification */ int idx; Uword ln; Ulong sts;& Ulong Get_Inp_Element();F memset( &fab, 0, sizeof(struct FAB)); /* fill with zeroes */G fab.fab$b_bid = FAB$C_BID; /* block id (FAB==3) */I fab.fab$b_bln = FAB$C_BLN; /* block length (0x50) */J fab.fab$l_fop = FAB$M_UFO; { /* user file open (n/a) */F fab.fab$l_fna = spec_buf; /* filename address */ nam_p = NULL;L /* parse & process each filespec from the command line parameter list */% for ( idx = 1, sts = SS$_NORMAL ;8 idx <= dyn_list.spec_cnt && syswork(sts) ; idx++ ) { prev_nam = nam_p;Y if ( prev_nam != NULL ) { /* use previous expanded string as related resultant string *// prev_nam->nam$l_rsa = prev_nam->nam$l_esa;/ prev_nam->nam$b_rsl = p |rev_nam->nam$b_esl;A fab.fab$b_dns = 0; /* clear default name */ }" /* fetch & parse i'th filespec */E sts = Get_Inp_Element( &dyn_list.spec_cnt, dyn_list.spec_list, &idx, &filespec, &ln);C fab.fab$b_fns = ( ln <= 0xFF ? ln : 0xFF ); /* byte-sized field */E nam_p = malloc( sizeof(struct NAM)); /* allocate new NAM block */? memset( nam_p, 0, sizeof(struct NAM)); /* fill with zeroes */@ nam_p->nam$b_bid = NAM$C_BID; /* block id (NAM==2) */B n }am_p->nam$b_bln = NAM$C_BLN; /* block length (0x60) */3 nam_p->nam$l_esa = malloc( 2 * (NAM$C_MAXRSS+1) );8 nam_p->nam$l_rsa = nam_p->nam$l_esa + NAM$C_MAXRSS + 1;4 nam_p->nam$b_ess = nam_p->nam$b_rss = NAM$C_MAXRSS;E nam_p->nam$l_rlf = prev_nam; /* related file NAM block */ fab.fab$l_nam = nam_p; sts = SYS$PARSE( &fab);G *(nam_p->nam$l_esa + nam_p->nam$b_esl) = '\0'; /* terminate string */ if ( syswork(sts) ) { repeat { sts = SYS$SEARCH( &fab);0 *(nam_~p->nam$l_rsa + nam_p->nam$b_rsl) = '\0'; /*\ * process filespec \*/< if ( syswork(sts) ) /* retreive file header */8 sts = Access_File( AS_FILE, nam_p, &header, &acl); if ( syswork(sts) )9 sts = Display_File( AS_FILE, nam_p, &header, &acl); } until( sysfail(sts) );I } else { /* parse failed; set up resultant string for error reporting */1 strcpy( nam_p->nam$l_rsa, nam_p->nam$l_esa); } /* $parse ok */* if ( sts == RMS$_NMF ) sts = SS$_NORMAL; } /*next idx*/ Call release_nam( nam_p); return( sts);} /*--XShow_Files--*/ /*\* * Process directory specifications. \*/Ulong XShow_Directory ( ){G struct fh2def header; /* ods-2 file header */K struct FAB fab; /* RMS File Access Block */& struct NAM *nam_p, *prev_nam; Desc acl;- char spec_buf[NAM$C_MAXRSS+1];M _Descrip(dir spec,spec_buf); /* directory specification */ int idx; Uword ln; Ulong sts;& Ulong Get_Inp_Element();F memset( &fab, 0, sizeof(struct FAB)); /* fill with zeroes */G fab.fab$b_bid = FAB$C_BID; /* block id (FAB==3) */I fab.fab$b_bln = FAB$C_BLN; /* block length (0x50) */J fab.fab$l_fop = FAB$M_UFO; /* user file open (n/a) */F fab.fab$l_fna = spec _buf; /* filename address */ nam_p = NULL;L /* parse & process each filespec from the command line parameter list */% for ( idx = 1, sts = SS$_NORMAL ;8 idx <= dyn_list.spec_cnt && syswork(sts) ; idx++ ) { prev_nam = nam_p;Y if ( prev_nam != NULL ) { /* use previous expanded string as related resultant string *// prev_nam->nam$l_rsa = prev_nam->nam$l_esa;/ prev_nam->nam$b_rsl = prev_nam->nam$b_esl;A fab.fab$b_dns = 0; /* clea r default name */ }" /* fetch & parse i'th filespec */E sts = Get_Inp_Element( &dyn_list.spec_cnt, dyn_list.spec_list, &idx, &dirspec, &ln);C fab.fab$b_fns = ( ln <= 0xFF ? ln : 0xFF ); /* byte-sized field */E nam_p = malloc( sizeof(struct NAM)); /* allocate new NAM block */? memset( nam_p, 0, sizeof(struct NAM)); /* fill with zeroes */@ nam_p->nam$b_bid = NAM$C_BID; /* block id (NAM==2) */B nam_p->nam$b_bln = NAM$C_BLN; /* block length (0x60) */, nam_p ->nam$l_esa = malloc( NAM$C_MAXRSS+1);! nam_p->nam$b_ess = NAM$C_MAXRSS;E nam_p->nam$l_rlf = prev_nam; /* related file NAM block */ fab.fab$l_nam = nam_p; sts = SYS$PARSE( &fab);G *(nam_p->nam$l_esa + nam_p->nam$b_esl) = '\0'; /* terminate string */ #ifdef debug( printf("%08X \"%s\" (%s)\n",sts,, ((struct NAM *)fab.fab$l_nam)->nam$l_esa,@ ((struct NAM *)fab.fab$l_nam)->nam$l_rlf == NULL ? "" :H ((struct NAM *)((struct NAM *)fab.fab$l_nam)->nam$l_rlf)->nam$l_rsa);#endif /*\ * process directory filespec \*/; if ( syswork(sts) ) /* retreive file header */6 sts = Access_File( AS_DIR, nam_p, &header, &acl); if ( syswork(sts) )7 sts = Display_File( AS_DIR, nam_p, &header, &acl); } /*next idx*/ Call release_nam( nam_p); return( sts);} /*--XShow_Directory--*/$Internal void release_nam ( nam_p ) struct NAM *nam_p;{ if ( nam_p != NULL ) {% Call release_nam( nam_p->nam$l_rlf); free( nam_p->nam$l_esa); free( nam_p); } return;} /*--release_nam--*/#if 0 /*\* * Process directory specifications. \*/Ulong XShow_Directory ( ){G struct fh2def header; /* ods-2 file header */K struct FAB fab; /* RMS File Access Block */I struct NAM nam; /* RMS file NAMe block */ Desc acl;L char expd_buf[NAM$C _MAXRSS+1], /* expanded string buffer */> spec_buf[NAM$C_MAXRSS+1], /* file specification buf */? dflt_buf[NAM$C_MAXRSS+1]; /* default filespec buffer */K _Descrip(dirspec,spec_buf); /* directory spec string */M _Descrip(defspec,dflt_buf); /* default filespec string */ int idx; Uword ln;" Ulong sts, ctx = 0;& Ulong Get_Inp_Element();M strcpy( dflt_buf, "");  /* initial default is NULL */F memset( &fab, 0, sizeof(struct FAB)); /* fill with zeroes */G fab.fab$b_bid = FAB$C_BID; /* block id (FAB==3) */I fab.fab$b_bln = FAB$C_BLN; /* block length (0x50) */J fab.fab$l_fop = FAB$M_UFO; /* user file open (n/a) */G fab.fab$l_fna = spec_buf; /* file name address */J fab.fab$l_dna = dflt_buf; /* default name address */G fab.fab$l_nam = &nam; /* NAM block address */F memset( &nam, 0, sizeof(struct NAM)); /* fill with zeroes */G nam.nam$b_bid = NAM$C_BID; /* block id (NAM==2) */I nam.nam$b_bln = NAM$C_BLN; /* block length (0x60) */M nam.nam$l_esa = expd_buf; /* expanded string address */J nam.nam$b_ess = NAM$C_MAXRSS; /* expanded string size */L /* parse & process each filespec from the command line parameter list */% for ( idx = 1, sts = SS$_NORMAL ;8 idx <= dyn_list.spec_cnt && syswork(sts) ; idx++ ) {" /* fetch & parse i'th filespec */D Call Get_Inp_Element( &dyn_list.spec_cnt, dyn_list.spec_list, &idx, &dirspec, &ln);A fab.fab$b_fns = ln; /* length of filename */E if ( idx > 1 ) /* build default name && store its length */7 fab.fab$b_dns = build_dflt( &nam, &defspec, &ctx);F sts = SYS$PARSE( &fab); /* have RMS parse filespec */ expd_buf[nam.nam$b_esl] = '\0'; #ifdef debug0 printf( "$parse: %08X\n \"%s\" (%s)\n", sts,A ((struct NAM *)fab.fab$l_nam)->nam$l_esa, fab.fab$l_dna);#endif /* process filespec */ if ( syswork(sts) ), sts = Access_Dir( &nam, &header, &acl); if ( syswork(sts) )- sts = Display_Dir( &nam, &header, &acl); } /*next idx*/ return( sts);} /*--XShow_Directory--*/ /*\D * build_dflt() -- alternate method of handling related filespecs. \*/(int build_dflt ( nam_p, name_dsc, ctx ) struct NAM *nam_p;B Desc *name_dsc; /* place to put result */6 Ulong *ctx; /* context */{, String str = name_dsc->dsc_adr; *str = '\0'; *ctx |= nam_p->nam$l_fnb; if ( *ctx & NAM$M_NODE )5 strncat( str, nam_p->nam$l_node, nam_p->nam$b_node); if ( *ctx & NAM$M_EXP_DEV )3 strncat( str, nam_p->nam$l_dev, nam_p->nam$b_dev); if ( *ctx & NAM$M_EXP_DIR )3 s trncat( str, nam_p->nam$l_dir, nam_p->nam$b_dir); if ( *ctx & NAM$M_EXP_NAME )5 strncat( str, nam_p->nam$l_name, nam_p->nam$b_name); if ( *ctx & NAM$M_EXP_TYPE )5 strncat( str, nam_p->nam$l_type, nam_p->nam$b_type); if ( *ctx & NAM$M_EXP_VER )3 strncat( str, nam_p->nam$l_ver, nam_p->nam$b_ver); return( strlen(str) );} /*--build_dflt--*/ #endif /*0*/ww @sR$|Ւ8/* XShoFiles2.C -- routines for XSHOW FILES & DIRECTORYK * Pat Rankin, 8/88, 11/88 */3#include "C.H" /* miscellaneous */9#include "ACLdef.H" /* access control list */<#include "FATdef.H" /* file/record attributes */:#include "FCHdef.H" /* file characteristics */6#include "FH2def.H" /* file header defs */K#include "FI2def.H" /* identificatio n portion of file header */T#include "FM2def.H" /* map (retreival pointer) portion of file header */A#include /* file information block defs */=#include /* attribute request codes */8#include /* string descriptors */9#include /* function prototypes */9#include /* RMS NAMe block defs */8#include /* I/O function codes */6#include /* rms status codes */A#include /* system service status codes */struct file_info {$ Uword fid[3], vers_limit;- Ulong alloc, size, owner, flags;* Uword protection, revision_cnt; Quad dates[4];& Ulong acl_length, acl_part; Ubyte *acl_start;N /* items above are common to both dir & file, those below are file only */> Uword did[3], rec_prot, lrl, mrs, def_ext, gbc;, Ubyte org, rfm, rat, bks, vfc,% acc_mode, journalling, ru_active; Ulong highwater;};,extern Ulong SYS$ASSIGN(), SYS$DASSGN(), SYS$QIOW(), SYS$CHANGE_ACL();Ulong Get_Header();0Ulong Access_File ( as_dir, nam_p, header, acl) Boolean as_dir; struct NAM *nam_p; struct fh2def *header; Desc *acl;{+ char buffer[NAM$C_MAXRSS+1]; Uword *fid_p; Ulong sts;2 /* get device name (for channel assignment) */J strncpy( buffer, &nam_p->nam$t_dvi[1], (unsigned)nam_p->nam$t_dvi[0]);9 strcpy( &buffer[(unsigned)nam_p->nam$t_dvi[0]], ":");? fid_p = ( as_dir ? &nam_p->nam$w_did : &nam_p->nam$w_fid ); #ifdef debug { printf( " %s", buffer);E printf( " (%ld,%d,%d)\n", (long)fid_p[0]|((fid_p[2]&0xFF00)<<8), fid_p[1], fid_p[2]&0x00FF);H printf( " \"%s\"\n", as_dir ? nam_p->nam$l_esa : nam_p->nam$l_rsa); }#endif if ( as_dirK  && nam_p->nam$l_fnb & (NAM$M_EXP_NAME|NAM$M_EXP_TYPE|NAM$M_EXP_VER) ) return( SS$_BADIRECTORY );- else if ( nam_p->nam$l_fnb & NAM$M_NODE ) return( RMS$_SUP );: sts = Get_Header( as_dir, buffer, fid_p, header, acl);#if 0 if ( syswork(sts) ) { struct fi2def *id;F /* get pointer to identification section (word offset from header) */B id = (struct fi2def *)((Uword *)&header + header.fh2$b_idoffset);6 strncpy( buffer, id->fi2$t_filename, FI2$S_FILENAME);K strncpy( &buffer[FI2$S_FILENAME], id->fi2$t_filenamext, FI2$S_FILENAMEXT);0 buffer[FI2$S_FILENAME+FI2$S_FILENAMEXT] = '\0';; p = memchr( buffer, ' ', FI2$S_FILENAME+FI2$S_FILENAMEXT); if ( p != NULL ) *p = '\0'; printf( " \"%s\"\n", buffer); { char buffer[32]; _Descrip(workbuf,buffer);& workbuf.dsc_len = sizeof(buffer) - 1;= Call SYS$ASCTIM( &workbuf, &workbuf, &id->fi2$q_credate, 0); Call LIB$PUT_OUTPUT( &workbuf);& workbuf.dsc_len = sizeof(buffer) - 1;= Call SYS$ASCTIM( &workbuf, &workbuf, &id->fi2$q_revdate, 0); Call LIB$PUT_OUTPUT( &workbuf);& workbuf.dsc_len = sizeof(buffer) - 1;= Call SYS$ASCTIM( &workbuf, &workbuf, &id->fi2$q_expdate, 0); Call LIB$PUT_OUTPUT( &workbuf);& workbuf.dsc_len = sizeof(buffer) - 1;= Call SYS$ASCTIM( &workbuf, &workbuf, &id->fi2$q_bakdate, 0); Call LIB$PUT_OUTPUT( &workbuf); } }#endif return( sts );} /*--Access_File--*/6Ulong Get_Header ( as_dir, device, fid, header, acl ) Boolean  as_dir; String device; Uword fid[3]; struct fh2def *header; Desc *acl;{ struct fibdef fib;9 Desc fib_dsc = { sizeof fib, 0, 0, &fib },1 dev_dsc = { strlen(device), 0, 0, device }; long acl_len;U#define BIGBUFSIZ (ATR$S_READACL > ATR$S_FILE_SPEC ? ATR$S_READACL : ATR$S_FILE_SPEC)@ static Ubyte static_buf[BIGBUFSIZ], *dynamic_buf = NULL;$ static int dyn_buf_siz = 0;# _Descrip(file_spec,static_buf);( struct atrdef attr_rqst_list[] = {, { sizeof *header, ATR$C_HEADER, header },1 { sizeof acl_len, ATR$C_ACLLENGTH, &acl_len }, { 0, 0, NULL } }; Uword channel;" Ulong sts, iosb[2]; channel = 0;3 sts = SYS$ASSIGN( &dev_dsc, &channel, 0, NULL); #ifdef debug3 printf( "$assign: %08X, #%d\n", sts, channel);#endif' if ( sysfail(sts) ) return( sts ); acl_len = 0;' memset( header, 0, sizeof *header);! memset( &fib, 0, sizeof fib);9 fib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;> memcpy( fib.fib$r_fid_overlay.fib$w_fid, fid, sizeof fid);8 sts = SYS$QIOW( 0, channel, IO$_ACCESS, &iosb, 0, 0,, &fib_dsc, 0, 0, 0, &attr_rqst_list, 0); #ifdef debugA printf( "$qiow: %08X (%08X %08X)\n", sts, iosb[0], iosb[1]);#endif' if ( syswork(sts) ) sts = iosb[0];% acl->dsc_len = (unsigned)acl_len; acl->dsc_adr = NULL;( if ( syswork(sts) && acl_len > 0 ) {3 memse t( attr_rqst_list, 0, sizeof attr_rqst_list);V if ( acl_len <= (header->fh2$b_rsoffset - header->fh2$b_acoffset) * sizeof(Uword) ) {H acl->dsc_adr = (Ubyte *)((Uword *)header + header->fh2$b_acoffset);) } else if ( acl_len <= ATR$S_READACL ) {6 attr_rqst_list[0].atr$w_size = sizeof static_buf;2 attr_rqst_list[0].atr$w_type = ATR$C_READACL;/ attr_rqst_list[0].atr$l_addr = static_buf;9 sts = SYS$QIOW( 0, channel, IO$_ACCESS, &iosb, 0, 0,- &fib_dsc, 0, 0, 0, &attr_rqs t_list, 0); #ifdef debugA printf( "$qiow: %08X (%08X %08X)\n", sts, iosb[0], iosb[1]);#endif( if ( syswork(sts) ) sts = iosb[0];B acl->dsc_adr = ( syswork(sts) ? static_buf : (Ubyte *)NULL ); } else {A /* we need to either actually access the file on our channel$ or retreive its full name */6 attr_rqst_list[0].atr$w_size = sizeof static_buf;4 attr_rqst_list[0].atr$w_type = ATR$C_FILE_SPEC;/ attr_rqst_list[0].atr$l_addr = static_buf;9 sts = SYS$QIOW( 0, channel, IO$_ACCESS, &iosb, 0, 0,- &fib_dsc, 0, 0, 0, &attr_rqst_list, 0); #ifdef debugA printf( "$qiow: %08X (%08X %08X)\n", sts, iosb[0], iosb[1]);#endif( if ( syswork(sts) ) sts = iosb[0]; if ( syswork(sts) ) { Ubyte *acl_ptr; int acl_left; long acl_context;3 /* convert counted string to string descriptor */7 file_spec.dsc_len = (unsigned)*(file_spec.dsc_adr++); #ifdef debug% Call LIB$PUT_OUTPUT( &file_spec);#endif - /* allocate a bigger buffer if necessary */ if ( acl_len > dyn_buf_siz ) { if ( dyn_buf_siz != 0 )= free( dynamic_buf), dynamic_buf = NULL, dyn_buf_siz = 0;G dyn_buf_siz = (acl_len & ~0x0FF) + ATR$S_READACL; /* round up */2 dynamic_buf = (Ubyte *)malloc( dyn_buf_siz); }; /* (this is wrong type of item list, but it will work) *// attr_rqst_list[0].atr$w_size = ACL$S_READACL;/ attr_rqst_list[0].atr$w_type = ACL$C_READACL; acl_left = acl_len; acl_ptr = dynamic_buf; acl_context = 0; repeat {- attr_rqst_list[0].atr$l_addr = acl_ptr;7 sts = SYS$CHANGE_ACL( 0, &ACL$C_FILE, &file_spec,+ &attr_rqst_list, 0, 0, &acl_context); #ifdef debugB printf( "$change_acl: %08X, acl_left = %d\n", sts, acl_left);#endif if ( syswork(sts) ) {- /* guarantee at least one trailing zero */1 *(acl_ptr + attr_rqst_list[0].atr$w_size) = 0; while ( *acl_ptr != 0 )2 acl_left -= *acl_ptr, acl_ptr += *acl_ptr;  }+ } until( acl_left <= 0 || sysfail(sts) );@ acl->dsc_adr = ( syswork(sts) ? dynamic_buf : (Ubyte *)NULL ); } } #ifdef debugS printf( " (acl): length = %d, address = %08X\n", acl->dsc_len, acl->dsc_adr);#endif } Call SYS$DASSGN( channel); return( sts );} /*--Get_Header--*/ /*\= * Collect relevant data from file header and RMS NAM block. * and pass it on to the formatting routine. \*/2Ulong Display_File( as_dir, nam_p, header, acl ) Boolean as_dir; struct NAM *nam_p; struct fh2def *header; Desc *acl;{ struct fi2def *id; struct file_info info;B Desc name = { 0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL };& Ulong Format_Dir_Info(), Format_File_Info(); if ( as_dir ) {8 /* we don't want node, name, type, or version (".;") */! name.dsc_adr = nam_p->nam$l_dev;4 name.dsc_len = nam_p->nam$b_dev + nam_p->nam$b_dir; } else {! name.dsc_ad r = nam_p->nam$l_rsa;! name.dsc_len = nam_p->nam$b_rsl; }: memcpy( info.fid, header->fh2$w_fid, sizeof info.fid);; info.vers_limit = header->fh2$w_recattr.fat$w_versions;9 info.alloc = header->fh2$w_recattr.fat$w_hiblkh << 16- | header->fh2$w_recattr.fat$w_hiblkl;9 info.size = header->fh2$w_recattr.fat$w_efblkh << 16- | header->fh2$w_recattr.fat$w_efblkl;@ if ( header->fh2$w_recattr.fat$w_ffbyte == 0 ) info.size--;) info.owner = header->fh2$l_fil eowner;( info.flags = header->fh2$l_filechar;- info.protection = header->fh2$w_fileprot;I /* get pointer to identification section (word offset from header) */E id = (struct fi2def *)((Uword *)header + header->fh2$b_idoffset);+ info.revision_cnt = id->fi2$w_revision;> memcpy( info.dates, id->fi2$q_credate, sizeof info.dates);Q /* limited acl handling here: full size, size & address of what we've got */# info.acl_length = acl->dsc_len;b /* info.acl_part = ( ac l->dsc_len <= ATR$S_READACL ? acl->dsc_len : ATR$S_READACL ); /**TEMP**/ /*-*/& info.acl_part = info.acl_length;K info.acl_start = ( acl->dsc_len == 0 ? (Ubyte *)NULL : acl->dsc_adr );- if ( !as_dir ) { /* file only items */< memcpy( info.did, header->fh2$w_backlink, sizeof info.did);0 info.org = header->fh2$w_recattr.fat$v_fileorg;. info.rfm = header->fh2$w_recattr.fat$v_rtype;0 info.rat = header->fh2$w_recattr.fat$b_rattrib;. info.lrl = header->fh2$w_recattr.fat$w_rsize; 0 info.bks = header->fh2$w_recattr.fat$b_bktsize;0 info.vfc = header->fh2$w_recattr.fat$b_vfcsize;/ info.mrs = header->fh2$w_recattr.fat$w_maxrec;3 info.def_ext = header->fh2$w_recattr.fat$w_defext;, info.gbc = header->fh2$w_recattr.fat$w_gbc;' info.rec_prot = header->fh2$w_recprot;( info.acc_mode = header->fh2$b_acc_mode;* info.journalling = header->fh2$b_journal;* info.ru_active = header->fh2$b_ru_active;* info.highwater = header->fh2$l_highwater; }7 return( Format_File_Info( &as_dir, &name, &info) );} /*--Display_File--*/ww H|Ւ>* Itm.F -- Fortran include file defining itemlist structures*C STRUCTURE /itmlst/ !standard itemlist for VMS system services2 INTEGER *2 itm_length /0/ !length of buffer+ INTEGER *2 itm_code /0/ !item code3 INTEGER *4 itm_bufadr /0/ !address of bufferI INTEGER *4 itm_retlen /0/ !address of i*2 to receive output length END STRUCTURE !itmlstJc same as /itmlst/ except not initialized to 0 & alternate field namesI STRUCTURE /itm3 / !three longword itemlist for VMS system services UNION MAP !long form2 INTEGER *2 itm_w_length !length of buffer+ INTEGER *2 itm_w_code !item code3 INTEGER *4 itm_l_bufadr !address of bufferI INTEGER *4 itm_l_retlen !address of i*2 to receive output length END MAP MAP !short form2 INTEGER *2 i_len !length of buffer+ INTEGER *2 i_cod !item code3 INTEGER *4 i_buf !address of bufferI INTEGER *4 i_rln !address of i*2 to receive output length END MAP END UNION END STRUCTURE !itm3& PARAMETER ITM_C_END_OF_LIST = 0& PARAMETER ITM_K_END_OF_LIST = 0 PARAMETER ITM_S_BYTE = 1 PARAMETER ITM_S_WORD = 2# PARAMETER ITM_S_LONGWORD = 4# PARAMETER ITM_S_QUADWORD = 8wwdNM|Ւ?* Dsc.F -- Substitute include file for Descriptor definitions* INCLUDE '($DSCdef)/nolist'F parameter dSC_S_DSC = 8 !descriptor size (standard quad type)M! alternate definition of generic descriptor structure (all fields should,! be treated as unsigned quantities) STRUCTURE /dsc/ UNION MAP% INTEGER *2 d_len !length# BYTE d_typ !type$ BYTE d_cls !class8 INTEGER *4 d_adr !address (pointer to data) END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc STRUCTURE /dsc_s/ UNION MAP INTEGER *2 d_len /0/5 BYTE d_typ /DSC$K_DTYPE_T/ !ascii text1 BYTE d_cls /DSC$K_CLASS_S/ !static INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc_s STRUCTURE /dsc_d/ UNION MAP INTEGER *2 d_len /0/5 BYTE d_typ /DSC$K_DTYPE_T/ !ascii text2 BYTE d_cls /DSC$K_CLASS_D/ !dynamic INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc_d STRUCTURE /dsc_z/ UNION MAP INTEGER *2 d_len /0/6 BYTE d_typ /0/ !unspecified6 BYTE d_cls /0/ !unspecified INTEGER *4 d_adr /0/ END MAP MAP7 INTEGER *4 d_quad(2) !quadword (two longwords) END MAP END UNION END STRUCTURE !dsc_zww 2Q|ՒO* Cli.F -- Status codes returned by CLI$PRESENT, CLI$GET_VALUE, CLI$DCL_PARSE*. parameter CLI$_NOCOMD = '000380B0'x. parameter CLI$_ABSENT = '000381F0'x. parameter CLI$_NEGATED = '000381F8'xA parameter CLI$_LOCNEG = '00038230'x !locally negated. parameter CLI$_PRESENT = '0003FD19'x. parameter CLI$_DEFAULTED = '0003FD21'xD parameter CLI$_CONCAT = '0003FD29'x !terminated by plusA parameter CLI$_LOCPRES = '0003FD31'x !locally presentE parameter CLI$_COMMA = '0003FD39'x !terminated by comma. parameter CLI$_NORMAL = '00030001'xB parameter CLI$_INVREQTYP = '00038822'x !(no CLI present)7 parameter CLI$_SYNTAX = '000310FC'x !fatalH parameter CLI$_VALREQ = '00038150'x !missing required valueww@d /JOBNAME -- name(s) of job(s) which are to be displayed* /JOBNAME[=([-,]job-name[,job-name...])K List of one or more batch and/or print job-names of interest; wildcardsH are supported. Only jobs which match the name(s) will be displayed.I If the first element of the list is a dash ('-'), then only jobs that) do NOT match names will be displayed. /ON_NODE, /ON_NODE[=([-,]node-name[,node-nam e...])C List of one or more VAXcluster nodes of interest; wildcards areJ supported. Only queues that execute on the node(s) will be displayed.J If the first element of the list is a dash ('-'), then only queues NOTH on the node(s) will be displayed. Note: appropriate for VAXclusterD systems only; also, incompatable with /IF=(GENERIC,NOEXECUTION).@ /output -- destination of output; defaults to SYS$OUTPUT /output[=file-spec]< /SUMMARY -- display job counts by  job-status category /SUMMARY9 /USERNAME -- user(s) whose jobs are to be displayed- /USERNAME[=([-,]user-name[,user-name...])K List of one or more VMS usernames of interest; wildcards are supported.C Only jobs owner by the user(s) will be displayed. If the firstH element of the list is a dash ('-'), then only jobs NOT owned by theF user(s) will be displayed. The default value is the current user.H Note: the /ALL_JOBS qualifier still controls whether any jobs owned$ by other users may be displayed. /WIDTH /WIDTH=valueF Specifies line width used when formatting /FULL data. The defaultE value is 80 columns. Note that the base display does not attempt to stay within this limit.wwP/|Ւ #ifdef VMS# ifdef MODULE# module MODULE# endif#endif#define TRUE 1#define FALSE 0#define NULL 0#define NUL '\0'#define EOF -1 #define begin #define end #define then#define elseif else if #define endif#define next continue #define enddo#define endfor#define endswitch#define repeat do##define until(cond) while(!(cond))#define Begin {#define End }#define If if (#define Then ) {#define Else } else {#define ElseIf } else If#define EndIf }#define While while (#define For for (#define Loop ) {#define Next(i) }#define Next_ }#define Repeat do {%#define Until(cond) } while (!(cond))#define and &&#define or ||#define not !#define is ==#define aint !=8#define program main(argc,argv) int argc; char *argv[];#define function#define procedure void#define Call (void)#define Integer int#define Character char#define External extern#define Internal static#ifdef MAIN_MODULE## define Global /* no-op */;# define _value_(x) = x /* initial value for definitions */;# define _dim_(x) x /* dimension(s) " " */# define _dim2_(x,y) x][y# define _dim3_(x,y,z) x][y][z#else# define Global extern;# define _value_(x) /* no value for declarations */;# define _dim_(x) /* " dimensions for " */# define _dim2_(x,y) ][y# define _dim3_(x,y,z) ][y][z#endif#define Local static#define Temporary auto/* #define void int */typedef float Real ;typedef char *Pointer ;typedef char *String ;typedef char Byte ;typedef short Word ;typedef char Boolean ;typedef int Logical ;typedef long Quad[2] ;typedef unsigned char Ubyte ;typedef unsigned short Uword ;typedef unsigned long Ulong ;typedef struct Descriptor {4 Uword dsc_len; /* Length of data *// Byte dsc_typ; /* Data type */3 Byte dsc_cls; /* Storage class */5 Pointer dsc_adr; /* Address of data */} Desc ;C#define _Descrip(var,buf) Desc var = { sizeof(buf)-1, 14, 1, buf }#define IAnd(p,q) ((p)&(q))#define IOr(p,q) ((p)|(q))#define Odd(n) IAnd(n,1)%#define Min(a,b) ((a)>(b)?(b):(a))%#define Max(a,b) ((a)<(b)?(b):(a))%#define Abs(a) ((a)<0? -(a):(a))#define syswork(sts) Odd(sts)%#define sy sfail(sts) (!syswork(sts))*#define streq(a,b) (strcmp((a),(b))==0)U#define xstrcpy(d,s) (strcpy(d,s)+strlen(s)) /* return pointer to end of string *//#define xstrcat(d,s) ((d)+strlen(strcat(d,s)))0#define strcpy2(d,s1,s2) strcat(strcpy(d,s1),s2)>#define strcpy3(d,s1,s2,s3) strcat(strcat(strcpy(d,s1),s2),s3)L#define strcpy4(d,s1,s2,s3,s4) strcat(strcat(strcat(strcpy(d,s1),s2),s3),s4)0#define strcat2(d,s1,s2) strcat(strcat(d,s1),s2)Z/* #define DeBuG(Vr,Tp) if _debug (fprintf(stderr,"Vr = %Tp\n",Vr)); /* from */ww |Ւ /* acldef *' * Access Control List definitions * */I#define ACL$K_LENGTH 0x0000000C /* Length of the overhead area */I#define ACL$C_LENGTH 0x0000000C /* Length of the overhead area *//* Object types */;#define ACL$C_FILE 0x00000001 /* Files */G#define ACL$C_DEVICE 0x00000002 /* MBX, MT, TT, etc. */J#define ACL$C_JOBCTL_QUEUE 0x00000003 /* Job controller queue */P#define ACL$C_COMMON_EF_CLUSTER 0x00000004 /* Common event flag clusters */I#define ACL$C_LOGICAL_NAME_TABLE 0x00000005 /* Logical name tables */=#define ACL$C_PROCESS 0x00000006 /* Process */K#define ACL$C_GROUP_GLOBAL_SECTION 0x00000007 /* Group global sections */L#define ACL$C_SYSTEM_GLOBAL_SECTION 0x00000008 /* System global sections */O#define ACL$C_RESERVED_OBJECT_1 0x00000009 /* Reserved object type (V5) */O#define ACL$C_RESERVED_OBJECT_2 0x0000000A /* Reserved object type (V5) */O#define ACL$C_RESERVED_OBJECT_3 0x0000000B /* Reserved object type (V5) */O#define ACL$C_RESERVED_OBJECT_4 0x0000000C /* Reserved object type (V5) *//* Action codes */>#define ACL$C_ADDACLENT 0x00000001 /* Add an ACL entry */A#define ACL$C_DELACLENT 0x00000002 /* Delete an ACL entry */A#define ACL$C_MODACLENT 0x00000003 /* Modify an ACL entry */A#define ACL$C_FNDACLENT 0x00000004 /* Locate an ACL entry */F#define ACL$C_FNDACETYP 0x00000005 /* Locate sp ecific ACE type */?#define ACL$C_DELETEACL 0x00000006 /* Delete entire ACL */:#define ACL$C_READACL 0x00000007 /* Read the ACL */B#define ACL$C_ACLLENGTH 0x00000008 /* Get the ACL's length */?#define ACL$C_READACE 0x00000009 /* Read a single ACE */>#define ACL$C_RLOCK_ACL 0x0000000A /* Read lock on ACL */?#define ACL$C_WLOCK_ACL 0x0000000B /* Write lock on ACL */D#define ACL$C_UNLOCK_ACL 0x0000000C /* Release exclusive lock */F#define ACL$C_GRANT_ACE 0x 0000000D /* ACE granting access (V5) */G#define ACL$C_NEXT_ACE 0x0000000E /* Increment ACE number (V5) */G#define ACL$C_RESERVED_ITEM_2 0x0000000F /* Reserved item code (V5) */G#define ACL$C_RESERVED_ITEM_3 0x00000010 /* Reserved item code (V5) */"#define ACL$S_ADDACLENT 0x000000FF"#define ACL$S_DELACLENT 0x000000FF"#define ACL$S_MODACLENT 0x000000FF"#define ACL$S_FNDACLENT 0x000000FF"#define ACL$S_FNDACETYP 0x000000FF"#define ACL$S_DELETEACL 0x000000FF"#define ACL$S_READAC L 0x00000200"#define ACL$S_ACLLENGTH 0x00000004"#define ACL$S_READACE 0x000000FF"#define ACL$S_RLOCK_ACL 0x00000004"#define ACL$S_WLOCK_ACL 0x00000004##define ACL$S_UNLOCK_ACL 0x00000004:#define ACL$S_GRANT_ACE 0x000000FF /* (V5) */:#define ACL$S_NEXT_ACE 0x00000004 /* (V5) */:#define ACL$S_RESERVED_ITEM_2 0x000000FF /* (V5) */:#define ACL$S_RESERVED_ITEM_3 0x000000FF /* (V5) */struct acldef {M char *acl$l_flink; /* Forward link to next list in the queue */J char *acl$l_blink; /* Back link to previous list in queue */= unsigned short acl$w_size; /* Total size of the list */: char acl$b_type; /* Structure type code */8 char acl$__fill_1; /* Spare unused byte */J char *acl$l_list; /* Start of the Access Control Entries */ }; /*acldef*/wwCLdef.H! |Ւ RANKIN FATdef.H!`@p|Ւ RANKIN FCHdef.H!@Ƃ|Ւ RANKIN FH2def.H!@ij|Ւ RANKIN FI2def.H!@ |Ւ RANKIN FM2def.H"Ɣ|Ւ RANKIN makefile."@aznՒ RANKIN build.comН|Ւ /* fatdef *# * File attributes definitions * */#define FAT$C_UNDEFINED 0#define FAT$C_FIXED 1#define FAT$C_VARIABLE 2#define FAT$C_VFC 3#define FAT$C_STREAM 4#define FAT$C_STREAMLF 5#define FAT$C_STREAMCR 6#define FAT$C_SEQUENTIAL 0#define FAT$C_RELATIVE 1#define FAT$C_INDEXED 2#define FAT$C_DIRECT 3#define FAT$M_FORTRANCC 1#define FAT$M_IMPLIEDCC 2#define FAT$M_PRINTCC 4#define FAT$M_NOSPAN 8#define FAT$K_LENGTH 32#define FAT$C_LENGTH 32#define FAT$S_FATDEF 32#define FAT$B_RTYPE 0#define FAT$S_RTYPE 4#define FAT$V_RTYPE 0#define FAT$S_FILEORG 4#define FAT$V_FILEORG 4#define FAT$B_RATTRIB 1#define FAT$V_FORTRANCC 0#define FAT$V_IMPLIEDCC 1#define FAT$V_PRINTCC 2#define FAT$V_NOSPAN 3#define FAT$W_RSIZE 2#define FAT$L_HIBLK 4#define FAT$W_HIBLKH 4#define FAT$W_HIBLKL 6#define FAT$L_EFBLK 8#define FAT$W_EFBLKH 8#define FAT$W_EFBLKL 10#define FAT$W_FFBYTE 12#define FAT$B_BKTSIZE 14#define FAT$B_VFCSIZE 15#define FAT$W_MAXREC 16#define FAT$W_DEFEXT 18#define FAT$W_GBC 20#define FAT$W_VERSIONS 30struct fatdef { variant_struct {< unsigned fat$v_rtype : 4; /* record format */@ unsigned fat$v_fileorg : 4; /* file organization */ } fat$r_rtype_fields;G unsigned char fat$b_rattrib; /* record attributes */R unsigned short fat$w_rsize; /* record size (longest record) */ variant_union {L unsigned long fat$l_hiblk; /* highest block (PDP-11 format) */ unsigned short fat$w_hiblk[2]; variant_struct {9 unsigned short fat$w_hiblkh; /* upper word */9 unsigned short fat$w_hiblkl; /* lower word */ } fat$r_hiblk_fields; } fat$r_hiblk_overlay; variant_union {K unsigned long fat$l_efblk; /* end-of-file bl ock (reversed) */ unsigned short fat$w_efblk[2]; variant_struct {9 unsigned short fat$w_efblkh; /* upper word */9 unsigned short fat$w_efblkl; /* lower word */ } fat$r_efblk_fields; } fat$r_efblk_overlay;S unsigned short fat$w_ffbyte; /* first free byte of last block */A unsigned char fat$b_bktsize; /* bucket size */Q unsigned char fat$b_vfcsize; /* fixed portion of vfc format */K unsigned short  fat$w_maxrec; /* maximum record length */K unsigned short fat$w_defext; /* default extend amount */I unsigned short fat$w_gbc; /* global buffer count */> char fatdef$$_fill_1[6]; /* reserved */> char fatdef$$_fill_2[2]; /* not used */V unsigned short fat$w_versions; /* version limit (directories only) */ }; /*fatdef*/www_|Ւ /* fchdef *' * File characteristic definitions * */#define FCH$M_NOBACKUP 2#define FCH$M_WRITEBACK 4#define FCH$M_READCHECK 8#define FCH$M_WRITCHECK 16#define FCH$M_CONTIGB 32#define FCH$M_LOCKED 64#define FCH$M_CONTIG 0x0080#define FCH$M_BADACL 0x0800#define FCH$M_SPOOL 0x1000#define FCH$M_DIRECTORY 0x2000#define FCH$M_BADBLOCK 0x4000#define FCH$M_MARKDEL 0x8000"#define FCH$M_NOCHARGE 0x00010000"#define FCH$M_ERASE  0x00020000#define FCH$S_FCHDEF 4I#define FCH$V_NOBACKUP 1 /* file is not to be backed up */F#define FCH$V_WRITEBACK 2 /* write-back cache enabled */I#define FCH$V_READCHECK 3 /* verify add write operations */H#define FCH$V_WRITCHECK 4 /* verify add read operations */A#define FCH$V_CONTIGB 5 /* contiguous best-try */?#define FCH$V_LOCKED 6 /* deaccessed locked */8#define FCH$V_CONTIG 7  /* contiguous */<#define FCH$V_BADACL 11 /* ACL is corrupt */E#define FCH$V_SPOOL 12 /* intermediate spool file */<#define FCH$V_DIRECTORY 13 /* directory file */H#define FCH$V_BADBLOCK 14 /* file contains bad block(s) */?#define FCH$V_MARKDEL 15 /* marked for delete */#define FCH$V_NOCHARGE 16=#define FCH$V_ERASE 17 /* erase on delete */struct fchdef {$ unsigned : 1;$ unsigned fch$v_nobackup : 1;$ unsigned fch$v_writeback : 1;$ unsigned fch$v_readcheck : 1;$ unsigned fch$v_writcheck : 1;$ unsigned fch$v_contigb : 1;$ unsigned fch$v_locked : 1;$ unsigned fch$v_contig : 1;$ unsigned : 3;$ unsigned fch$v_badacl : 1;$ unsigned fch$v_spool : 1;$ unsigned fch$v_directory : 1;$ unsigned fch$v_badblock : 1;$ unsigned fch$v_markdel : 1;$ unsigned fch$v_nocharge : 1;$ unsigned fch$v_erase : 1;$ unsigned :14; }; /*fchdef*/ww2$M_BADBLOCK 0x4000#define FH2$M_MARKDEL 0x8000"#define FH2$M_NOCHARGE 0x00010000"#define FH2$M_ERASE 0x00020000#define FH2$M_ONLY_RU 1#define FH2$M_RUJNL 2#define FH2$M_BIJNL 4#define FH2$M_AIJNL 8#define FH2$M_ATJNL 16#define FH2$M_NEVER_RU 32#define FH2$M_JOURNAL_FILE 64!#define FH2$C_RU_FACILITY_RMS 1!#define FH2$C_RU_FACILITY_DBMS 2!#define FH2$C_RU_FACILITY_RDB 3"#define FH2$C_RU_FACILITY_CHKPNT 4#define FH2$K_LENGTH 80#define FH2$C_LENGTH 80#define FH2$K_SUBSET0_LENGTH 88#define FH2$C_SUBSET0_LENGTH 88#define FH2$K_FULL_LENGTH 108#define FH2$C_FULL_LENGTH 108#define FH2$S_FH2DEF 512#define FH2$B_IDOFFSET 0#define FH2$B_MPOFFSET 1#define FH2$B_ACOFFSET 2#define FH2$B_RSOFFSET 3#define FH2$W_SEG_NUM 4#define FH2$W_STRUCLEV 6#define FH2$B_STRUCVER 6#define FH2$B_STRUCLEV 7#define FH2$S_FID 6#define FH2$W_FID 8#define FH2$W_FID_NUM 8#define FH2$W_FID_SEQ 10#define FH2$W_FID_RVN 12#define FH2$B_FID_RVN 12#define FH2$B_FID_NMX 13#define FH2$S_EXT_FID 6#define FH2$W_EXT_FID 14#define FH2$W_EX_FIDNUM 14#define FH2$W_EX_FIDSEQ 16#define FH2$W_EX_FIDRVN 18#define FH2$B_EX_FIDRVN 18#define FH2$B_EX_FIDNMX 19#define FH2$S_RECATTR 32#define FH2$W_RECATTR 20#define FH2$L_FILECHAR 52#define FH2$V_NOBACKUP 1#define FH2$V_WRITEBACK 2#define FH2$V_READCHECK 3#define FH2$V_WRITCHECK 4#define FH2$V_CONTIGB 5#define FH2$V_LOCKED 6#define FH2$V_CONTIG 7#define FH2$V_BADACL 11#define FH2$V_SPOOL 12#define FH2$V_DIRECTORY 13#define FH2$V_BADBLOCK 14#define FH2$V_MARKDEL 15#define FH2$V_NOCHARGE 16#define FH2$V_ERASE 17#define FH2$W_RECPROT 56#define FH2$B_MAP_INUSE 58#define FH2$B_ACC_MODE 59#define FH2$L_FILEOWNER 60#define FH2$W_UICMEMBER 60#define FH2$W_UICGROUP 62#define FH2$W_FILEPROT 64#define FH2$S_BACKLINK 6#define FH2$W_BACKLINK 66#define FH2$W_BK_FIDNUM 66#define FH2$W_BK_FIDSEQ 68#define FH2$W_BK_FIDRVN 70#define FH2$B_BK_FIDRVN 70#define FH2$B_BK_FIDNMX 71#define FH2$B_JOURNAL 72#define FH2$V_ONLY_RU 0#define FH2$V_RUJNL 1#define FH2$V_BIJNL 2#define FH2$V_AIJNL 3#define FH2$V_ATJNL 4#define FH2$V_NEVER_RU 5#define FH2$V_JOURNAL_FILE 6#define FH2$B_RU_ACTIVE 73#define FH2$L_HIGHWATER 76#define FH2$S_CLASS_PROT 20#define FH2$R_CLASS_PROT 88#define FH2$W_ CHECKSUM 510struct fh2def {D unsigned char fh2$b_idoffset; /* id area offset */E unsigned char fh2$b_mpoffset; /* map area offset */E unsigned char fh2$b_acoffset; /* acl area offset */J unsigned char fh2$b_rsoffset; /* reserved area offset */D unsigned short fh2$w_seg_num; /* segment number */ variant_union {> unsigned short fh2$w_struclev; /* structure level */ variant_struct {@  unsigned char fh2$b_strucver; /* structure version */> unsigned char fh2$b_struclev; /* structure level */ } fh2$r_struclev_fields; } fh2$r_struclev_overlay; variant_union {B unsigned short fh2$w_fid[3]; /* file identification */ variant_struct {: unsigned short fh2$w_fid_num; /* file number */> unsigned short fh2$w_fid_seq; /* sequence number */ variant_union {' unsigned short fh2$w_fid_rvn; variant_struct {B unsigned char fh2$b_fid_rvn; /* relative volume no. (disk) */A unsigned char fh2$b_fid_nmx; /* file no. extension (disk) */ } fh2$r_fid_rvn_fields; } fh2$r_fid_rvn_overlay; } fh2$r_fid_fields; } fh2$r_fid_overlay; variant_union {N unsigned short fh2$w_ext_fid[3]; /* extension header identification */ variant_struct {% unsigned short fh2$w_ex_fidnum;% unsigned short fh2$w_ex_fidseq; variant_union {) unsigned short fh2 $w_ex_fidrvn; variant_struct {" unsigned char fh2$b_ex_fidrvn;" unsigned char fh2$b_ex_fidnmx;! } fh2$r_ex_fidrvn_fields; } fh2$r_ex_fidrvn_overlay; } fh2$r_ext_fid_fields; } fh2$r_ext_fid_overlay;G struct fatdef fh2$w_recattr; /* record attributes */J unsigned long fh2$l_filechar; /* file characteristics */G unsigned short fh2$w_recprot; /* record protection */K unsigned char fh2$b_map_inuse;  /* map area words in use */H unsigned char fh2$b_acc_mode; /* caller access mode */ variant_union {= unsigned long fh2$l_fileowner; /* file owner uic */ variant_struct {% unsigned short fh2$w_uicmember;$ unsigned short fh2$w_uicgroup; } fh2$r_uic_fields; } fh2$r_fileowner_overlay;J unsigned short fh2$w_fileprot; /* file protection mask */ variant_union {P unsigned short fh2$w_backlink[3]; /* directory backlink identification */ variant_struct {% unsigned short fh2$w_bk_fidnum;% unsigned short fh2$w_bk_fidseq; variant_union {) unsigned short fh2$w_bk_fidrvn; variant_struct {" unsigned char fh2$b_bk_fidrvn;" unsigned char fh2$b_bk_fidnmx;! } fh2$r_bk_fidrvn_fields; } fh2$r_bk_fidrvn_overlay; } fh2$r_backlink_fields; } fh2$r_backlink_overlay;H unsigned char fh2$b_journal; /* journaling options */O unsigned cha r fh2$b_ru_active; /* recovery unit active flag */+ char fh2def$$_fill_1[2];D unsigned long fh2$l_highwater; /* highwater mark */+ char fh2def$$_fill_2[8];M char fh2$r_class_prot[20]; /* security classification */- char fh2def$$_fill_3[402];' unsigned short fh2$2_checksum; }; /*fh2def*/wwO|Ւ /* fi2def *3 * Identification portion of ods-2 file header * */#define FI2$K_LENGTH 120#define FI2$C_LENGTH 120#define FI2$S_FI2DEF 200#define FI2$S_FILENAME 20#define FI2$T_FILENAME 0#define FI2$W_REVISION 20#define FI2$S_CREDATE 8#define FI2$Q_CREDATE 22#define FI2$S_REVDATE 8#define FI2$Q_REVDATE 30#define FI2$S_EXPDATE 8#define FI2$Q_EXPDATE 38#define FI2$S_BAKDATE 8#define FI2$Q_BAKDATE 46#define FI2$S_FILENAMEXT 66#define FI2$T_FILENAMEXT 54#define FI2$S_USERLABEL 80#define FI2$T_USERLABEL 120struct fi2def {M char fi2$t_filename[20]; /* filename.type;vers (1st 20) */@ unsigned short fi2$w_revision; /* revision count */D long fi2$q_credate[2]; /* creation date/time */S long fi2$q_revdate[2]; /* revision (modification) date/time */F long fi2$q_expdate[2]; /* expiration date/time */B  long fi2$q_bakdate[2]; /* backup date/time */N char fi2$t_filenamext[66]; /* filename.type;vers (last 66) */E char fi2$t_userlabel[80]; /* user file label (?) */ }; /*fi2def*/ww|Ւ /* fm2def *< * Map (retreival pointer) portion of ods-2 file header * */#define FM2$C_PLACEMENT 0#define FM2$C_FORMAT1 1#define FM2$C_FORMAT2 2#define FM2$C_FORMAT3 3#define FM2$K_LENGTH0 2#define FM2$C_LENGTH0 2#define FM2$K_LENGTH1 4#define FM2$C_LENGTH1 4#define FM2$S_FM2DEF 4#define FM2$W_WORD0 0#define FM2$S_FORMAT 2#define FM2$V_FORMAT 14#define FM2$V_EXACT 0#define FM2$V_ONCYL 1#define FM2$V_LBN 12#define FM2$V_RVN 13#define FM2$S_HIGHLBN 6#define FM2$V_HIGHLBN 8#define FM2$S_COUNT2 14#define FM2$V_COUNT2 0#define FM2$B_COUNT1 0#define FM2$W_LOWLBN 2#define FM2$K_LENGTH2 6#define FM2$C_LENGTH2 6#define FM2$S_FM2DEF1 6#define FM2$L_LBN2 2#define FM2$K_LENGTH3 8#define FM2$C_LENGTH3 8#define FM2$S_FM2DEF2 8#define FM2$W_LOWCOUNT 2#define FM2$L_LBN3 4struct fm2def { variant_unio n {! unsigned short fm2$w_word0;1 variant_struct { /* type of retreival pointer */) unsigned : 14;) unsigned fm2$v_format : 2; } fm2$r_mapwrd_type;_ variant_struct { /* format 0: placement specification (applies to next retreival pointer) */) unsigned fm2$v_exact : 1;) unsigned fm2$v_oncyl : 1;) unsigned : 10;) unsigned fm2$v_lbn : 1;) unsigned fm2$v _rvn : 1;= unsigned : 2; /* format */ } fm2$r_placement;= variant_struct { /* format 1: count <= 255, lbn < 2**22 */+ unsigned char fm2$b_count1; /* 8 */) unsigned fm2$v_highlbn : 6;= unsigned : 2; /* format */" unsigned short fm2$w_lowlbn; } fm2$r_format1;> variant_struct { /* format 2: count < 2**14, lbn < 2**32 */) unsigned fm2$v_count : 14;= unsigned : 2; /* format */ unsigned long fm2$l_lbn2; } fm2$r_format2;> variant_struct { /* format 3: count < 2**30, lbn < 2**32 */) unsigned fm2$v_highcnt : 14;= unsigned : 2; /* format */$ unsigned short fm2$w_lowcount; unsigned long fm2$l_lbn3; } fm2$r_format3;$ unsigned char fm2$b_bytes[8]; } fm2$r_overlay; }; /*fm2def*/ww@|Ւ#*# makefile for XShow#:# $ make -r [-w] [debug|noopt|d_lines] xshow xshoque#xshow : xshow.exe write sys$output " -XShow- "xshoque : xshoque.exe write sys$output " -XShoQue- "xshofiles : xshofiles.exe! write sys$output " -XShoFiles- "3debug : fdebug # compile/debug, link/debug* if f$type(CC).nes."STRING" then cc := cc cc := 'cc'/noopt/debug3 if f$type(MACRO).nes."STRING" then macro := macro macro := 'macro'/debug0 if f$type(LINK).nes."STRING" then link := link link := 'link'/debug/traceback.fdebug : # compile/debug, link normally+ on warning then exit $status.or.%x100000009 if f$type(FORTRAN).nes."STRING" then fortran := fortran! fortran := 'fortran'/noopt/debug;noopt fnoopt : # compile/nooptimize for quicker turnaround+ on warning then exit $status.or.%x100000009 if f$type(FORTRAN).nes."STRING" then fortran := fortran fortran := 'fortran'/noopt* if f$type(CC).nes."STRING" then cc := cc cc := 'cc'/noopt!d_lines : # fortran/d_lines+ on warning then exit $status.or.%x100000009 if f$type(FORTRAN).nes."STRING" then fortran := fortran fortran := 'fortran'/d_lines"analysis sca : # compile/analysis9 if f$type(FORTRAN).nes."STRING" then fortran := fortran fortran := 'fortran'/analys* if f$type(CC).nes."STRING" then cc := cc cc := 'cc'/analysIxshow.exe : xshow.obj xshow1.obj xshow2.obj xshow_dcl.obj xshocpu.obj \ dyn amic.obj format.obj) write sys$$output " Linking ""XShow"" "F link XShow.Obj,XShow1,XShow2,XShow_Dcl,XShoCpu,Dynamic.Obj,Format.ObjIxshoque.exe : xshoque.obj xshoque1.obj xshoque2.obj xshoque3.obj \B dynamic.obj format.obj netwrkmsg.obj \ xshoque.f xshoque_def.f+ write sys$$output " Linking ""XShoQue"" ". link XShoQue.Obj,XShoQue1,XShoQue2,XShoQue3,-& Dynamic.Obj,Format.Obj,NetwrkMsg.ObjIxshofiles.exe : xshofiles.obj xshofiles1.obj xshofiles2.obj \; dynamic.obj format.obj \ xshofiles.f- write sys$$output " Linking ""XShoFiles"" "C link XShoFiles.Obj,XShoFiles1,XShoFiles2,Dynamic.Obj,Format.Obj, - sys$input:/options# sys$share:VaxCRtl/share $*.obj : *.for, write sys$$output " Compiling ""$*.For"" " fortran $*.Forxshofiles1.obj : xshofiles1.c2 write sys$$output " Compiling ""XShoFiles1.C"" " cc XShoFiles1.Cxshofiles2.obj : xshofiles2.c2 write sys$$output " Compiling ""XShoFiles2.C"" " cc XShoFiles2.Cxshow_dcl.obj : xshow_dcl.mar4 write sys$$output " Assembling ""XShow_Dcl.Mar"" " macro XShow_Dcl.Marxshocpu.obj : xshocpu.mar2 write sys$$output " Assembling ""XShoCpu.Mar"" " macro XShoCpu.MarOnetwrkmsg.obj : # create indirect message module (for LAT queue status). write sys$$output " Building ""NetwrkMsg"" "7 message/object=[]NetwrkMsg/file=NetwrkMsg nl:NetwrkMsgLxshoque.obj xshoque1.obj xshoque2.obj xshoque3.obj : xshoque.f xshoque_def.f#ww rnՒ+$! compile and/or link some or all of XSHOW$! usage: $ @build *$ $ p1 := 'p1'#$ if p1.eqs."LINK" then goto link%$ lib_rpl := libr/obj xsho/repl0$ if p1.eqs."" .or. p1.eqs."ALL" then p1 = "*"$ if p1.nes."*" then goto 'p1$$common:8$ if f$trnlnm("f_inc").eqs."" then define/job f_inc []F$ if f$search("xsho.olb").eqs."" then library/object/create xsho.olb$ fortran []dynamic$ lib_rpl []dynamic$ fortran []format$ lib_rpl []format&$  if p1.eqs."COMMON" then goto _done$$xshow:$ fortran []xshow$ lib_rpl []xshow$ fortran []xshow1$ lib_rpl []xshow1$ fortran []xshow2$ lib_rpl []xshow2$ macro []xshow_dcl$ lib_rpl []xshow_dcl$ macro []xshocpu$ lib_rpl []xshocpu&$ if p1.eqs."XSHOW" then goto _check$ $xshoque:$ fortran []xshoque$ lib_rpl []xshoque$ fortran []xshoque1$ lib_rpl []xshoque1$ fortran []xshoque2$ lib_rpl []xshoque2$ fortran []xshoque3$ lib_rpl []xshoque39$ message/object=[]netwrkmsg/file=netwrkmsg nl:netwrkmsg$ lib_rpl []netwrkmsg($ if p1.eqs."XSHOQUE" then goto _check$ $xshofiles:$ fortran []xshofiles$ lib_rpl []xshofiles$ cc []xshofiles1$ lib_rpl []xshofiles1$ cc []xshofiles2$ lib_rpl []xshofiles2($ if p1.eqs."XSHOQUE" then goto _check$ $xshocmd:"$! (VERB must be built separately)/$ if p1.eqs."XSHOCMD" then exit %x002A !abort$$_check:"$ if p1.eqs."*" then p1 = "LINK"6$ if p1.eqs."LINK" .or. p2.eqs."LINK" then goto link $ goto _done$$link:.$ if p1.eqs."LINK" .or. p1.eqs."XSHOW" then -# link/exe=xshow xsho/lib/incl=xshow0$ if p1.eqs."LINK" .or. p1.eqs."XSHOQUE" then -3 link/exe=xshoque xsho/lib/incl=(xshoque,netwrkmsg)=$ if p1.nes."LINK" .and. p1.nes."XSHOFILES" then goto _doneG$ link/exe=xshofiles xsho/lib/incl=xshow_files,sys$input:/optionssys$share:vaxcrtl/shareable$$_done:$ exitww