as_meters.pl1 08/04/87 1455.5rew 08/04/87 1222.1 155664 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ as_meters: proc; /* Command to print >sc1>as_meter_table. Coded by Tom Casey, March 1980. Modified May 1981 by T. Casey to print asmt meters in header. Modified June 1981 by T. Casey for MR9.0 to print the ABS_TRYLOG meter. Modified July 1981 by T. Casey to add -reset, -report_reset, &c. */ /****^ HISTORY COMMENTS: 1) change(87-07-21,Herbst), approve(87-07-21,MCR7694), audit(87-07-21,GDixon), install(87-08-04,MR12.1-1055): A) Update for AS_METER_NAMES array declared in as_meter_numbers.incl.pl1. END HISTORY COMMENTS */ /* Ext. Entries */ dcl cu_$arg_count entry returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl (ioa_, ioa_$rsnnl, com_err_) entry options (variable); dcl date_time_ entry (fixed bin (71), char (*)); dcl decode_clock_value_$date_time entry (fixed bin (71), fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin, fixed bin (71), fixed bin, char (3), fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); /* Automatic and Based */ dcl code fixed bin (35); dcl ignore_code fixed bin (35); /* crossref will show where we ignore return codes */ dcl i fixed bin; dcl (month, day, year, hour, minute, second, dow) fixed bin; dcl usec fixed bin (71); dcl zone char (3) init (""); dcl (asmtp, asmtep) ptr init (null); dcl argp ptr, argl fixed bin, arg char (argl) based (argp); dcl totalsw bit (1) aligned init (""b); dcl namesw bit (1) aligned init ("1"b); dcl shortnamesw bit (1) aligned init (""b); dcl total_real_time fixed bin (71); dcl sigma_vcpu fixed bin (71) init (0); dcl sigma_pf fixed bin (34) init (0); dcl dtstr char (16); dcl now fixed bin (71); dcl today char (8); dcl (reset_sw, report_reset_sw, un_reset_sw, temp_un_reset_sw, pct_sw, no_header_sw, meter_sw) bit (1) aligned init (""b); dcl asmt_copy (asmt_length) fixed bin (35) aligned based; /* overlay to copy asmt segment */ dcl asmt_length fixed bin; /* length of overlay */ dcl 1 rasmt like asmt aligned based (real_asmtp); /* "rasmt" is easier to type than "real_asmtp -> asmt" */ /* Static */ dcl real_asmtp ptr int static init (null); /* ptr to real as_meter_table, in >sc1 (or test dir) */ dcl temp_ptr (2) ptr int static init ((2) null); /* ptrs to two temp segs */ dcl prev_asmtp ptr defined (temp_ptr (1)); /* 1st one points to copy of as_meter_table made at reset time */ dcl diff_asmtp ptr defined (temp_ptr (2)); /* 2nd one points to difference between copy and current values */ dcl reset bit (1) int static init (""b); /* on if we have saved a copy because user said -reset */ dcl reset_time fixed bin (71) int static; /* time that reset was done */ dcl selected (36) bit (1) unaligned int static init ((36) (1)"1"b); dcl sysdir char (168) int static init (">sc1"); /* Constant */ dcl me char (9) int static options (constant) init ("as_meters"); dcl digits char (10) int static options (constant) init ("0123456789"); dcl UPPER char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl LOWER char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); /* Builtin */ dcl (addr, clock, divide, float, hbound, length, ltrim, mod, null, size, substr, translate) builtin; if real_asmtp = null then do; /* get ptr to as_meter_table if we don't already have it */ call hcs_$initiate (sysdir, "as_meter_table", "", (0), (1), real_asmtp, code); if real_asmtp = null then do; call com_err_ (code, me, "^a>as_meter_table", sysdir); return; end; end; now = clock (); call date_time_ (now, dtstr); today = substr (dtstr, 1, 8); do i = 1 to cu_$arg_count (); call cu_$arg_ptr (i, argp, argl, ignore_code); if arg = "-tt" | arg = "-total" | arg = "-totals" then totalsw = "1"b; else if arg = "-sh" | arg = "-short" | arg = "-short_name" | arg = "-shnm" then do; shortnamesw = "1"b; namesw = ""b; end; else if arg = "-rs" | arg = "-reset" then reset_sw = "1"b; else if arg = "-rrs" | arg = "-report_reset" then reset_sw, report_reset_sw = "1"b; else if arg = "-urs" | arg = "-unreset" then un_reset_sw = "1"b; else if arg = "-turs" | arg = "-temp_unreset" then temp_un_reset_sw = "1"b; else if arg = "-pct" | arg = "-percent" then pct_sw = "1"b; else if arg = "-nhe" | arg = "-no_header" then no_header_sw = "1"b; else if arg = "-mt" | arg = "-meter" then call get_selected_meter_names; else do; call com_err_ (0, "as_meters", "Unknown argument: ^a", arg); return; end; end; /* end loop thru arglist */ /* Decide what to do: report, reset, or some combination or variation of them */ if reset_sw then /* if user wants to reset now */ if ^report_reset_sw then /* and he doesn't want a report first */ goto do_reset; /* go do the reset */ asmtp = real_asmtp; /* assume we'll print real asmt, until we discover otherwise */ if un_reset_sw then /* if user wants to permanently cancel a previous reset */ if reset then /* and there was one */ do; /* then cancel it */ reset = ""b; /* forget it was done */ call release_temp_segment_ (me, prev_asmtp, code); /* release the seg it was in */ if code ^= 0 then goto temp_seg_error; end; if reset then /* if we did a reset previously */ if ^temp_un_reset_sw then /* and user doesn't want to temporarily ignore it */ do; /* then subtract previous values from current ones */ call get_temp_segment_ (me, diff_asmtp, code); /* we always release this when done printing */ if code ^= 0 then goto temp_seg_error; asmtp = diff_asmtp; /* we'll print the seg containing the differences */ asmt = /* if this works, I'll buy the compiler writers a beer */ real_asmtp -> asmt - prev_asmtp -> asmt; /* subtract everything */ end; /* Compute total real time. This does not include real time spent in un-metered code, so it is a little low. */ total_real_time = 0; do i = 1 to hbound (asmt.entry, 1); /* add up individual real times */ total_real_time = total_real_time + asmt.entry (i).real_time; /* NOT tot_real_time */ end; /* that would be double counting */ /* Print header */ if no_header_sw then goto skip_header; if ^totalsw then /* print heading (different if reset or not) */ if reset & ^temp_un_reset_sw then call ioa_ ("Reset at ^a; metering time: ^a", dt (reset_time), ti (now - reset_time)); else call ioa_ ("Startup at ^a, vcpu = ^.3f, pf = ^d; metering time: ^a", dt (asmt.startup_clock), asmt.startup_vcpu/1.0e6, asmt.startup_pf, ti (now - asmt.startup_clock)); call ioa_ ("Latest update^[ (in progress)^] at ^a, rt = ^.3f, vcpu = ^.3f, pf = ^d", (rasmt.update_in_progress ^= 0), dt (rasmt.latest_clock), total_real_time/1.0e6, asmt.latest_vcpu/1.0e6, asmt.latest_pf); if totalsw then goto do_reset; /* no more output wanted; go reset (if wanted) & return */ if rasmt.global_entered > 0 then call ioa_ ("There ^[is^;are^] ^d call^[s^] in progress.", (rasmt.global_entered = 1), rasmt.global_entered, (rasmt.global_entered > 1)); call ioa_ ("Logins: ^d int, ^d abs, ^d dmn; logouts: ^d int, ^d abs, ^d dmn.", asmt.logins, asmt.logouts); call ioa_ ("ASMT: ^d, RT: ^.3f, VCPU: ^.3f, PF: ^d^/", asmt.asmt_count, asmt.asmt_real_time/1.0e6, asmt.asmt_vcpu/1.0e6, asmt.asmt_pf); /* Print a line of column headings, and then one or more lines for each used (and selected) entry */ call ioa_ ("^5tUPD_TIME^14tCOUNT^20tTOTAL_REAL^31tTOTAL_VCPU^42tTOTALPF^50t^6xREAL^61t^6xVCPU^72t^5xPF"); if pct_sw then call ioa_; /* blank line if printing 4-line group per entry */ skip_header: do i = 1 to hbound (asmt.entry, 1); asmtep = addr (asmt.entry (i)); if asmte.entry_count > 0 & selected (i) then do; call ioa_ ( "^[^3a^s^;^s^2d)^]^[*^;^x^]^8a^14t^5d^[(^d)^;^s^]^20t^10.3f^31t^10.3f^42t^7d^50t^10.3f^61t^10.3f^72t^7d^[^x^a^]", shortnamesw, substr (AS_METER_NAMES (i), 1, 3), i, asmte.entered > 0, tm (rasmt.entry (i).update_clock), asmte.entry_count, (asmte.recursive_entry_count ^= 0), asmte.recursive_entry_count, asmte.tot_real_time/1.0e6, asmte.tot_vcpu/1.0e6, asmte.tot_pf, asmte.real_time/1.0e6, asmte.vcpu/1.0e6, asmte.pf, namesw, AS_METER_NAMES (i)); sigma_vcpu = sigma_vcpu + asmte.vcpu; sigma_pf = sigma_pf + asmte.pf; /* If -pct arg given, print 3 more lines for this entry: percent of total, per-call usage, pf per (real vcpu) sec */ if pct_sw then do; /* percent of total */ if asmt.latest_pf > 0 then /* avoid zerodivides */ call ioa_ ("^5t% of tot^20t^8.1f%^31t^8.1f%^42t^6.1f%^50t^8.1f%^61t^8.1f%^72t^6.1f%", (1.0e2*asmte.tot_real_time)/total_real_time, (1.0e2*asmte.tot_vcpu)/asmt.latest_vcpu, (1.0e2*asmte.tot_pf)/asmt.latest_pf, (1.0e2*asmte.real_time)/total_real_time, (1.0e2*asmte.vcpu)/asmt.latest_vcpu, (1.0e2*asmte.pf)/asmt.latest_pf); /* per-call usage */ call ioa_ ("^5tper-call^20t^10.3f^31t^10.3f^42t^7.2f^50t^10.3f^61t^10.3f^72t^7.2f", asmte.tot_real_time / (1.0e6*asmte.entry_count), asmte.tot_vcpu/ (1.0e6*asmte.entry_count), float (asmte.tot_pf)/asmte.entry_count, asmte.real_time/ (1.0e6*asmte.entry_count), asmte.vcpu/ (1.0e6*asmte.entry_count), float (asmte.pf)/asmte.entry_count); /* page faults per real and vcpu second */ if asmte.vcpu > 0 then /* avoid zerodivides */ call ioa_ ("^5tpf/sec^20t^8.1f^31t^8.1f^50t^8.1f^61t^8.1f", (1.0e6*asmte.tot_pf)/asmte.tot_real_time, (1.0e6*asmte.tot_pf)/asmte.tot_vcpu, (1.0e6*asmte.pf)/asmte.real_time, (1.0e6*asmte.pf)/asmte.vcpu); call ioa_; /* separate the 4-line per-entry groups with blank lines */ end; /* end -pct given */ end; /* end this entry used and selected */ end; /* end loop thru all entries */ /* Compute and print the "Other" usage, i.e. that not included in any of the above meters */ if ^meter_sw then do; /* only when printing all meters */ sigma_vcpu = asmt.latest_vcpu - sigma_vcpu - asmt.startup_vcpu; sigma_pf = asmt.latest_pf - sigma_pf - asmt.startup_pf; call ioa_ ("^/Other (not metered) vcpu and pf:^61t^10.3f^72t^7d", sigma_vcpu/1.0e6, sigma_pf); if pct_sw & asmt.latest_pf > 0 then /* avoid zerodivides */ call ioa_ ("^61t^8.1f%^72t^6.1f%", (1.0e2*sigma_vcpu)/asmt.latest_vcpu, (1.0e2*sigma_pf)/asmt.latest_pf); call ioa_; /* blank line at end */ end; /* If we did a reset previously, release the temp seg containing the differences. */ if reset then do; call release_temp_segment_ (me, diff_asmtp, code); if code ^= 0 then goto temp_seg_error; end; /* If user wants to do a reset now, save a copy of the live asmt */ do_reset: if reset_sw then do; /* if user wants to reset now, save current values */ if prev_asmtp = null then do; /* if we don't have a temp seg to save them, get one */ call get_temp_segment_ (me, prev_asmtp, code); if code ^= 0 then goto temp_seg_error; end; asmt_length = size (asmt); /* size of stuff to copy */ prev_asmtp -> asmt_copy = real_asmtp -> asmt_copy; reset_time = now; reset = "1"b; /* remember that we have saved the values */ end; return; temp_seg_error: call com_err_ (code, me, "(temp segment)"); error_return: return; /* ******************** */ dt: proc (clk) returns (char (17) varying); /* to format and return the date (if not today) and time */ dcl clk fixed bin (71); dcl c17 char (17) varying; dcl c8 char (8); dcl hhmmss char (8) init ("hh:mm:ss"); dcl dtsw bit (1) aligned; dtsw = "1"b; goto dt_common; tm: entry (clk) returns (char (8)); /* to format and return just the time */ dtsw = ""b; dt_common: call date_time_ (clk, dtstr); call decode_clock_value_$date_time (clk, month, day, year, hour, minute, second, usec, dow, zone, code); substr (hhmmss, 1, 2) = substr (dtstr, 11, 2); /* whoever invented the tenths of a minute date time format */ substr (hhmmss, 4, 2) = substr (dtstr, 13, 2); /* should be forced to use watches and clocks */ if code = 0 then do; /* whose faces are calibrated in tenths of a minute */ substr (hhmmss, 7, 1) = substr (digits, 1+divide (second, 10, 17, 0)); /* and whose second hands */ substr (hhmmss, 8, 1) = substr (digits, 1+mod (second, 10)); /* jump ahead every 6 seconds */ end; else substr (hhmmss, 7, 2) = "??"; /* if code is nonzero, we don't know the seconds */ if dtsw then do; /* return date (if not today) as well as time */ if substr (dtstr, 1, 8) = today then c17 = hhmmss; /* just return time, since date is today */ else do; c17 = substr (dtstr, 1, 8); c17 = c17 || " "; c17 = c17 || hhmmss; end; return (c17); end; else do; /* we can only return 8 chars, so just return time */ c8 = hhmmss; if substr (dtstr, 1, 8) ^= today then do; /* KLUDGE to flag time as not in current day */ substr (c8, 3, 1) = "!"; /* I said it was a kludge ... */ substr (c8, 6, 1) = "!"; /* but we only have 8 characters */ end; return (c8); end; end dt; /* ******************** */ get_selected_meter_names: proc; /* process args after -meter */ dcl ix fixed bin; dcl name_arg char (8) varying; if ^meter_sw then do; /* if this is first -meter arg on command line */ selected (*) = ""b; /* clear all the switches */ meter_sw = "1"b; /* remember that we did so */ end; get_next_meter_arg: call cu_$arg_ptr (i+1, argp, argl, code); /* look at next arg */ if code ^= 0 then return; /* if no more args */ if substr (arg, 1, 1) = "-" then return; /* if it is a control arg */ i = i + 1; /* we're going to use this arg; bump index to next one */ if arg = "all" then do; selected (*) = "1"b; meter_sw = ""b; /* we aren't printing a subset of the meters */ return; end; name_arg = translate (arg, UPPER, LOWER); /* get it in all upper case */ do ix = 1 to hbound (AS_METER_NAMES, 1) /* look for exact match between arg and meter name */ while (AS_METER_NAMES (ix) ^= name_arg); end; if ix <= hbound (AS_METER_NAMES, 1) then do; selected (ix) = "1"b; goto get_next_meter_arg; end; do ix = 1 to hbound (AS_METER_NAMES, 1) /* look for match between arg and first few chars of meter name */ while (substr (AS_METER_NAMES (ix), 1, length (name_arg)) ^= name_arg); end; if ix <= hbound (AS_METER_NAMES, 1) then do; selected (ix) = "1"b; goto get_next_meter_arg; end; call com_err_ (0, me, "Unknown meter name: ^a", arg); goto error_return; end get_selected_meter_names; /* ******************** */ ti: proc (int) returns (char (9) varying); /* format and return a time interval as HHH:MM:SS */ dcl int fixed bin (71); dcl rs char (9) varying; dcl int_pic pic "zzzzzzzz9"; dcl sum fixed bin; hour = divide (int, 3600*1000000, 71, 0); minute = divide (int, 60*1000000, 71, 0) - hour*60; second = divide (int, 1000000, 71, 0) - hour*3600 - minute*60; sum = second + minute*1000 + hour*1000000; /* HHH0MM0SS */ if sum > 999999999 then do; /* avoid blowup in picture conversion */ if hour > 999999 then rs = "999999+hr"; else call ioa_$rsnnl ("^6d+hr", rs, (0), hour); end; else do; int_pic = sum; if substr (int_pic, 3, 1) ^= " " then substr (int_pic, 4, 1) = ":"; /* HHH:MM0SS */ if substr (int_pic, 6, 1) ^= " " then substr (int_pic, 7, 1) = ":"; /* HHH:MM:SS */ rs = ltrim (int_pic); end; return (rs); end ti; /* ******************** */ test: entry (testdir); dcl testdir char (*); sysdir = testdir; /* the arg better be there, or we'll take a fault */ if real_asmtp ^= null then /* be sure to initiate new segs */ call hcs_$terminate_noname (real_asmtp, ignore_code); do i = 1 to 2; if temp_ptr (i) ^= null then call release_temp_segment_ (me, temp_ptr (i), ignore_code); end; reset = ""b; /* in case there was a reset in effect */ return; %include as_meter_numbers; %include as_meter_table; end as_meters;  as_who.pl1 10/16/92 1251.6r w 10/16/92 1249.0 353862 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ /* AS_WHO - print information about who's on Multics. This is a privileged version for use by the Answering Service. This entry point also works as an active function, which returns Person_id.Project_id of processes which would have been printed. AS_WHO$LONG - same thing, but more information. AS_WHO$HMU - give header lines with nusers and load. This command types out the userid's of listed logged-in users from the segment "answer_table", which is maintained by the answering service program "lg_ctl_". The possible arguments are as follows: . -lg print "long who" . -nhe omit headers . -as print information on absentee users . -dmn print information on daemon users . -sc print information on secondary users . -cpu print information about cpu usage . -idle print information about idle time . -connected . print information about connected processes . -disc print information about disconnected processes . -process_id, -pid . print out the process id for each process listed . -pdir_volume {LVname} . -pdv {LVname} . print pdir volumes, or print only users with pdir volume = LVname . -channel channel_id_starname . -chn channel_id_starname . print information on users using named channels . -gp xx print information on group xx . -nm sort lines on user name . -pj sort lines on project id . (the default sort is by time logged in) . -ia print information on interactive users . Name list only users with person name "Name" . .Proj list only users with project name "Proj" . Name.Proj list only users with person name "Name" and project "Proj" END DESCRIPTION */ /****^ HISTORY COMMENTS: 1) change(70-09-06,VanVleck), approve(), audit(), install(): Initial coding. 2) change(71-07-01,EDS), approve(), audit(), install(): for absentees. 3) change(76-07-01,Wells), approve(), audit(), install(): to understand about FTP channels. 4) change(77-08-01,Casey), approve(), audit(), install(): to optionally print the pdir volume of each user. 5) change(78-09-01,Johnson), approve(), audit(), install(): for long tty channel names (ring0 demultiplexing). 6) change(78-12-01,Casey), approve(), audit(), install(): to know about the foreground absentee queue. 7) change(79-03-21,GDixon), approve(), audit(), install(): to add -channel, -no_header and [as_who]. 8) change(79-04-01,Casey), approve(), audit(), install(): for MR7.0a to print foreground and background absentee users separately in heading. 9) change(79-12-01,Hornig), approve(), audit(), install(): for process preservation and max_users. 10) change(80-09-06,VanVleck), approve(), audit(), install(): for CPU and Idle. 11) change(80-12-01,Kittlitz), approve(), audit(), install(): for hmu ignore most control args. 12) change(81-07-07,Herbst), approve(), audit(), install(): to allow starnames and not implicitly assume Name -> Name*. 13) change(81-07-07,Herbst), approve(), audit(), install(): as_who$hmu fixed not to list names with -ia. 14) change(81-11-01,Kittlitz), approve(), audit(), install(): user_table_entry conversion. 15) change(81-12-01,Kittlitz), approve(), audit(), install(): whotab changes. 16) change(84-11-01,Pandolf), approve(), audit(), install(): to include hc_lock. 17) change(85-12-12,Newcomb), approve(85-12-12,MCR7263), audit(86-01-09,Margolin), install(86-01-28,MR12.0-1008): added the -connected ctl arg; made some minor corrections to declarations and argument processing/AF usage; changed to use ssu_ standalone invocation; fixed some unreported bugs. 18) change(86-03-18,MSharpe), approve(86-04-28,MCR7405), audit(86-07-01,EJSharpe), install(86-08-18,MR12.0-1130): Added -process_id (-pid) control arg, Removed undocumented -net control arg. 19) change(86-07-10,Hartogs), approve(86-07-10,MCR7451), audit(86-08-14,GWMay), install(86-08-18,MR12.0-1130): Fix bugs in as_who. Correct so that idle and cpu times include number of hours. Access ring0_peek only when necessary, thereby allowing use by users with access to some system tables. 20) change(86-08-22,Hartogs), approve(86-08-22,PBF7451), audit(86-08-22,Lippard), install(86-08-22,MR12.0-1139): Fixed to work with .project_id. 21) change(87-04-26,GDixon), approve(87-05-01,MCR7741), audit(87-05-06,Parisek), install(87-08-03,MR12.1-1055): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 22) change(87-08-11,Hartogs), approve(87-08-11,MCR7714), audit(87-08-11,Lippard), install(87-08-13,MR12.1-1085): Fixed to work correctly on successive invocation with -idle and -cpu. 23) change(91-03-21,Vu), approve(91-03-21,MCR8244), audit(91-12-05,Zimmerman), install(91-12-06,MR12.5-1002): as_who incorrectly interprets preemption. 24) change(92-10-02,Zimmerman), approve(92-10-02,MCR8269), audit(92-10-05,WAAnderson), install(92-10-16,MR12.5-1026): Lack of access to copy info from tc_data is now reported on each invocation, rather than once per process. END HISTORY COMMENTS */ %page; as_who: procedure options (variable, separate_static); /* START OF DECLARATIONS */ /* Automatic */ dcl argno fixed bin init (0), /* number of argument */ arg_count fixed bin init (0), retp ptr init (null ()), /* ptr to af return arg. */ ap ptr init (null ()), /* ptr to argument */ (pp1, pp2) ptr init (null ()), /* temporaries */ al fixed bin (21) init (0), /* lth of argument */ code fixed bin (35) init (0), /* file-system error code */ (f1, f2) float bin init (0), /* conversion temps */ retl fixed bin (21) init (0), /* max length of af return arg. */ sort fixed bin init (SORT_BY_DATE), /* type of sort */ no_usage bit (1) init (FALSE), /* 1 if can't get CPU usage */ have_read_apt bit (1) init (FALSE), long bit (1) aligned init (FALSE), /* 1 if long who wanted */ abs bit (1) aligned init (FALSE), /* 1 if only information on absentee users */ afsw bit (1) aligned init (FALSE), /* 1 if as_who entry invoked as active fnc */ dmn bit (1) aligned init (FALSE), /* 1 if only info on daemon users */ iasw bit (1) aligned init (FALSE), /* 1 if interactives. */ connected_sw bit (1) aligned init (FALSE), /* 1 if only connected */ disc_sw bit (1) aligned init (FALSE), /* 1 if only disconnected */ chnsw bit (1) aligned init (FALSE), /* 1 if only users of given channels selected. */ nhesw bit (1) aligned init (FALSE), /* 1 if headings should not be printed. */ no_ulist bit (1) aligned init (FALSE), /* 1 if only header ("hmu" cmd) */ pid_sw bit (1) aligned init (FALSE), /* 1 if displaying pid */ sbsw bit (1) aligned init (FALSE), /* 1 if only secondarys */ selgp char (8) aligned init (""), /* Selects group */ selx fixed bin init (0), /* if particular users wanted */ sel_starsw bit (1) init (FALSE), /* ON if asking for a set of users */ dotl fixed bin init (0), /* location of dot in arg */ channel_name char (32), chnnm char (32) init ("**"), /* channels tag used to select users. */ sel_names (100) char (32), (i, j) fixed bin init (0), /* index */ ary (256) fixed bin, /* sort array */ d fixed bin init (0), /* distance between sorted elems */ last fixed bin init (0), /* highest index in whotab */ swap fixed bin init (0), /* 1 if a swap was done */ ajd fixed bin init (0), /* temp for sort, ary(j+d) */ (time, time1) char (16) init (""), /* ASCII time */ why char (124) init (""), /* reason for shutdown */ clock_time fixed bin (71) init (0), (prim, nolist, anon) char (1) init (""), /* pretty print temps */ grp char (8) init (""), /* ... */ absdn char (168) init (""), /* ... */ absen char (32) init (""), /* ... */ aj fixed bin init (0), /* temp, ary(j) */ did fixed bin init (0), /* count of lines printed */ abs_name char (6) init (""), /* temp for absentee equiv of tty name */ select_sw fixed bin init (0), /* switch to indicate whether user is selected */ pers char (28) init (""), /* temp for name */ proj char (28) init (""), /* temp for project */ process_id bit (36), /* temp for 1st half of pid */ absentee_users fixed bin init (0), /* temp for max number of absentee users */ abs_running fixed bin init (0), /* Shows any residual users */ foreground_users fixed bin init (0), /* temp for number of foreground absentee users */ fancy char (1), /* used to eliminate certain new line chars on hmu */ k fixed bin init (0); /* index */ dcl max_chan_name fixed bin init (6); /* max length of name of a tty channel */ dcl pdvsw bit (1) init (FALSE); dcl pdlvix fixed bin init (0); dcl lvnm char (32) init (""); dcl proc_usage char (10) init (""); dcl proc_idle char (10) init (""); dcl (cpusw, idlesw) bit (1) init (FALSE); dcl sci_ptr ptr init (null ()); /* Based */ dcl arg char (al) unaligned based (ap), /* pickup for args */ ret char (retl) varying based (retp); /* af return argument. */ /* Constant */ dcl ( FALSE bit (1) init ("0"b), MY_NAME char (6) init ("as_who"), MY_NAME_HMU char (21) init ("as_who$how_many_users"), MY_NAME_LONG char (11) init ("as_who$long"), NL char (1) init (" "), SORT_BY_DATE fixed bin init (0), SORT_BY_NAME fixed bin init (1), SORT_BY_PROJECT fixed bin init (2), TEN_UNITS fixed bin init (10.0e0), /* Ten units are stored for each normal user */ TRUE bit (1) init ("1"b) ) int static options (constant); /* Internal Static */ dcl ( ip ptr init (null), /* ptr to installation_parms */ initializer_process bit (1) init ("0"b /* FALSE */), static_ansp ptr init (null), /* ptr to answer table */ static_autp ptr init (null), /* ptr to absentee user table, used to decide when to */ /* re-init various pointers to tables */ static_dtp ptr init (null), static_dutp ptr init (null), /* ptr to daemon user table */ sysdir char (64) init (""), /* must be set first time through */ tcml fixed bin (19) init (0), tcmp0 ptr init (null ()), whoptr ptr init (null) /* ptr to system "whotab" */ ) int static; /* Error codes */ dcl (error_table_$badopt, error_table_$logical_volume_not_defined, error_table_$noarg, error_table_$too_many_args ) fixed bin (35) ext static; /* Entry */ dcl check_star_name_$entry entry (char(*), fixed bin(35)); dcl match_star_name_ entry (char(*), char(*), fixed bin(35)); dcl disk_table_$get_dtp entry (ptr); dcl mdc_$read_disk_table entry (ptr, fixed bin (35)); dcl get_process_id_ entry returns (bit (36)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl (ioa_, ioa_$nnl) entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin (19), fixed bin (35)); dcl ring_zero_peek_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl ssu_$abort_line entry () options (variable); dcl ssu_$arg_count entry (ptr, fixed bin); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$get_temp_segment entry (ptr, char (*), ptr); dcl ssu_$return_arg entry (ptr, fixed bin, bit (1) aligned, ptr, fixed bin (21)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); /* External static */ dcl sys_info$system_control_dir char (168) varying aligned external static; /* Builtin */ dcl (addr, addrel, clock, divide, fixed, hbound, index, length, max, null, rtrim, search, substr) builtin; /* Condition */ dcl cleanup condition; %page; /* as_who: */ /* procedure options (variable, separate_static); */ on cleanup call clean_up (); call ssu_$standalone_invocation (sci_ptr, MY_NAME, "", null (), ABORT_ENTRY, code); if code ^= 0 then go to exit_no_cleanup; call ssu_$return_arg (sci_ptr, arg_count, afsw, retp, retl); if afsw then do; ret = ""; nhesw = TRUE; end; arglp: if arg_count ^= 0 then READ_ARGS: do argno = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, argno, ap, al); /* get nth argument */ if arg = "-nm" | arg = "-name" then sort = SORT_BY_NAME; else if arg = "-pj" | arg = "-project" then sort = SORT_BY_PROJECT; else if arg = "-lg" | arg = "-long" then long = TRUE; /* long who? */ else if arg = "-nhe" | arg = "-no_header" then nhesw = TRUE; /* omit headers ? */ else if arg = "-as" | arg = "-absentee" then abs = TRUE; /* absentee users? */ else if arg = "-dmn" | arg = "-daemon" then dmn = TRUE; /* Daemons? */ else if arg = "-ia" | arg = "-interactive" then iasw = TRUE; else if arg = "-connected" then connected_sw = TRUE; else if arg = "-disconnected" | arg = "-disc" then disc_sw = TRUE; /* disconnected processes */ else if arg = "-process_id" | arg = "-pid" then pid_sw = TRUE; /* display the process_id */ else if arg = "-gp" | arg = "-group" then do; if argno = arg_count then BAD_GROUP: call ssu_$abort_line (sci_ptr, error_table_$noarg, "-group requires a load control group name."); argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap, al); if index (arg, "-") = 1 then go to BAD_GROUP; selgp = arg; end; else if arg = "-sc" | arg = "-secondary" then sbsw = TRUE; /* Secondary users? */ else if arg = "-pdir_volume" | arg = "-pdv" then PROCESS_PDIR_VOL_ARG: do; /* optionally followed by LVname */ if argno = arg_count then pdvsw = TRUE; /* no lvname */ else do; /* see if next arg is lvname or ctl arg */ call ssu_$arg_ptr (sci_ptr, argno + 1, ap, al); if index (arg, "-") = 1 then pdvsw = TRUE; /* ctl arg ==> no LV name */ else do; lvnm = arg; /* remember the name, for later lookup in disk_table */ pdvsw = FALSE; /* don't print each users pdlvname - they will all be the same */ argno = argno + 1; /* increment so we don't re-process LVname */ end; end; end PROCESS_PDIR_VOL_ARG; else if arg = "-cpu" then cpusw = TRUE; else if arg = "-idle" then idlesw = TRUE; else if arg = "-chn" | arg = "-channel" then do; chnsw = TRUE; if argno = arg_count then bad_chn: call ssu_$abort_line (sci_ptr, error_table_$noarg, "-channel requires a channel id argument."); argno = argno + 1; call ssu_$arg_ptr (sci_ptr, argno, ap, al); if index (arg, "-") = 1 then go to bad_chn; chnnm = arg; call check_star_name_$entry (chnnm, code); if code < 0 | code > 2 then call ssu_$abort_line (sci_ptr, code, "Invalid channel id ^a.", arg); end; else if index (arg, "-") = 1 then call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); else do; /* n.o.t.a., must be user-selection */ selx = selx + 1; /* up index in select array */ if selx > hbound (sel_names, 1) then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "Too many selection parameters given, maximum is ^d.", hbound (sel_names, 1)); if search (arg, "*?") ^= 0 then sel_starsw = TRUE; /* stars specified at all */ dotl = index (arg, "."); /* where's the dot? */ if dotl = 0 then sel_names (selx) = arg || ".*"; /* Person_starname -> Person_starname.* */ else if dotl = 1 then do; sel_starsw = TRUE; /* asking for a set of users */ sel_names (selx) = "*" || arg; /* Proj_starname -> *.Proj_starname */ end; else sel_names (selx) = arg; end; end READ_ARGS; go: if static_autp = null then do; /* is this the first call? */ if sysdir = "" then sysdir = sys_info$system_control_dir; call initiate_file_ (sysdir, "installation_parms", R_ACCESS, ip, (0) /* ignore bit count */, code); if ip = null then call ssu_$abort_line (sci_ptr, code, "installation_parms"); call initiate_file_ (sysdir, "daemon_user_table", R_ACCESS, static_dutp, (0) /* ignore bit count */, code); if static_dutp = null then call ssu_$abort_line (sci_ptr, code, "daemon_user_table"); call initiate_file_ (sysdir, "whotab", R_ACCESS, whoptr, (0) /* ignore bit count */, code); if whoptr = null then call ssu_$abort_line (sci_ptr, code, "whotab"); call initiate_file_ (sysdir, "answer_table", R_ACCESS, static_ansp, (0) /* ignore bit count */, code); if static_ansp = null then call ssu_$abort_line (sci_ptr, code, "answer_table"); if static_ansp->anstbl.as_procid = get_process_id_ () then /* if we are the initializer process */ initializer_process = TRUE; /* remember that because we have a disk table copy */ else initializer_process = FALSE; /* we don't, so we have to make one */ /* set autp so we don't re-initialize every invocation */ call initiate_file_ (sysdir, "absentee_user_table", R_ACCESS, static_autp, (0) /* ignore bit count */, code); if static_autp = null then call ssu_$abort_line (sci_ptr, code, "absentee_user_table"); end; if (cpusw | idlesw) & tcmp0 = null then do; call ring0_get_$segptr ("", "tc_data", tcmp0, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "tc_data"); call ring_zero_peek_$get_max_length_ptr (tcmp0, tcml, code); if code ^= 0 then do; tcmp0 = null; call ssu_$abort_line (sci_ptr, code, "tc_data"); end; end; ansp = static_ansp; autp = static_autp; dutp = static_dutp; if connected_sw & disc_sw then do; iasw = TRUE; /* conn & disc users = interactive */ connected_sw, disc_sw = FALSE; end; if pdvsw | lvnm ^= "" then do; /* if we need disk_table */ if static_dtp = null then do; /* if we don't have it, get it */ if initializer_process then /* if this is the initializer process, we always have a copy */ call disk_table_$get_dtp (static_dtp); /* of disk_table in ring 4, so get ptr to that */ else /* otherwise we have to make a copy and update it each time */ call ssu_$get_temp_segment (sci_ptr, "disk_table", static_dtp); end; if ^initializer_process then do; /* update as_who_disk_table */ call mdc_$read_disk_table (static_dtp, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "error from mdc_$read_disk_table"); end; dtp = static_dtp; if lvnm ^= "" then do; /* if -pdv LVname given, look up LVname in disk_table */ do i = 1 to dt.n_lv_entries while (dt.lv_array (i).lvname ^= lvnm); end; if i > dt.n_lv_entries then call ssu_$abort_line (sci_ptr, error_table_$logical_volume_not_defined, "^a", lvnm); pdlvix = i; /* remember disk table index of the specified vol */ end; end; max_chan_name = 6; /* compute length of longest channel name */ do j = 1 to anstbl.current_size; utep = addr (anstbl.entry (j)); if ute.active >= NOW_LOGGED_IN then max_chan_name = max (max_chan_name, length (rtrim (ute.tty_name))); end; if nhesw then go to no_header; if no_ulist then fancy = " "; /* reduce number of new lines between totals */ else fancy = NL; clock_time = clock (); absentee_users = autbl.max_abs_users; abs_running = absentee_users + autbl.n_abs_run; foreground_users = autbl.n_abs_run - autbl.n_background_abs; if ^sbsw & ^chnsw & selgp = "" & pdlvix = 0 & selx = 0 then do; /* print header if no users selected */ if dmn then do; call ioa_ ("^d daemons.", whotab.n_daemons); if no_ulist then go to pnl; end; if (connected_sw | disc_sw | iasw | chnsw) then do; if no_ulist then do; f1 = anstbl.n_units / TEN_UNITS; f2 = anstbl.max_units / TEN_UNITS; go to print_ia_hdr; end; call ioa_ (""); if long then go to prt_user_header; else go to ias; end; if abs then do; if long then do; call ioa_ ("Absentee users = ^d background^[,^x^d foreground^;^s^]; Max background absentee users = ^d^a", autbl.n_background_abs, (foreground_users ^= 0), foreground_users, absentee_users, fancy); go to prt_user_header; /* Print listing header */ end; call ioa_ (""); /* Print blank line first */ go to print_abs_hdr; /* print short absentee header only */ end; if dmn then do; call ioa_ (""); if long then go to prt_user_header; else go to daemons; end; f1 = anstbl.n_units / TEN_UNITS; /* format up units */ f2 = anstbl.max_units / TEN_UNITS; /* ... */ if long then do; /* long who? */ call date_time_ (whotab.timeup, time); /* yup. make heading */ call ioa_ ("^/Multics ^a; ^a", whotab.sysid, installation_parms.installation_id); call ioa_ ("Load = ^.1f of ^.1f units; users = ^d of ^d", f1, f2, anstbl.n_users, anstbl.max_users); if abs_running > 0 then call ioa_ ("Absentee users = ^d background^[,^x^d foreground^;^s^]; Max background absentee users = ^d", autbl.n_background_abs, (foreground_users ^= 0), foreground_users, absentee_users); call ioa_ ("Daemon users = ^d", whotab.n_daemons); call ioa_ ("System up since ^a", time); if whotab.nextsd ^= 0 then do; why = whotab.why; if why < "" then why = ""; call date_time_ (whotab.nextsd, time); if whotab.until = 0 then call ioa_ ("Scheduled shutdown at ^a ^a", time, why); else do; call date_time_ (whotab.until, time1); call ioa_ ("Scheduled shutdown from ^a to ^a ^a", time, time1, why); end; end; call date_time_ (whotab.lastsd, time); if whotab.erfno = "crash" then call ioa_ ("Last crash was at ^a^a", time, fancy); else if whotab.lastsd = 0 then call ioa_ ("^a", fancy); else if whotab.erfno = "" then call ioa_ ("Last shutdown was at ^a^a", time, fancy); else call ioa_ ("Last crash (ERF# ^a) was at ^a^a", whotab.erfno, time, fancy); prt_user_header: if no_ulist then go to pnl; call ioa_ ("^4xLogin at^6xTTY Load^3xChan^vxGroup^3x^[^3xCPU^3x ^]^[^3xIdle^2x ^]^[ Process ID ^] PNDS User ID^[^2x(pdir_volume)^]^/", max_chan_name - length (" "), cpusw, idlesw, pid_sw, pdvsw); end; else do; /* short who. */ print_ia_hdr: call ioa_ ("^/Multics ^a, load ^.1f/^.1f; ^d/^d users, ^d daemons.", whotab.sysid, f1, f2, anstbl.n_users, anstbl.max_users, whotab.n_daemons); if abs_running > 0 & (^no_ulist | abs | (^iasw & ^dmn)) then /* ! */ print_abs_hdr: call ioa_ ("Absentee users ^d/^d^[^x(+^d FG)^]", autbl.n_background_abs, absentee_users, (foreground_users ^= 0), foreground_users); call ioa_$nnl ("^a", fancy); /* Could have put in a conditional */ end; end; no_header: if no_ulist then go to pnl; /* if "hmu" command */ if (connected_sw | disc_sw | iasw) then go to ias; if abs then go to abs_portion; /* if "as_who -as" command */ if dmn then go to daemons; ias: last = anstbl.current_size; /* save high limit on who */ do j = 1 to last; /* set up sort array */ ary (j) = j; /* ... */ end; d = last; /* set up for Shell sort */ pass: d = divide (d + 1, 2, 17, 0); /* ... */ swap = 0; /* ... */ do j = 1 to last - d; /* comparison loop */ aj = ary (j); /* make temps */ ajd = ary (j + d); /* ... */ pp1 = addr (anstbl.entry (aj)); pp2 = addr (anstbl.entry (ajd)); if sort = SORT_BY_DATE then if pp1 -> ute.login_time > pp2 -> ute.login_time then go to ic; if sort = SORT_BY_NAME then if pp1 -> ute.person > pp2 -> ute.person then go to ic; if sort = SORT_BY_PROJECT then if pp1 -> ute.project > pp2 -> ute.project then go to ic; else if pp1 -> ute.project = pp2 -> ute.project then if pp1 -> ute.person > pp2 -> ute.person then do; ic: ary (j) = ajd; /* No. Swap entries */ ary (j + d) = aj; /* ... */ swap = swap + 1; /* remember a swap */ end; end; if swap > 0 then go to pass; /* if out of order do it again */ if d > 1 then go to pass; /* ... */ do j = 1 to last; /* now the print loop */ utep = addr (anstbl.entry (ary (j))); /* set up ptr to user */ if ute.active < NOW_LOGGED_IN then go to skip; /* skip dead entries */ pers = ute.person; /* copy personal name */ proj = ute.project; /* copy project */ if pid_sw then process_id = ute.proc_id; /* copy process id */ if selgp ^= "" then if ute.group ^= selgp then go to skip; if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip; if sbsw then if ute.standby_line = 0 then go to skip; if connected_sw then if ute.uflags.disconnected then go to skip; if disc_sw then if ^ute.uflags.disconnected then goto skip; if chnsw then do; /* select users by channel id. */ call match_star_name_ (ute.tty_name, chnnm, code); if code ^= 0 then go to skip; end; if selx = 0 then go to print; /* any users selected? */ call select; /* check for selected users */ if select_sw = 0 then go to skip; /* user not in selected group */ print: did = did + 1; /* remember we did one */ if ute.anonymous = 0 then anon = " "; else anon = "*"; if ute.preempted ^= 0 then prim = "X"; else if ute.at.nobump then prim = "+"; /* Can be bumped by operator? */ else if ute.standby_line = 1 then prim = "S";/* Secondary? */ else if ute.cant_bump_until < clock_time then prim = ">"; else prim = " "; if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */ call get_usage (ute.proc_id, ute.cpu_usage); if afsw then do; ret = ret || rtrim (pers); ret = ret || "."; ret = ret || rtrim (proj); ret = ret || " "; end; else if long then do; /* long who? */ call date_time_ (ute.login_time, time); /* yup. */ if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" "; else time1 = time; f1 = ute.user_weight / TEN_UNITS; /* get nice units */ if ute.at.nolist then nolist = "N"; else nolist = " "; grp = ute.group; /* Get group */ if grp = "Other" then grp = ""; /**** Avoid operator mistakes by not displaying channel name when the user is disconnected. This channel name is not terribly useful anyway in this case, and prevents attempting to bump disconnected users by channel name (which may result in bumping the user currently on that channel). */ if ute.uflags.disconnected then channel_name = ""; else channel_name = ute.tty_name; call ioa_ ("^16a ^4a ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^] ^[^12.3b ^;^s^]^1a^1a^[D^; ^]^[S^; ^] ^1a^a.^a^[^2x(^a)^;^s^]", time, ute.tty_id_code, f1, max_chan_name, channel_name, grp, cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, prim, nolist, ute.uflags.disconnected, ute.uflags.suspended, anon, pers, proj, pdvsw, lvnm); end; else do; /* short who. */ call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b ^;^s^]^a^a.^a ^a^[^2x(^a)^;^s^]", cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, anon, pers, proj, prim, pdvsw, lvnm); end; skip: end; if (connected_sw | disc_sw | iasw) then if ^abs then if ^dmn then go to done; else go to daemons; abs_portion: if autbl.n_abs_run <= 0 then go to daemons; do j = 1 to autbl.current_size; /* run through table */ utep = addr (autbl.entry (j)); /* get address of abs user entry */ if ute.active = 0 then go to skip1; /* only look at used entries */ pers = ute.person; /* copy personal name */ proj = ute.project; /* copy project name */ if pid_sw then process_id = ute.proc_id; /* copy process id */ if selgp ^= "" then if ute.group ^= selgp then go to skip1; if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip1; if sbsw then go to skip1; call ioa_$rsnnl ("abs^d", abs_name, k, j); if chnsw then do; /* select absentee users by abs_name. */ call match_star_name_ (abs_name, chnnm, code); if code ^= 0 then go to skip1; end; if selx = 0 then go to print1; /* are any users selected */ call select; /* check for selected users */ if select_sw = 0 then go to skip1; /* user not in selected group */ print1: did = did + 1; /* increment count of printed persons */ if ute.anonymous = 0 then anon = " "; else anon = "*"; call expand_pathname_ ((ute.input_seg), absdn, absen, code); k = index (absen, ".absin"); if k > 0 then substr (absen, k) = ""; if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */ call get_usage (ute.proc_id, ute.cpu_usage); if afsw then do; ret = ret || rtrim (pers); ret = ret || "."; ret = ret || rtrim (proj); ret = ret || " "; end; else if long then do; call date_time_ (ute.login_time, time); if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" "; else time1 = time; f1 = ute.user_weight / TEN_UNITS; grp = ute.group; if grp = "Other" then grp = ""; call ioa_ ("^16a Q ^[FG^s^;^d^x^] ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^]^[ ^12.3b^;^s^] A ^[S^; ^] ^1a^a.^a (^a)^[^2x(^a)^;^s^]", time, (ute.queue = 0), ute.queue, f1, max_chan_name, abs_name, grp, cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, ute.uflags.suspended, anon, pers, proj, absen, pdvsw, lvnm); end; else call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b ^;^s^]^a^a.^a (^a)^[^2x(^a)^;^s^]", cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, anon, pers, proj, absen, pdvsw, lvnm); skip1: end; daemons: if abs then if ^dmn then go to done; do j = 1 to dutbl.current_size; /* print out daemons */ utep = addr (dutbl.entry (j)); if ute.active ^= NOW_HAS_PROCESS then go to skip2; /* skip if not in */ pers = ute.person; proj = ute.project; if pid_sw then process_id = ute.proc_id; if selgp ^= "" then if ute.group ^= selgp then go to skip2; if pdlvix > 0 & ute.pdir_lvix ^= pdlvix then goto skip2; if sbsw then go to skip2; if chnsw then do; /* select daemons by tty_name */ call match_star_name_ (ute.tty_name, chnnm, code); if code ^= 0 then go to skip2; end; if selx = 0 then go to print2; call select; if select_sw = 0 then go to skip2; print2: did = did + 1; if pdvsw then call get_lvnm ((ute.pdir_lvix)); /* sets lvnm */ call get_usage (ute.proc_id, ute.cpu_usage); if afsw then do; ret = ret || rtrim (pers); ret = ret || "."; ret = ret || rtrim (proj); ret = ret || " "; end; else if long then do; call date_time_ (ute.login_time, time); if substr (time, 1, length ("mm/dd/yy")) = substr (time1, 1, length ("mm/dd/yy")) then substr (time, 1, length ("mm/dd/yy")) = (8)" "; else time1 = time; f1 = ute.user_weight / 1e1; if ute.at.nolist then nolist = "N"; else nolist = " "; grp = ute.group; if grp = "Other" then grp = ""; /**** Avoid operator mistakes by not displaying channel name when the user is disconnected. This channel name is not terribly useful anyway in this case, and prevents attempting to bump disconnected users by channel name (which may result in bumping the user currently on that channel). */ if ute.uflags.disconnected then channel_name = ""; else channel_name = ute.tty_name; call ioa_ ("^16a ^4a ^4.1f^3x^va ^8a^[^11a ^;^s^]^[^11a^;^s^]^[^12.3b^;^s^] D^1a ^a.^a^[^2x(^a)^;^s^]", time, ute.tty_id_code, f1, max_chan_name, channel_name, grp, cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, nolist, pers, proj, pdvsw, lvnm); end; else do; /* short */ call ioa_ ("^[^11a ^;^s^]^[^11a ^;^s^]^[^12.3b ^;^s^]^a.^a D^[^2x(^a)^;^s^]", cpusw, proc_usage, idlesw, proc_idle, pid_sw, process_id, pers, proj, pdvsw, lvnm); end; skip2: end; done: if afsw then do; if length (ret) > 0 then /* remove trailing blank from list of pers.proj ids */ ret = substr (ret, 1, length (ret) - 1); end; else if selx ^= 0 then /* If user names specified */ if did = 0 then do; /* if printed nobody */ if pdlvix = 0 then /* if users were not eliminated because of -pdv LVname */ call ioa_ ("User^[s^] not logged in.", selx > 1 | sel_starsw); end; else /* ! */ pnl: call ioa_ (""); /* extra CR */ else if did ^= 0 /* were any printed? */ then go to pnl; if pdlvix ^= 0 & did = 0 then call ioa_ ("No^[ne of the specified^] users have process directories on volume ""^a""", ((selgp ^= "") | sbsw | selx ^= 0 | connected_sw | disc_sw | iasw | abs | dmn), lvnm); exit: call clean_up; /* releases temp segs etc. */ exit_no_cleanup: return; /* done. */ /* end as_who; */ %page; clean_up: proc; /* reset a pointer and get rid of the ssu invocation, and thus */ /* any temporary storage acquired. */ if ^initializer_process then static_dtp = null; /* destroy will release temp seg, if acquired */ if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); end clean_up; %skip (6); as_who$long: entry; on cleanup call clean_up (); call ssu_$standalone_invocation (sci_ptr, MY_NAME_LONG, "", null (), ABORT_ENTRY, code); if code ^= 0 then go to exit_no_cleanup; call ssu_$arg_count (sci_ptr, arg_count); /* not allowed to be an AF */ long = TRUE; /* set switch and join up */ go to arglp; %skip (6); as_who$how_many_users: as_who$hmu: entry (); call ssu_$standalone_invocation (sci_ptr, MY_NAME_HMU, "", null (), ABORT_ENTRY, code); if code ^= 0 then go to exit_no_cleanup; call ssu_$arg_count (sci_ptr, arg_count); /* not allowed to be an AF */ if arg_count > 0 /* no args allowed */ then call ssu_$abort_line (sci_ptr, error_table_$too_many_args, "No arguments allowed, ^d given.", arg_count); no_ulist = TRUE; /* do just a header */ go to go; %page; as_who$as_who_init: entry (sysdirname); dcl sysdirname char (*) parameter; sysdir = sysdirname; static_ansp, static_autp, static_dutp = null; return; %skip (6); ABORT_ENTRY: procedure (); go to exit; end ABORT_ENTRY; %skip (6); select: proc; /* internal procedure to see if user is selected by name */ dcl group_id char (32); dcl code fixed bin (35); select_sw = 1; /* assume that user is part of selected group */ group_id = rtrim (pers) || "." || proj; do k = 1 to selx; /* search all classes of selection */ call match_star_name_ (group_id, sel_names (k), code); if code = 0 then return; end; select_sw = 0; /* user is not part of selected group */ return; end select; %skip (6); get_lvnm: proc (lvix); dcl lvix fixed bin; if lvix > 0 & lvix <= dt.n_lv_entries then lvnm = dt.lv_array (lvix).lvname; else lvnm = "?"; return; end get_lvnm; %page; get_usage: proc (x, y); dcl x bit (36) aligned; dcl y fixed bin (71); dcl i fixed bin, code fixed bin (35); dcl white_len fixed bin; dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl find_char_$last_in_list entry (char (*), char (*)) returns (fixed bin (21)); if no_usage then do; abort: proc_usage = ""; proc_idle = ""; return; end; /* Grab metering data we need. */ if ^have_read_apt then do; call ssu_$get_temp_segment (sci_ptr, "apt", tcmp); call ring_zero_peek_ (tcmp0, tcmp, tcml, code); if code ^= 0 then do; no_usage = TRUE; go to abort; end; have_read_apt = TRUE; end; aptep = addrel (tcmp, tcm.apt_offset); do i = 0 to tcm.apt_size - 1; if apte.processid = x then go to found; aptep = addrel (aptep, tcm.apt_entry_size); end; go to abort; found: proc_usage = date_time_$format ("^ZZHd:^ZZMH:^99.(6)9UM", apte.virtual_cpu_time+ y, "gmt", ""); if substr (proc_usage, 1, length ("::")) = "::" then substr (proc_usage, 1, length (" ")) = " "; if substr (proc_usage, 1, length (":")) = ":" then substr (proc_usage, 1, length (" ")) = " "; proc_usage = substr (proc_usage, 1, find_char_$last_in_list (proc_usage, ".") + 1); do white_len = 1 to 9 - find_char_$last_in_list (proc_usage, "."); proc_usage = " " || substr (proc_usage, 1, find_char_$last_in_list (proc_usage, ".") + 1); end; proc_idle = date_time_$format ("^ZZHd:^ZZMH:^99.(6)9UM", clock () - apte.state_change_time, "gmt", ""); if substr (proc_idle, 1, length ("::")) = "::" then substr (proc_idle, 1, length (" ")) = " "; if substr (proc_idle, 1, length (":")) = ":" then substr (proc_idle, 1, length (" ")) = " "; proc_idle = substr (proc_idle, 1, find_char_$last_in_list (proc_idle, ".") + 1); do white_len = 1 to 9 - find_char_$last_in_list (proc_idle, "."); proc_idle = " " || substr (proc_idle, 1, find_char_$last_in_list (proc_idle, ".") + 1); end; if fixed (apte.state, 18) = 2 then proc_idle = (9)" " || "R"; else if fixed (apte.state, 18) = 3 then proc_idle = (9)" " || "W"; else if fixed (apte.state, 18) = 1 then proc_idle = (9)" " || "X"; return; end get_usage; %page; %include absentee_user_table; %page; %include access_mode_values; %page; %include answer_table; %page; %include apte; %page; %include daemon_user_table; %page; %include dialup_values; %page; %include disk_table; %page; %include hc_lock; %page; %include installation_parms; %page; %include tcm; %page; %include user_attributes; %page; %include user_table_entry; %page; %include user_table_header; %page; %include whotab; end as_who;  call_finder.pl1 10/27/83 1614.3r 10/27/83 1441.5 99189 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ call_finder: proc; /* Finds all calls to entries with a given segment name Written by: Richard A. Barnes 24 January 1974 */ /* Modified on 4 June 1975 by J. C. Whitmore to attempt use of system privilege initiate */ /* Modified 11/10/82 by R. Holmstedt to use the new object_info include file */ /* Changed to use interpret_link_info.incl.pl1 05/12/83 S. Herbst */ dcl (alen, i, nargs, nentry, ncompilers, total) fixed bin; dcl (aptr, sptr) ptr; dcl (all, added_access) bit (1) aligned; dcl root char (168) aligned init (">"); dcl dir char (168); /* full directory name */ dcl ename char (32); /* entry name */ dcl target char (32) aligned; dcl 1 entry (256), 2 name char (65), 2 refs fixed bin; dcl 1 compiler_table (32), 2 cname char (8), 2 segs fixed bin, 2 uses fixed bin; dcl arg char (alen) based (aptr); dcl have_priv bit (1) int static init ("1"b); /* assume we have privileges for now */ dcl code fixed bin (35); dcl me char (11) int static init ("call_finder"); dcl nl char (1) int static init (" "); dcl ftotal float bin; dcl total_object_segs fixed bin init (0); dcl total_segs_with_call fixed bin init (0); dcl 1 segment_acl aligned, 2 access_name char (32), 2 modes bit (36) init ("1"b), /* r */ 2 zero_pad bit (36) init ("0"b), 2 status_code fixed bin (35); dcl 1 delete_acl aligned, 2 access_name char (32), 2 status_code fixed bin (35); dcl error_table_$moderr fixed bin (35) ext; dcl cleanup condition; dcl (addr, addrel, divide, fixed, float, hbound, index, ltrim, null, rtrim, substr) builtin; dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl get_group_id_ entry () returns (char (32) aligned); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl system_privilege_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl interpret_link_ entry (ptr, ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ios_$write_ptr entry (ptr, fixed bin, fixed bin (7)); dcl object_info_$display entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl sweep_disk_ entry (char (168) aligned, entry); all = "0"b; nentry, ncompilers = 0; call cu_$arg_count (nargs); /* get name of target */ call cu_$arg_ptr (1, aptr, alen, code); if code ^= 0 then do; err: call com_err_ (code, me, "^/Usage: call_finder entry {-all, path}, ^/^-The root is default starting node for path."); return; end; if substr (arg, 1, 1) = "-" then goto err; target = arg; /* get other 2 args */ if nargs > 3 then goto err; do i = 2 to nargs; call cu_$arg_ptr (i, aptr, alen, code); if substr (arg, 1, 1) = "-" then do; if arg = "-all" | arg = "-a" then do; if all = "1"b then goto err; /* if all true then second time thru */ all = "1"b; end; else goto err; end; else do; call expand_path_ (aptr, alen, addr (root), null, code); if code ^= 0 then go to err; end; end; /* Now call the sweeper program */ segment_acl.access_name, delete_acl.access_name = get_group_id_ (); sptr = null; added_access = "0"b; on condition (cleanup) call clean_up; call sweep_disk_ (root, counter); /* now print out totals */ sum: total = 0; do i = 1 to nentry; total = total + refs (i); end; ftotal = total; call ioa_ ("^/^d total object segments searched^/^d segments call ^a with ^d calls^/", total_object_segs, total_segs_with_call, target, total); do i = 1 to nentry; call ioa_ ("^a^65t^4d^70t^7.2f%", name (i), refs (i), 100.0 * (float (refs (i))/ftotal)); end; call ioa_ (""); do i = 1 to ncompilers; call ioa_ ("^8a^8d^10d", compiler_table (i).cname, compiler_table (i).segs, compiler_table (i).uses); end; return; counter: proc (superior, parent, levels, pename, bptr, nptr); dcl superior char (168) aligned, /* superior directory path */ parent char (32) aligned, /* parent directory name */ levels fixed bin, /* distance from root */ pename char (32) aligned, /* entry name */ bptr ptr, /* ptr to branch structure */ nptr ptr; /* ptr to names area */ dcl (i, j, n) fixed bin; dcl (lptr, liptr) ptr; dcl reference char (68) varying aligned; dcl nbits fixed bin (24); dcl (first, firstlink) bit (1) aligned; dcl code fixed bin (35); dcl line char (80); dcl written fixed bin (7); dcl segment_type bit (2) int static init ("01"b); dcl 1 branch based aligned, 2 type bit (2) unal, 2 nnames bit (16) unal, 2 nindex bit (18) unal; dcl 1 link_header based aligned, 2 object_seg fixed bin, 2 def_section bit (18) unal, 2 first_reference bit (18) unal, 2 section_thread ptr, 2 linkage_ptr ptr, 2 begin_links bit (18) unal, 2 section_length bit (18) unal, 2 obj_seg bit (18) unal, 2 combined_length bit (18) unal; dcl 1 linkword based aligned, 2 pad bit (30) unal, 2 ft2 bit (6) unal; dcl 1 auto_interpret_link_info aligned like interpret_link_info; dcl (no_read_permission, not_in_read_bracket, seg_fault_error, program_interrupt, record_quota_overflow, linkage_error) condition; dcl length builtin; %include object_info; dcl 1 obj_info like object_info; %include interpret_link_info; %page; /* first, see if we could have an object segment */ obj_info.version_number = object_info_version_2; if bptr -> branch.type ^= segment_type then return; ename = pename; if index (ename, ".") ^= 0 then return; if substr (ename, 1, 1) = "!" then return; /* we might have one, so let's initiate it */ if superior ^= "" then dir = rtrim (superior) || ">" || parent; else dir = parent; on linkage_error begin; have_priv = "0"b; go to init_seg; end; init_seg: if have_priv then call system_privilege_$initiate_count (dir, ename, "", nbits, 1, sptr, code); else call hcs_$initiate_count (dir, ename, "", nbits, 1, sptr, code); revert linkage_error; /* we have the privilege we need */ if sptr = null then if code = error_table_$moderr then do; call hcs_$add_acl_entries (dir, ename, addr (segment_acl), 1, code); if code ^= 0 then return; added_access = "1"b; if have_priv then call system_privilege_$initiate_count (dir, ename, "", nbits, 1, sptr, code); else call hcs_$initiate_count (dir, ename, "", nbits, 1, sptr, code); if sptr = null then go to finish; end; else return; /* prepare for somebody's interfering with us */ on condition (cleanup) call clean_up; on condition (record_quota_overflow) go to finish; on condition (program_interrupt) go to finish; on condition (seg_fault_error) go to finish; on condition (no_read_permission) go to finish; on condition (not_in_read_bracket) go to finish; /* object_info_ will tell us about the object segment */ call object_info_$display (sptr, nbits, addr (obj_info), code); if code ^= 0 then go to finish; total_object_segs = total_object_segs + 1; /* record count of compiler names. */ do j = 1 to ncompilers while (compiler_table (j).cname ^= obj_info.compiler); end; if j <= ncompilers then compiler_table (j).segs = compiler_table (j).segs + 1; else if j <= hbound (compiler_table, 1) then do; ncompilers = j; compiler_table (j).cname = obj_info.compiler; compiler_table (j).segs = 1; compiler_table (j).uses = 0; end; else do; call com_err_ (0, me, "compiler table full"); call clean_up; go to sum; end; /* now, we have to look at the links */ first, firstlink = "1"b; lptr = addrel (obj_info.linkp, obj_info.linkp -> link_header.begin_links); n = divide (obj_info.llng - fixed (obj_info.linkp -> link_header.begin_links, 18), 2, 17, 0); do i = 1 to n; if lptr -> linkword.ft2 = "100110"b /* fault 2 tag */ then do; /* we have a link, see if it points at target seg */ auto_interpret_link_info.version = INTERPRET_LINK_INFO_VERSION_1; call interpret_link_ (addr (auto_interpret_link_info), lptr, code); if code ^= 0 then go to finish; if auto_interpret_link_info.segment_name = target then do; /* PAYDIRT! */ if firstlink then do; firstlink = "0"b; total_segs_with_call = total_segs_with_call + 1; compiler_table (j).uses = compiler_table (j).uses + 1; end; reference = rtrim (auto_interpret_link_info.segment_name) || rtrim (auto_interpret_link_info.entry_point_name) || " "; /* put entry into table */ do j = 1 to nentry while (entry (j).name ^= reference); end; if j <= nentry then entry (j).refs = entry (j).refs + 1; else if j <= hbound (entry, 1) then do; nentry = j; entry (j).name = reference; entry (j).refs = 1; end; else do; call com_err_ (0, me, "table_overflow"); call clean_up; go to sum; end; /* print out information */ if all then do; if first then do; call ioa_ ("^/>^a>^a (^a)", ltrim(dir,">"), ename, obj_info.compiler); first = "0"b; line = " "; written = 1; end; if length (reference) + written >= length (line) then call write; substr (line, written+1, length (reference)) = reference; written = written + length (reference); end; end; end; lptr = addrel (lptr, 2); end; /* write list line */ if ^ first then call write; /* CLEAN UP! */ clean_up: entry; finish: if sptr ^= null then do; call hcs_$terminate_noname (sptr, code); sptr = null; end; if added_access then do; call hcs_$delete_acl_entries (dir, ename, addr (delete_acl), 1, code); added_access = "0"b; end; return; write: proc; written = written + 1; substr (line, written, 1) = nl; call ios_$write_ptr (addr (line), 0, written); written = 1; end; end; end;  check_dir.pl1 10/27/83 1614.3rew 10/27/83 1441.5 51894 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ check_dir: proc; dcl (path, dn) char (168) aligned, (en, char32) char (32) aligned, myid char (32) aligned, line char (120) aligned, datstr char (16) aligned, (c1, char1) char (1) aligned, (i, j, k, l, m, n) fixed bin, (ii, jj) fixed bin, (pers, tpers (10)) char (32) aligned, (proj, tproj (10)) char (32) aligned, (tag, ttag (10)) char (4) aligned, nids fixed bin init (1), idx fixed bin init (2), fb71 fixed bin (71) init (0), bitc fixed bin (24), movelen fixed bin, areap ptr init (null), barea area ((512)) based (areap), (eptr, nptr) ptr init (null), ap ptr, al fixed bin, bchr char (al) unaligned based (ap), ec fixed bin (35), (p, q) ptr; dcl bcs char (131071) based (p) aligned; dcl NL char (1) aligned int static init (" "); dcl (addr, null, substr, index, unspec, length, bit, fixed, divide, mod, abs) builtin; dcl establish_cleanup_proc_ entry (entry), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), get_wdir_ entry () returns (char (168) aligned), get_system_free_area_ entry (ptr), get_group_id_$tag_star entry () returns (char (32) aligned), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), ioa_$nnl entry options (variable), ioa_$rs entry options (variable), date_time_ entry (fixed bin (71), char (*) aligned), com_err_ entry options (variable); dcl hcs_$star_list_ entry (char (*) aligned, char (*) aligned, fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)), hcs_$get_bc_author entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (35)); dcl hcs_$list_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)), hcs_$list_dir_acl entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)), hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$delete_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$delete_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)), hcs_$replace_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned, fixed bin (35)), hcs_$replace_dir_acl entry (char (*) aligned, char (*) aligned, ptr, fixed bin, bit (1) aligned, fixed bin (35)); dcl 1 btime based aligned, 2 xpad bit (20) unal, 2 xdtm bit (36) unal, 2 ypad bit (16) unal; dcl 1 br (n) based (eptr) aligned, 2 type bit (2) unal, 2 nnam bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtu bit (36) unal, 2 mode bit (5) unal, 2 pad bit (13) unal, 2 recs bit (18) unal; dcl names (100) char (32) aligned based (nptr); /* ------------------------------------------------------ */ call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then do; wd: dn = get_wdir_ (); go to join; end; else if bchr = "-wd" then go to wd; call expand_path_ (ap, al, addr (dn), null, ec); if ec ^= 0 then go to er; join: call get_system_free_area_ (areap); call establish_cleanup_proc_ (clean); myid = get_group_id_$tag_star (); idlp: tpers (nids), tproj (nids), ttag (nids) = "*"; i = index (myid, "."); if i = 0 then tpers (nids) = myid; else do; if i > 1 then tpers (nids) = substr (myid, 1, i-1); j = index (substr (myid, i+1), "."); if j = 0 then tproj (nids) = substr (myid, i+1); else do; tproj (nids) = substr (myid, i+1, j-1); ttag (nids) = substr (myid, i+j+1); end; end; call cu_$arg_ptr (idx, ap, al, ec); if ec = 0 then do; /* If given any ids, override */ nids = idx - 1; idx = idx + 1; myid = bchr; go to idlp; end; call hcs_$star_list_ (dn, "**", 2, areap, n, k, eptr, nptr, ec); if ec ^= 0 then do; er: call com_err_ (ec, "check_dir", dn); return; end; do i = 1 to n; if br (i).type = "10"b then go to skip; en = names (fixed (br (i).nindex, 18)); call hcs_$get_bc_author (dn, en, char32, ec); if ec ^= 0 then call com_err_ (ec, "check_dir", "^a>^a", dn, en); else do; ii = index (char32, "."); pers = substr (char32, 1, ii-1); jj = index (substr (char32, ii+1), "."); proj = substr (char32, ii+1, jj-1); tag = substr (char32, ii+jj+1); do m = 1 to nids; if tpers (m) = "*" then; else if tpers (m) ^= pers then go to fail; if tproj (m) = "*" then; else if tproj (m) ^= proj then go to fail; if ttag (m) = "*" then; else if ttag (m) ^= tag then go to fail; go to skip; /* all match. so not list */ fail: end; list: addr (fb71) -> xdtm = br (i).dtm; call date_time_ (fb71, datstr); call ioa_ ("^32a^8x^16a ^32a", en, datstr, char32); end; skip: end; call clean; return; clean: proc; if eptr ^= null then free eptr -> br in (barea); if nptr ^= null then free nptr -> names in (barea); end clean; end;  ckauth.pl1 10/27/83 1614.3rew 10/27/83 1441.5 42408 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ckauth: proc; /* CKAUTH - check for file authored by given user */ dcl path char (168) aligned, /* root of tree */ ctime char (24) aligned, (co, dp) char (64) aligned, /* titles for report */ (c1, char1) char (1) aligned, (i, j, k, l, m, n) fixed bin, (t1, t2) fixed bin, rolder (0: 90) fixed bin, folder (0: 90) fixed bin, movelen fixed bin, slp ptr, lth fixed bin (24), NL char (1) aligned, kk fixed bin, ap ptr, al fixed bin, bchr char (al) unaligned based (ap), ec fixed bin, total fixed bin int static, name char (32) aligned int static init ("Dumper.SysDaemon.a"), an fixed bin init (2), modsw bit (1) init ("1"b), (p, q, p1, q1, p2, q2) ptr; dcl clock_ ext entry returns (fixed bin (71)), com_err_ entry options (variable), ioa_$rsnnl entry options (variable), cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin), sweep_disk_ ext entry (char (168) aligned, entry), expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin), ioa_ entry options (variable), date_time_ entry (fixed bin (71), char (*) aligned), hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2), ptr, fixed bin), get_wdir_ entry returns (char (168) aligned), hcs_$get_author entry (char (*) aligned, char (*) aligned, fixed bin, char (*) aligned, fixed bin), hcs_$get_bc_author entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin), hcs_$acl_add1 entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), (3) fixed bin (3), fixed bin), hcs_$terminate_noname entry (ptr, fixed bin); dcl bcs char (262144) aligned based (slp); dcl (divide, substr, addr, null, index, fixed) builtin; dcl 1 movetable based aligned, 2 moveary (movelen) fixed bin (35); /* --------------------- */ total = 0; call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then path = ">"; else path = bchr; arglp: call cu_$arg_ptr (an, ap, al, ec); if ec = 0 then do; if substr (bchr, 1, 1) = "-" then do; if bchr = "-author" | bchr = "-at" then do; modsw = "0"b; end; else do; call com_err_ (0, "ckauth", "unknown option ^a", bchr); return; end; end; else do; /* not control arg, must be access name */ name = bchr; if index (name, ".") = 0 then do; call com_err_ (0, "ckauth", "no period in access control name ^a", name); return; end; end; an = an + 1; go to arglp; end; /* Now, go to work. Call disk sweeper program */ call sweep_disk_ (path, counter); call ioa_ ("Total ^d", total); return; counter: proc (sdn, sen, lvl, een, bptr, nptr); dcl sdn char (168) aligned, /* superior dir name */ sen char (32) aligned, /* dirname */ lvl fixed bin, /* distance from root */ een char (32) aligned, /* entry name */ bptr ptr, /* ptr to info structure */ nptr ptr; /* ptr to names structure */ dcl xp char (168) aligned, xi fixed bin, hisid char (32) aligned, mode fixed bin (5); dcl 1 branch based (bptr) aligned, /* thing returned by star_long */ 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtu bit (36) unal, 2 mode bit (5) unal, 2 pad bit (13) unal, 2 records bit (18) unal; dcl 1 links based (bptr) aligned, 2 type bit (2) unal, /* 00b */ 2 nname bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtd bit (36) unal, 2 pln bit (18) unal, 2 pnindex bit (18) unal; dcl names (100) char (32) based (nptr); xi = fixed (branch.type); if xi ^= 1 then return; call ioa_$rsnnl ("^a>^a", xp, xi, sdn, sen); if modsw then call hcs_$get_bc_author (xp, een, hisid, ec); else call hcs_$get_author (xp, een, 0, hisid, ec); if ec ^= 0 then do; call com_err_ (ec, "ckauth", "^a>^a", xp, een); end; else do; if name = hisid then do; total = total + 1; call ioa_ ("^a>^a", xp, een); end; end; end counter; end ckauth;  command_usage_count.pl1 10/27/83 1614.3rew 10/27/83 1441.5 162963 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: command_usage_count */ /* */ /* Status: */ /* 1) Modified in July, 1983 by G. Dixon - increase number of commands which can be */ /* monitored from 200 (user_list_size) to max number of usage_list.commands entries */ /* which will fit in a segment. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ command_usage_count: cuc: procedure () options (variable); dcl code fixed bin (35), errsw bit (1), first fixed bin init (user_list_size), last_index fixed bin init (0), me char (19) static init ("command_usage_count"), message char (80) var, tempstring char (32) var, userseg_name char (32); dcl arg char (argl) based (argp), /* argument from cu_$arg_ptr */ argl fixed bin, argp ptr; dcl arg_no fixed bin init (1), /* no. of argument being processed */ nargs fixed bin; /* no. of arguments */ dcl comlist (40) char (32) var, /* array for command name arguments */ ncom fixed bin init (0); /* length of the array */ dcl (i, j, k, list_size, maxj, total) fixed bin; /* temporaries */ dcl (usage_list_ptr, segptr, usage_totals_ptr, user_list_ptr) pointer; dcl (add, /* add request given */ all, /* -all option given */ clear, /* -clear option given */ delete, /* delete request given */ header, /* heading printed */ i_locked_it, /* control lock needs opened */ print, /* print request given */ total_only) bit (1) init ("0"b); /* -total option given */ %include command_usage; dcl com_err_ ext entry options (variable), copy_acl_ ext entry (char (*), char (*), char (*), char (*), bit (1), fixed bin (35)), cu_$arg_count ext entry (fixed bin), cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)), cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)), hcs_$delentry_file ext entry (char (*), char (*), fixed bin (35)), hcs_$fs_get_path_name ext entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$make_ptr ext entry (ptr, char (*), char (*), ptr, fixed bin (35)), hcs_$make_seg ext entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$terminate_noname ext entry (ptr, fixed bin (35)), hcs_$truncate_seg ext entry (ptr, fixed bin, fixed bin (35)), get_temp_segment_ entry (character (*), pointer, fixed binary (35)), release_temp_segment_ entry (character (*), pointer, fixed binary (35)), ioa_ entry options (variable); dcl (error_table_$badcall, error_table_$badopt, error_table_$bad_conversion, error_table_$bigarg, error_table_$inconsistent, error_table_$namedup, error_table_$noarg, error_table_$noentry, error_table_$notalloc, error_table_$seglock, error_table_$too_many_names, error_table_$zero_length_seg) external static fixed bin (35); dcl cleanup condition; dcl (addr, fixed, index, length, null, rel, size, substr) builtin; /* PROCESS ARGUMENT LIST */ call cu_$arg_count (nargs); arg_get: call cu_$arg_ptr (arg_no, argp, argl, code); if code ^= 0 then go to err_nomsg; if arg_no = 1 then go to key; if substr (arg, 1, 1) = "-" then go to ctl_arg; /* control argument found */ if ncom >= 40 then do; /* too many command name arguments ? */ code = error_table_$too_many_names; go to err_nomsg; end; if argl > 32 then do; /* command name argument too long ? */ code = error_table_$bigarg; go to arg_err; end; ncom = ncom + 1; comlist (ncom) = arg; go to arg_loop; ctl_arg: if add | print then /* for add or print requests only: */ if arg = "-tt" | arg = "-total" then do; /* check for "-total" option */ total_only = "1"b; go to arg_loop; end; if delete | print then /* for delete or print requests only: */ if arg = "-a" | arg = "-all" then do; /* check for "-all" option */ all = "1"b; go to arg_loop; end; if print then /* for print requests only: */ if arg = "-ft" | arg = "-first" then do; /* check for "-first n" option */ arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, argp, argl, code); if code ^= 0 then go to err_nomsg; first = cv_dec_check_ (arg, code); if code ^= 0 then do; code = error_table_$bad_conversion; go to arg_err; end; go to arg_loop; end; if print then /* for print requests only: */ if arg = "-cl" | arg = "-clear" then do; /* check for "-clear" option */ clear = "1"b; go to arg_loop; end; if print then /* for print requests only: */ if arg = "-brief" | arg = "-bf" then do; /* check for "-brief" option */ header = "1"b; /* don't print heading */ go to arg_loop; end; code = error_table_$badopt; /* unknown control option */ go to arg_err; key: if arg = "pr" | arg = "print" then do; /* print request */ print = "1"b; go to arg_loop; end; if arg = "add" then do; /* add request */ add = "1"b; go to arg_loop; end; if arg = "dl" | arg = "delete" then do; /* delete request */ delete = "1"b; go to arg_loop; end; code = error_table_$badcall; /* unknown key argument */ go to arg_err; arg_loop: arg_no = arg_no + 1; if arg_no <= nargs then go to arg_get; /* CHECK ARGUMENT CONSISTENCY */ if all & ncom ^= 0 then do; code = error_table_$inconsistent; message = "-all and " || comlist (1); go to err_msg; end; if total_only & first ^= user_list_size then do; code = error_table_$inconsistent; message = "-total and -first"; go to err_msg; end; if ncom = 0 then /* add request must specify a command name list */ if add | (delete & ^all) then do; /* "-all" is default for print, but not for delete */ code = error_table_$noarg; go to err_nomsg; end; /* INITIATE LIST AND TOTALS SEGMENTS */ call hcs_$make_ptr (null, "command_usage_list_", "", usage_list_ptr, code); if code ^= 0 then go to list_err; call hcs_$make_ptr (null, "command_usage_totals_", "", usage_totals_ptr, code); if code ^= 0 then go to totals_err; /* SET LOCK FOR MODIFICATION REQUESTS */ if add | delete | clear then do; /* if any modification of the control or */ if ^usage_list.locked then do; /* usage segments is requested, then set */ usage_list.locked = "1"b; /* a lock against other modification requests */ i_locked_it = "1"b; /* remember to reset the lock */ on cleanup begin; /* reset lock if aborted */ usage_list.locked = "0"b; /* entrance to this condition proves */ end; /* that i set lock */ end; else do; /* lock is already set */ code = error_table_$seglock; message = "command_usage_list_^/The command list is being edited - try again later."; go to err_msg; end; end; list_size = usage_list.n_commands; /* copy command name list size */ if add then go to add_com; /* PROCESS PRINT AND DELETE REQUESTS */ if list_size = 0 then do; /* see if anything is there to process. */ code = error_table_$zero_length_seg; message = "command_usage_list_^/The command name list is empty."; go to err_msg; end; if print & ^total_only then do; /* get a scratch segment if needed */ call get_temp_segment_ ((me), user_list_ptr, code); if user_list_ptr = null () then go to temp_err; end; /* If we are deleting entries, things get juggled around, so turn off usage monitoring for a few milliseconds. We don't want to set a lock that would be waited on by any process executing any command (including one attempting to reset that lock). Losing a few tallies isn't that important. */ if delete then usage_list.n_commands = 0; if ncom ^= 0 then go to select; /* print or delete selected entries */ do k = 1 to list_size; /* print or delete all entries */ if commands.primary (k) then call print_or_delete; /* process each command name group */ end; if ^delete then go to print_done; /* we just deleted every thing, so */ /* truncate segments to zero length */ call hcs_$truncate_seg (usage_list_ptr, 0, code); if code ^= 0 then go to list_err; call hcs_$truncate_seg (usage_totals_ptr, 0, code); if code ^= 0 then go to totals_err; /* Note: truncating command_usage_list_ resets the lock */ return; /* so just return */ select: do j = 1 to ncom; /* go through list of command name arguments */ do k = 1 to list_size; /* find name in the control list */ if commands.name (k) = comlist (j) then go to found; end; go to next_com; /* not there, print error message when done */ found: if ^commands.primary (k) then k = commands.slot (k); /* get the primary entry of the command group */ call print_or_delete; /* process command group */ comlist (j) = ""; /* clear argument from list to say we did it */ next_com: end; if delete then do; /* truncate control segment */ call hcs_$truncate_seg (usage_list_ptr, fixed (rel (addr (commands.name (list_size+1)))), code); if code ^= 0 then go to list_err; usage_list.n_commands = list_size; /* turn monitoring back on */ end; do j = 1 to ncom; /* check for names not found */ if comlist (j) ^= "" then call com_err_ (error_table_$noentry, (me), "^a", comlist (j)); end; print_done: if print & ^total_only then call release_temp_segment_ ((me), user_list_ptr, (0)); go to quit; /* done */ /* PROCESS ADD REQUESTS */ add_com: if list_size = 0 then do; /* initialize */ call hcs_$fs_get_path_name (usage_totals_ptr, usage_list.directory, k, "", code); if code ^= 0 then go to totals_err; call hcs_$truncate_seg (usage_totals_ptr, 0, code); if code ^= 0 then go to totals_err; end; do k = 1 to list_size; /* check for duplication of command names */ do j = 1 to ncom; if commands.name (k) = comlist (j) then do; code = error_table_$namedup; message = comlist (j) || "^/Command name already in table."; go to err_msg; end; end; if commands.primary (k) then last_index = commands.slot (k); /* locate last used index in totals list */ end; usage_list_size = ncom + list_size; if usage_list_size > 7000 then do; code = error_table_$notalloc; /* would adding this command group make too many ? */ message = "command_usage_list_^/The command name list is full."; go to err_msg; end; if ^total_only then do; /* if creating a user usage segment, */ if length (comlist (1)) < 27 then go to add_user_seg; /* check length of the first command name */ do j = 2 to ncom; /* too long - search names for a shorter one */ if length (comlist (j)) < 27 then do; /* found one - move to the front of the list */ tempstring = comlist (1); comlist (1) = comlist (j); comlist (j) = tempstring; go to add_user_seg; end; end; code = error_table_$bigarg; message = "Some command name must be less than 27 characters long.^/Add request ignored."; go to err_msg; add_user_seg: userseg_name = comlist (1) || ".usage"; /* create segment name */ call hcs_$make_seg (usage_list.directory, userseg_name, "", 01011b, user_list_ptr, code); if user_list_ptr = null then go to userseg_err; call copy_acl_ (usage_list.directory, "command_usage_totals_", usage_list.directory, userseg_name, errsw, code); if code ^= 0 then if errsw then go to userseg_err; else go to totals_err; call hcs_$truncate_seg (user_list_ptr, 0, code); /* truncate segment */ if code ^= 0 then go to userseg_err; call hcs_$terminate_noname (user_list_ptr, code); /* done with user segment */ if code ^= 0 then go to userseg_err; end; do j = 1 to ncom; commands.name (list_size+j) = comlist (j); /* copy command name to list entry */ commands.primary (list_size+j) = "0"b; /* say entry is not a primary one */ commands.slot (list_size+j) = list_size + 1; /* make secondaries point to primary entry */ end; commands.primary (list_size+1) = "1"b; /* now make the first entry a primary entry */ commands.slot (list_size+1) = last_index + 1; /* it's slot element points to the usage totals tally */ commands.count_users (list_size+1) = ^total_only; /* says whether a user usage segment exists */ usage_totals (last_index + 1) = 0; /* clear usage total tally */ usage_list.n_commands = list_size + ncom; /* finally increase size of command name list */ /* EXIT */ quit: if i_locked_it then usage_list.locked = "0"b; /* if lock set by this process, reset it */ return; /* INTERNAL PROCEDURE TO PROCESS A SINGLE PRINT OR DELETE REQUEST */ print_or_delete: proc; dcl j fixed bin; if delete then go to delete_com; if ^header then do; /* heading needed */ if total_only then call ioa_ ("USAGE^-COMMAND^/COUNT^-GROUP^/"); else call ioa_ ("USAGE^-COMMAND^-USER^-USER^/COUNT^-GROUP^-COUNT^-NAME^/"); header = "1"b; /* heading now printed */ end; total = usage_totals (commands.slot (k)); /* save usage total */ if clear then /* reset total if clearing */ usage_totals (commands.slot (k)) = 0; if commands.count_users (k) then /* if a user usage segment exists and */ if ^total_only | clear then do; /* we need it, then initiate it */ userseg_name = commands.name (k) || ".usage"; /* segment name */ call hcs_$initiate (usage_list.directory, userseg_name, "", 0, 1, segptr, code); if segptr = null () then go to userseg_err; if ^total_only then /* if printing user counts, copy them to temporary */ user_list_ptr -> user_list = segptr -> user_list; if clear then do; /* reset user counts if clearing */ call hcs_$truncate_seg (segptr, 0, code); if code ^= 0 then go to userseg_err; end; call hcs_$terminate_noname (segptr, code); /* done with segment */ if code ^= 0 then go to userseg_err; end; call ioa_ ("^5d^-^a", total, commands.name (k)); /* now do the printing */ do i = k+1 to list_size while (^commands.primary (i)); call ioa_ ("^-^a", commands.name (i)); /* print all names in the command group */ end; if ^commands.count_users (k) | total_only then return; do i = 1 to user_list_size; /* print the user usage counts */ maxj = 1; /* in descending order */ do j = 1 to user_list_size; /* find the largest tally */ if user_list.count (j) > user_list.count (maxj) then maxj = j; end; if user_list.count (maxj) = 0 then go to end_of_print; /* if the largest is zero, then done */ if i > first then go to end_of_print; /* check -first n value */ total = total - user_list.count (maxj); /* check user counts against total */ tempstring = user_list.name (maxj); /* copy user identifcation */ j = index (tempstring, "*"); /* form is "person.project.*" */ if j ^= 0 then /* we want only "person.project" */ tempstring = substr (tempstring, 1, j-2); call ioa_ ("^2-^5d^-^a", user_list.count (maxj), tempstring); /* print a line */ user_list.count (maxj) = 0; /* clear this entry and repeat */ end; end_of_print: if total > 0 then /* print result of error check */ call ioa_ ("^2-^5d^-^a", total, "all others"); call ioa_ (""); return; delete_com: if commands.count_users (k) then do; /* is there a user usage segment ? */ userseg_name = commands.name (k) || ".usage"; /* yes */ call hcs_$delentry_file (usage_list.directory, userseg_name, code); /* delete it */ if code ^= 0 then go to userseg_err; end; if all then return; /* if deleting everything, the following is not needed */ do i = commands.slot (k) to user_list_size; /* move total tallies past deleted one down by one */ usage_totals (i) = usage_totals (i+1); end; do i = k+1 to list_size while (^commands.primary (i)); /* find size of command group we are deleting */ end; i = i - k; /* "i" is now the size */ do j = k to list_size; /* move command entries past this group down */ commands.name (j) = commands.name (j+i); commands.primary (j) = commands.primary (j+i); if commands.primary (j) then commands.slot (j) = commands.slot (j+i) - 1; /* total tally moved down one */ else commands.slot (j) = commands.slot (j+i) - i; /* primary entry moved down by i */ commands.count_users (j) = commands.count_users (j+i); end; list_size = list_size - i; /* shorten command list length */ return; /* done */ end print_or_delete; /* ERROR ROUTINES */ arg_err: call com_err_ (code, (me), arg); /* never called with lock set */ return; list_err: message = "command_usage_list_"; go to err_msg; totals_err: message = "command_usage_totals_"; go to err_msg; userseg_err: message = userseg_name; go to err_msg; temp_err: message = "temporay segment"; err_msg: if i_locked_it then /* may be called with lock set */ if delete & ^all then usage_list.n_commands = list_size; call com_err_ (code, (me), message); go to quit; err_nomsg: call com_err_ (code, (me)); /* never called with lock set */ return; end command_usage_count;  console_edit.pl1 10/27/83 1614.3rew 10/27/83 1441.5 16029 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ console_edit: proc; /* CONSOLE_REPORT - produce a report of console use Input is the accounting deck for the month THVV 2/71 */ dcl (path, dn) char (168) aligned, en char (32) aligned, j fixed bin, idc char (8) aligned, ask_ entry options (variable), ask_$ask_line entry options (variable), ask_$ask_clr entry options (variable), ec fixed bin; dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin), com_err_ entry options (variable), hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin); dcl (null, addr) builtin; %include console_report_data; /* ============================= */ path = "termseg"; call expand_path_ (addr (path), 7, addr (dn), addr (en), ec); call hcs_$make_seg (dn, en, "", 1011b, tsp, ec); if tsp = null then do; er: call com_err_ (ec, "cdei", path); return; end; call ask_$ask_clr; loop: call ask_ ("idcode ", idc); if idc = "callexit" then return; do j = 1 to nterms; if id (j) = idc then go to f1; end; j, nterms = nterms + 1; call ask_$ask_clr (); go to loop; f1: if cm (j) ^= "" then call ask_$ask_line (cm (j), cm (j)); else call ask_$ask_line ("where ", cm (j)); go to loop; end;  cv_cmf.rd 12/01/89 1002.2rew 12/01/89 1000.0 397080 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,indcomtxt */ /* CV_CMF - Program to compile the Channel Master File into a Channel Definition Table. Written August 1975 by THVV Modified 751117 by PG to add access_name stmt Modified 760512 by Mike Grady to add baud stmt and FNP info Modified 760705 by D. M. Wells to understand about FTP channels Modified November 1976 by T. Casey to allow name: ttyNXX-ttyNYY; and Baud: NNN; Modified 761229 by D. M. Wells to allow compatibility for renamed items -- line_type TELNET and service_types FTP and MC Modified 770624 by Robert Coren to make terminal types be character strings and to add dont_read_answerback attribute. Modified Fall 1978 by Larry Johnson for demultiplexing. Modified April 1979 by Larry Johnson to move most checking of multiplexer and sub-channel specifications into multiplexer specific modules, and to allow FNP's to be specified other than those running MCS. Modified July 1979 by C. Hornig to allow non-FNP MCS channels. Modified 1979 August 21 by Art Beattie to accomodate a change to cdt.incl.pl1. Modified January 1981 by E. N. Kittlitz to eliminate cdte.phone_no. Modified May 1981 by Robert Coren to call parse_tty_name_. Modified December 1981 by Benson I. Margulies for cdt tree. Modified April 1982 by Robert Coren for change to baud_rates.incl.pl1. Modified July 1982 by E. N. Kittlitz for [severity] and cmf suffix. Modified August 1982 by E. N. Kittlitz for check_acs. Modified January 1983 by Keith Loepere for generic_destination. Modified 84-01-09 by BIM for more access control flags. */ /* HISTORY COMMENTS: 1) change(86-09-21,Beattie), approve(86-09-21,MCR7542), audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211): Remove references to the 963 and 029 preaccess commands and remove support for ARDS, 202_ETX, 2741 and 1050 in system interfaces. 2) change(87-03-17,Beattie), approve(87-05-04,MCR7682), audit(87-05-29,Parisek), install(87-07-17,MR12.1-1042): Fix bug in mpx_error where errors in CMF that are detected by multiplexers were not getting displayed. END HISTORY COMMENTS */ /*++ BEGIN / / ERROR(2) / RETURN \ mainloop / FNP : ; / LEX(2) open_fnp LEX(2) PUSH(mainloop) / do_fnp \ / name : ; / LEX(2) open_chn LEX(2) PUSH(mainloop) / do_name \ \" Master Keywords. These supply defaults for all cdte's following. / Access_class : ; / LEX(4) [dft.access_class = access_class_value] / mainloop \ / Access_class : / LEX(2) ERROR(10) NEXT_STMT / mainloop \ / Check_acs : / LEX(2) PUSH(mainloop) PUSH (assign_dft_access) / checksub \ / Attributes : / LEX(2) PUSH(mainloop) PUSH(assign_dft) / attsub \ / Baud : ; / LEX(2) [dft.baud_rate = baud_rate_value; dft.flags.autobaud = ""b] LEX(2) / mainloop \ / Baud : auto ; / LEX(2) [dft.baud_rate = 0; dft.flags.autobaud = "1"b] LEX(2) / mainloop \ / Baud : none ; / LEX(2) [dft.baud_rate = 0; dft.flags.autobaud = ""b] LEX(2) / mainloop \ / Baud : / LEX(2) ERROR(29) NEXT_STMT / mainloop \ / Line_type : ; / LEX(2) [dft.line_type = line_type_value] LEX(2) / mainloop \ / Line_type : / LEX(2) ERROR(11) NEXT_STMT / mainloop \ / Terminal_type : ; / LEX(2) check_terminal_type [dft.initial_terminal_type = terminal_type_value] LEX(2) / mainloop \ / Terminal_type : / LEX(2) ERROR(8) NEXT_STMT / mainloop \ / Comment : ; / LEX(2) [dft.comment = token_value] LEX(2) / mainloop \ / Initial_command : ; / LEX(2) [dft.initial_command = token_value; dft.execute_initial_command = token_value ^= ""] LEX(2) / mainloop \ / Generic_destination : ; / LEX(2) [addr (dft.initial_command) -> generic_destination = token_value; dft.generic_destination_present = token_value ^= ""] LEX(2) / mainloop \ / Charge : ; / LEX(2) [dft.charge_type = charge_value] LEX(2) / mainloop \ / Charge : / LEX(2) ERROR(12) NEXT_STMT / mainloop \ / Service : ; / LEX(2) [dft.service_type = service_value] LEX(2) / mainloop \ / Service : / LEX(2) ERROR(16) NEXT_STMT / mainloop \ / FNP_required_up_time : ; / LEX(2) [cdt.acceptable_fnp_tbf = token.Nvalue] LEX(2) / mainloop \ / FNP_required_up_time : / LEX(2) ERROR(44) NEXT_STMT / mainloop \ / Spare_channel_count : ; / LEX(2) [cdt.spare_channel_count = token.Nvalue] LEX(2) / mainloop \ / Spare_channel_count : / LEX(2) ERROR(47) NEXT_STMT / mainloop \ / end ; / / RETURN \ / : / ERROR(3) NEXT_STMT / mainloop \ / / ERROR(4) NEXT_STMT / mainloop \ / / ERROR(5) / RETURN \ \" \" do_name subroutine - handles name sub-keywords do_name / access_class : ; / LEX(4) [cdte.access_class = access_class_value] / do_name \ / access_class : / LEX(2) ERROR(10) NEXT_STMT / do_name \ / baud : auto ; / LEX(2) [cdte.flags.autobaud = "1"b; cdte.baud_rate = 0] LEX(2) / do_name \ / baud : none ; / LEX(2) [cdte.flags.autobaud = "0"b; cdte.baud_rate = 0] LEX(2) / do_name \ / baud : ; / LEX(2) [cdte.baud_rate = baud_rate_value] LEX(2) / do_name \ / baud : / LEX(2) ERROR(29) NEXT_STMT / do_name \ / check_acs : / LEX(2) PUSH(do_name) PUSH(assign_access) / checksub \ / attributes : / LEX(2) PUSH(do_name) PUSH(assign_attr) / attsub \ / answerback : ; / LEX(2) [cdte.answerback = token_value] LEX(2) / do_name \ / line_type : / LEX(2) [cdte.line_type = line_type_value] LEX(1) / line_type \ / line_type : / LEX(2) ERROR(11) NEXT_STMT / do_name \ / dataset : / LEX(2) [cdte.modem_type = dataset_value] LEX(1) / dataset \ / dataset : / LEX(2) ERROR (38) NEXT_STMT / do_name \ / terminal_type : ; / LEX(2) check_terminal_type [cdte.initial_terminal_type = terminal_type_value] LEX(2) / do_name \ / terminal_type : / LEX(2) ERROR(8) NEXT_STMT / do_name \ / comment : ; / LEX(2) [cdte.comment = token_value] LEX(2) / do_name \ / initial_command : ; / LEX(2) [cdte.initial_command = token_value; cdte.execute_initial_command = token_value ^= ""] LEX(2) / do_name \ / generic_destination : ; / LEX(2) [addr (cdte.initial_command) -> generic_destination = token_value; cdte.generic_destination_present = token_value ^= ""] LEX(2) / do_name \ / charge : ; / LEX(2) [cdte.charge_type = charge_value] LEX(2) / do_name \ / charge : / LEX(2) ERROR(12) NEXT_STMT / do_name \ / service : ; / LEX(2) [cdte.service_type = service_value] LEX(2) / do_name \ / service : / LEX(2) ERROR(16) NEXT_STMT / do_name \ / multiplexer_type : , ; / LEX(2) [cdte.mpx_type = mpx_type_value] LEX(2) [cdte.mpx_service = service_value] LEX(2) / do_name \ / multiplexer_type : , / LEX(4) ERROR(16) NEXT_STMT / do_name\ / multiplexer_type : ; / LEX(2) [cdte.mpx_type = mpx_type_value] LEX(2) / do_name \ / multiplexer_type : / LEX(2) ERROR(51) NEXT_STMT / do_name \ / / close_chn / STACK_POP \ / / close_chn / STACK_POP \ \" \" a couple of routines to handle line_type and dataset options dataset / , / LEX / ds_opt \ / ; / LEX / do_name \ / / ERROR(4) NEXT_STMT / do_name \ / / ERROR(5) / RETURN \ ds_opt / private_line / LEX [cdte.flags.private_line = "1"b] / dataset \ / / ERROR(40) NEXT_STMT / do_name \ / / ERROR(5) / RETURN \ line_type / , / LEX / lt_opt \ / ; / LEX / do_name \ / / ERROR(4) NEXT_STMT / do_name \ / / ERROR(5) / RETURN \ lt_opt / ebcdic / LEX [cdte.flags.bsc_ebcdic = "1"b] / line_type \ / ascii / LEX [cdte.flags.bsc_ebcdic = "0"b] / line_type \ / transparent / LEX [cdte.flags.bsc_transparent = "1"b] / line_type \ / nontransparent / LEX [cdte.flags.bsc_transparent = "0"b] / line_type \ / / ERROR(41) NEXT_STMT / do_name \ / / ERROR(5) / RETURN \ \" do_fnp subroutine - handles FNP sub-keywords do_fnp / type : ; / LEX(2) [fnpe.type = fnp_type_value] LEX(2) / do_fnp \ / type : / LEX(2) ERROR(19) NEXT_STMT / do_fnp \ / memory : ; / LEX(2) [fnpe.memory = token.Nvalue] LEX(2) / do_fnp \ / memory : / LEX(2) ERROR(20) NEXT_STMT / do_fnp \ / lsla : ; / LEX(2) [fnpe.nlslas = token.Nvalue] LEX(2) / do_fnp \ / lsla : / LEX(2) ERROR(21) NEXT_STMT / do_fnp \ / hsla : ; / LEX(2) [fnpe.nhslas = token.Nvalue] LEX(2) / do_fnp \ / hsla : / LEX(2) ERROR(21) NEXT_STMT / do_fnp \ / image : ; / LEX(2) [fnpe.coreimage = token_value] LEX(2) / do_fnp \ / image : / LEX(2) ERROR(22) NEXT_STMT / do_fnp \ / additional_info : ; / LEX(2) [fnpe.coreimage = token_value] LEX(2) / do_fnp\ / additional_info : / [fnpe.coreimage = ""] NEXT_STMT / do_fnp \ / service : ; / LEX(2) [fnpe.service_type = service_value] LEX(2) / do_fnp \ / service : / LEX(2) ERROR(16) NEXT_STMT / do_fnp \ / multiplexer_type : ; / LEX(2) [fnpe.mpx_type = mpx_type_value] LEX(2) /do_fnp\ / multiplexer_type : / LEX(2) ERROR(51) NEXT_STMT /do_fnp\ / / close_fnp / STACK_POP \ / / close_fnp / STACK_POP \ \" \" attsub subroutine - handles attributes lists attsub / / [sx=ON; ats=dft.attributes] / \ attloop / ; / LEX / STACK_POP \ / none / LEX [string(ats)=""b] / atts \ / ^ / LEX [sx=OFF] / \ / set_modes / LEX [ats.set_modes=sx] / atts \ / audit / LEX [ats.audit_access_error=sx] / atts \ / hardwired / LEX [ats.hardwired=sx] / atts \ / check_answerback / LEX [ats.ck_answerback=sx] / atts \ / dont_read_answerback / LEX [ats.dont_read_answerback=sx] / atts \ / / ERROR(14) NEXT_STMT / STACK_POP \ / / ERROR(7) / RETURN \ atts / , / LEX [sx = ON] / attloop \ / ; / LEX / STACK_POP \ / / ERROR(15) NEXT_STMT / STACK_POP \ / / ERROR(7) / RETURN \ assign_attr / / [cdte.attributes = ats] / STACK_POP \ assign_dft / / [dft.attributes=ats] / STACK_POP \ checksub / / [sx=ON;access=dft.access_control] / \ checkloop / ; / LEX / STACK_POP \ / none / LEX [string(access)=""b] / checks \ / all / LEX [string(access)=ALL_ACCESS_CHECKS] / checks \ / ^ / LEX [sx=OFF] / \ / login / LEX [access.login=sx] / checks \ / slave_dial / LEX [access.slave_dial=sx] / checks \ / dial_server / LEX [access.dial_server=sx] / checks \ / dial_out / LEX [access.dial_out=sx] / checks \ / priv_attach / LEX [access.priv_attach=sx] / checks \ / / ERROR(27) NEXT_STMT / STACK_POP \ / / ERROR(26) / RETURN \ checks / , / LEX [sx=ON] / checkloop \ / ; / LEX / STACK_POP \ / / ERROR(27) NEXT_STMT / STACK_POP \ / / ERROR(26) / RETURN \ assign_dft_access / / [dft.access_control=access] / STACK_POP \ assign_access / / [cdte.access_control=access] / STACK_POP \ ++*/ cv_cmf: procedure; /* automatic */ dcl (APstmt, APtoken, areap, cmfp) ptr; dcl 1 dft aligned like cdte; dcl 1 ats aligned like cdte.attributes; dcl 1 access aligned like cdte.access_control; dcl ALL_ACCESS_CHECKS bit (5) init ("11111"b) int static options (constant); dcl access_class_value (2) bit (72) aligned; dcl charge_value fixed bin; dcl service_value fixed bin; dcl line_type_value fixed bin; dcl terminal_type_value char (32); dcl fnp_type_value fixed bin; dcl dataset_value fixed bin; dcl baud_rate_value fixed bin; dcl mpx_type_value fixed bin; dcl mpx_error_printedp ptr init (null ()); dcl system_areap ptr; dcl dn char (168); dcl (supplied_en, cmf_en, cdt_en) char (32); dcl (i, n) fixed bin; dcl fnpno fixed bin; dcl ndev fixed bin; dcl bitc fixed bin (24); dcl (argc, argx) fixed bin; dcl ap ptr; dcl al fixed bin (21); dcl ec fixed bin (35); dcl code fixed bin (35); dcl created_table_segment bit (1) aligned; dcl sx bit (1) aligned; dcl fb35 fixed bin (35); dcl 1 dvt (16) aligned, 2 device_id char (8), 2 device_prices (0:7) float; /* based */ dcl bchr char (al) unal based (ap); dcl system_area area based (system_areap); dcl mpx_error_printed (hbound (mpx_types, 1), 99) bit (1) unal based (mpx_error_printedp); /* builtin */ declare (addr, bin, character, collate, dimension, divide, hbound, index, lbound, length, ltrim, max, null, rank, rel, rtrim, size, string, substr, translate, unspec, verify, wordno) builtin; /* conditions */ declare cleanup condition; declare sub_error_ condition; /* entries */ dcl convert_authorization_$from_string_range entry ((2) bit (72) aligned, character (*), fixed binary (35)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cdt_mgr_$thread entry (ptr, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl get_wdir_ entry () returns (char (168)); dcl get_group_id_ entry () returns (char (32) aligned); dcl get_shortest_path_ entry (char (*)) returns (char (168)); dcl get_system_free_area_ entry () returns (ptr); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl system_info_$device_prices entry (fixed bin, ptr); dcl lex_error_ entry options (variable); dcl lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var); dcl lex_string_$lex entry (ptr, fixed bin, fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)); dcl translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); dcl com_err_$suppress_name entry () options (variable); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl ttt_info_$terminal_data entry (char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl sort_items_$general entry (ptr, entry); dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)); dcl parse_tty_name_ entry (char (*), fixed bin, bit (1), fixed bin, fixed bin); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); /* internal static */ dcl ( ( ON bit (1) initial ("1"b), OFF bit (1) initial ("0"b), my_name char (6) initial ("cv_cmf") ) options (constant), first bit (1) initial ("1"b), (LEXDLM, LEXCTL) char (128) var, BREAKS char (128) var, IGBREAKS char (128) var ) internal static; dcl services (8) char (12) static options (constant) init ("login", "FTP", "MC", "slave", "", "autocall", "inactive", "multiplexer"); /* external static */ dcl ( error_table_$translation_failed, error_table_$noentry, error_table_$too_many_args, error_table_$badopt, error_table_$zero_length_seg, error_table_$noarg, error_table_$bad_conversion ) fixed bin (35) external static; dcl sys_info$max_seg_size ext fixed bin (18); dcl cv_cmf_severity_ fixed bin (35) external init (0); /* include files */ /* format: off */ %page; %include cdt; %page; %include author_dcl; %page; %include line_types; %page; %include baud_rates; %page; %include dataset_names; %page; %include multiplexer_types; %page; %include dialup_values; %page; %include sub_error_info; %include condition_info_header; %include condition_info; declare 1 auto_condition_info aligned like condition_info; %page; %include terminate_file; %page; %include access_mode_values; /* format: on */ /* program */ cmfp = null; /* Initialize for cleanup handler */ cdtp = null; /* .. */ areap = null; /* .. */ dn, supplied_en = ""; created_table_segment = ""b; on cleanup begin; call clean_up; /* do any tidying up of address space */ cv_cmf_severity_ = 5; /* fie on you */ end; call cu_$arg_count (argc, ec); /* Note AF calls */ if ec ^= 0 then do; call com_err_ (ec, my_name); go to severity_5_failure; end; if argc = 0 then do; give_usage: call com_err_$suppress_name (0, my_name, "Usage: cv_cmf CMF (-brief|-bf|-long|-lg)"); go to severity_5_failure; end; do argx = 1 to argc; call cu_$arg_ptr (argx, ap, al, (0)); if character (bchr, 1) ^= "-" then do; if supplied_en ^= "" then do; call com_err_ (error_table_$too_many_args, my_name, "Only one pathname may be given. ^a was the second.", bchr); go to severity_5_failure; end; call expand_pathname_ (bchr, dn, supplied_en, ec); if ec ^= 0 then do; path_error: call com_err_ (ec, my_name, "^a", bchr); go to severity_5_failure; end; call expand_pathname_$add_suffix (bchr, "cmf", dn, cmf_en, ec); if ec ^= 0 then go to path_error; call suffixed_name_$new_suffix (supplied_en, "cmf", "cdt", cdt_en, ec); /* if we get this far, how can we fail? */ if ec ^= 0 /* still, let's have a look */ then go to path_error; end; /* Pathname case */ else if bchr = "-bf" then SERROR_CONTROL = "01"b; else if bchr = "-brief" then SERROR_CONTROL = "01"b; else if bchr = "-long" | bchr = "-lg" then SERROR_CONTROL = "10"b; else if bchr = "-severity" | bchr = "-sv" then do; if argx >= argc then do; call com_err_ (error_table_$noarg, my_name, "After ""^a"".", bchr); go to severity_5_failure; end; argx = argx + 1; call cu_$arg_ptr (argx, ap, al, ec); fb35 = cv_dec_check_ (bchr, ec); if ec ^= 0 | fb35 < 0 | fb35 > 5 then do; call com_err_ (error_table_$bad_conversion, my_name, "Severity must be an integer in the range 0 - 5, not ""^a"".", bchr); go to severity_5_failure; end; MIN_PRINT_SEVERITY = fb35; end; else do; call com_err_ (error_table_$badopt, my_name, "^a", bchr); go to severity_5_failure; end; end; /* Arg Loop */ if supplied_en = "" then go to give_usage; call system_info_$device_prices (ndev, addr (dvt)); call initiate_file_ (dn, cmf_en, R_ACCESS, cmfp, bitc, ec); if ec = error_table_$noentry then if cmf_en ^= supplied_en then do; call initiate_file_ (dn, supplied_en, R_ACCESS, cmfp, bitc, ec); if ec = 0 then do; call com_err_ (0, my_name, "Warning: converting ^a. The segment should be named ^a.", pathname_ (dn, supplied_en), cmf_en); cmf_en = supplied_en; end; end; if ec ^= 0 then do; cmf_error: call com_err_ (ec, my_name, "^a.", pathname_ (dn, cmf_en)); go to severity_5_failure; end; n = divide (bitc + 8, 9, 24, 0); if n = 0 then do; ec = error_table_$zero_length_seg; go to cmf_error; end; dn = get_wdir_ (); call hcs_$make_seg (dn, cdt_en, "", 1010b, cdtp, ec); created_table_segment = (ec = 0); if cdtp = null then do; cdt_error: call com_err_ (ec, my_name, "^a.", pathname_ (dn, cdt_en)); go to severity_5_failure; end; call hcs_$truncate_seg (cdtp, 0, ec); /* if we set it all to ""b, it would take all the page faults */ if ec ^= 0 then go to cdt_error; cdtep = addr (cdt.cdt_entry (1)); cdt.author.proc_group_id = get_group_id_ (); /* Initialize the header of the new cdt */ cdt.author.table = "CDT"; dn = get_shortest_path_ (dn); cdt.author.w_dir = substr (dn, 1, length (cdt.author.w_dir)); cdt.author.last_install_time = 0; cdt.version = CDT_version; cdt.max_size = divide (sys_info$max_seg_size - bin (rel (cdtep), 18), size (cdte), 17, 0); cdt.acceptable_fnp_tbf = 5; cdt.spare_channel_count = 10; unspec (dft) = "0"b; /* Zero the defaults .. the lazy way */ cdtep = addr (dft); /* Set up cdtep to point at the dfts. */ dft.name = ""; /* Initialize defaults */ dft.comment = ""; dft.charge_type = 0; dft.line_type = LINE_UNKNOWN; dft.initial_terminal_type = ""; /* nothing special */ dft.current_terminal_type = ""; dft.tty_id_code = ""; string (dft.user_name) = ""; dft.baud_rate = 300; dft.modem_type = 0; string (dft.flags) = "0"b; dft.service_type = ANS_SERVICE; /* dialup line */ dft.answerback = ""; dft.initial_command = ""; call convert_authorization_$from_string_range (dft.access_class, "system_low", code); call translator_temp_$get_segment (my_name, areap, code); if areap = null then do; call com_err_ (code, my_name, "While making a temporary segment in the process directory."); go to severity_5_failure; end; if first then do; BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "()*,:;^"; IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24); call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL); first = "0"b; end; call lex_string_$lex (cmfp, n, 0, areap, "100"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, ec); Pthis_token = APtoken; call SEMANTIC_ANALYSIS (); /* now let individual sub-channels judge on their channels */ system_areap = get_system_free_area_ (); allocate mpx_error_printed in (system_area); string (mpx_error_printed) = "0"b; do i = 1 to hbound (cdt.fnp_entry, 1); fnpep = addr (cdt.fnp_entry (i)); if fnpe.state ^= FNP_FREE then call process_subchans (fnpep, substr (collate (), rank ("a") + i, 1), fnpe.mpx_type); end; do i = 1 to cdt.current_size; cdtep = addr (cdt.cdt_entry (i)); if cdte.service_type = MPX_SERVICE then call process_subchans (cdtep, (cdte.name), (cdte.mpx_type)); end; /* thread proc will detect missing parents and the like */ on sub_error_ begin; declare almsg char (100) aligned; call find_condition_info_ (null, addr (auto_condition_info), (0)); sub_error_info_ptr = auto_condition_info.info_ptr; call convert_status_code_ (sub_error_info.status_code, "", almsg); if ^sub_error_info.default_restart /* not warning */ then do; call semant_error (6, (almsg), (sub_error_info.info_string)); go to abort; end; call semant_error (25, (almsg), (sub_error_info.info_string)); /* Warning */ end; call cdt_mgr_$thread (cdtp, (0)); /* we look at condition, not code */ revert sub_error_; abort: if MERROR_SEVERITY > 2 then do; call com_err_ (error_table_$translation_failed, my_name, cmf_en); if created_table_segment then bitc = -1; else bitc = 0; end; else bitc = (wordno (addr (cdt.cdt_entry (1))) + size (cdte) * cdt.current_size) * 36; if bitc >= 0 then do; call terminate_file_ (cdtp, bitc, TERM_FILE_TRUNC_BC_TERM, ec); if ec ^= 0 then do; call com_err_ (ec, my_name, "Unable to set bitcount on ^a to ^d.", pathname_ (dn, cdt_en), bitc); go to severity_5_failure; end; end; call clean_up; cv_cmf_severity_ = MERROR_SEVERITY; return; severity_5_failure: call clean_up; cv_cmf_severity_ = 5; return; clean_up: procedure; if cmfp ^= null then call terminate_file_ (cmfp, (0), TERM_FILE_TERM, (0)); if cdtp ^= null then if created_table_segment then do; call terminate_file_ (cdtp, (0), TERM_FILE_DELETE, (0)); cdtp = null; end; else call terminate_file_ (cdtp, (0), TERM_FILE_TRUNC_BC_TERM, (0)); if areap ^= null then call translator_temp_$release_all_segments (areap, (0)); end clean_up; /* SYNTAX FUNCTIONS */ access_class: procedure () returns (bit (1) aligned); call convert_authorization_$from_string_range (access_class_value, token_value, code); return (code = 0); end access_class; legal_line_type: proc returns (bit (1)); dcl temp_line_type character (16); /* because we want to make changes to names, we need auto version */ temp_line_type = token_value; if temp_line_type = "Network" then temp_line_type = "TELNET"; do line_type_value = lbound (line_types, 1) to hbound (line_types, 1) while (temp_line_type ^= line_types (line_type_value)); end; if line_type_value > hbound (line_types, 1) then return ("0"b); /* The 1050, 2741, ETX and ARDS line types are no longer valid. */ if line_type_value = LINE_1050 | line_type_value = LINE_2741 | line_type_value = LINE_ARDS | line_type_value = LINE_ETX then return ("0"b); return ("1"b); end legal_line_type; legal_charge: proc returns (bit (1) aligned); if token_value = "none" then do; charge_value = 0; return ("1"b); end; do charge_value = 1 to ndev while (token_value ^= dvt.device_id (charge_value)); end; if charge_value > ndev then return ("0"b); return ("1"b); end legal_charge; legal_service: proc returns (bit (1) aligned); dcl temp_service_type character (12); /* because we want to make changes, we need auto variable */ temp_service_type = token_value; if temp_service_type = "mc" then temp_service_type = "MC"; else if temp_service_type = "ftp" then temp_service_type = "FTP"; do service_value = lbound (services, 1) to hbound (services, 1) while (temp_service_type ^= services (service_value)); end; if service_value > hbound (services, 1) then return ("0"b); return ("1"b); end legal_service; legal_fnp_type: proc returns (bit (1) aligned); do fnp_type_value = 1 to hbound (fnp_types, 1) while (token_value ^= fnp_types (fnp_type_value)); end; if fnp_type_value > hbound (fnp_types, 1) then do; if token_value ^= "HNP" then return ("0"b); fnp_type_value = 3; end; return ("1"b); end legal_fnp_type; legal_baud: proc returns (bit (1) aligned); baud_rate_value = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if baud_rate_value = 0 then return ("1"b); if baud_rate_value = 133 /* no longer valid */ then return ("0"b); do i = 1 to hbound (baud_table, 1) while (baud_table (i) ^= baud_rate_value); end; if i > hbound (baud_table, 1) then return ("0"b); return ("1"b); end legal_baud; legal_fnp_service: proc returns (bit (1) aligned); if token_value = "active" then service_value = ACTIVE; else if token_value = "inactive" then service_value = INACTIVE; else return ("0"b); return ("1"b); end legal_fnp_service; legal_dataset: proc returns (bit (1) aligned); do dataset_value = 1 to hbound (dataset_names, 1) while (token_value ^= dataset_names (dataset_value)); end; if dataset_value > hbound (dataset_names, 1) then return ("0"b); return ("1"b); end legal_dataset; legal_mpx_type: proc returns (bit (1) aligned); do mpx_type_value = 1 to hbound (mpx_types, 1) while (token_value ^= mpx_types (mpx_type_value)); end; if mpx_type_value > hbound (mpx_types, 1) then return ("0"b); else return ("1"b); end legal_mpx_type; /* SEMANTIC FUNCTIONS */ open_chn: proc; dcl i fixed bin; dcl fnp_no fixed bin; dcl (name1, name2) char (64) var; dcl (chan1, chan2) fixed bin; dcl pic9 picture "999999"; if cdt.current_size = cdt.max_size then do; pic9 = cdt.max_size; call semant_error (9, ltrim (pic9, "0"), ""); go to abort; end; channels_open = 0; i = index (token_value, "-"); /* check for range of channels */ if i = 0 then do; /* one channel */ name1 = token_value; channels_open = 1; end; else do; if i = 1 | i = token.Lvalue then do; /* bad range syntax */ bad_pair: call ERROR (45); name1 = "dummy"; channels_open = 1; go to make_cdt_entry; end; name1 = substr (token_value, 1, i - 1); name2 = substr (token_value, i + 1); if length (name1) ^= length (name2) then go to bad_pair; if name1 = name2 then go to bad_pair; do i = 1 to length (name1) while (substr (name1, i, 1) = substr (name2, i, 1)); end; /* count equal characters */ channel_digits = length (name1) - i + 1;/* number of digits that will vary */ if verify (substr (name1, i), "0123456789") ^= 0 then go to bad_pair; if verify (substr (name2, i), "0123456789") ^= 0 then go to bad_pair; chan1 = bin (substr (name1, i)); /* starting channel */ chan2 = bin (substr (name2, i)); /* ending channel */ if chan1 >= chan2 then go to bad_pair; channels_open = chan2 - chan1 + 1; /* number of channels to generate */ end; call check_chan_name ((name1), fnp_no, code); if code ^= 0 then do; name1 = "dummy"; channels_open = 1; end; make_cdt_entry: cdt.current_size, cdt.n_cdtes = cdt.n_cdtes + 1; cdtep = addr (cdt.cdt_entry (cdt.n_cdtes)); cdte = dft; cdte.in_use = NOW_HUNG_UP; cdte.name = name1; end open_chn; /* declare these variables in the external procedure, so open_chn and close_chn can share them */ dcl channels_open fixed bin; dcl channel_digits fixed bin; close_chn: proc; dcl p ptr; dcl new_name char (64) var; dcl i fixed bin; dcl pic9 picture "99999999"; dcl fnp_no fixed bin; if cdt.current_size = 0 then return; if cdte.answerback ^= "" then cdte.flags.ck_answerback = "1"b; if verify (cdte.comment, substr (collate (), 8, 9) || substr (collate (), 33)) ^= 0 then call semant_error (18, (cdte.name), ""); if cdte.flags.execute_initial_command & cdte.flags.generic_destination_present then do; call semant_error (55, (cdte.name), ""); cdte.flags.execute_initial_command, cdte.flags.generic_destination_present = "0"b; end; /* can't allow since these fields overlay */ if cdte.service_type = MPX_SERVICE then do; /* check for consistency of multiplexer stuff */ if cdte.mpx_type = 0 then /* must be specified */ call semant_error (48, (cdte.name), ""); if cdte.flags.execute_initial_command | cdte.flags.generic_destination_present then /* cant allow this, as field is redefined */ call semant_error (49, (cdte.name), ""); unspec (cdte.initial_command) = "0"b; /* reset for mpx use */ cdte.flags.execute_initial_command, cdte.flags.generic_destination_present = "0"b; if cdte.mpx_service = 0 then cdte.mpx_service = ACTIVE; end; else if cdte.mpx_type ^= 0 then /* cant have multiplexer type for non-mpx chan */ call semant_error (50, (cdte.name), ""); do i = 2 to channels_open; if cdt.current_size = cdt.max_size then do; pic9 = cdt.max_size; call semant_error (9, ltrim (pic9, "0"), ""); go to abort; end; new_name = rtrim (cdte.name); pic9 = bin (substr (new_name, length (new_name) - channel_digits + 1)) + 1; substr (new_name, length (new_name) - channel_digits + 1) = substr (pic9, length (pic9) - channel_digits + 1); call check_chan_name ((new_name), fnp_no, code); cdt.current_size, cdt.n_cdtes = cdt.current_size + 1; /* one more channel entry */ p = addr (cdt.cdt_entry (cdt.n_cdtes)); /* get ptr to new entry */ p -> cdte = cdte; /* copy previous entry into this one */ cdtep = p; /* move cdtep to latest entry */ cdte.name = new_name; /* put in the new name */ end; return; end close_chn; /* Procedure to check syntax of a channel name */ check_chan_name: proc (name, fnp_no, code); dcl name char (*); dcl fnp_no fixed bin; dcl code fixed bin (35); dcl i fixed bin; dcl p ptr; dcl hsla bit (1); dcl la_no fixed bin; dcl subchan fixed bin; fnp_no = 0; code = 0; if name = "" | length (name) > length (cdte.name) then do; bad_chan_name: call semant_error (28, name, ""); code = 1; /* error return */ return; end; if (substr (name, 1, 3) = "net" | substr (name, 1, 3) = "ftp") & length (name) = 6 & verify (substr (name, 4), "0123456789") = 0 then ; else do; if substr (name, 2, 1) = "." then do; call parse_tty_name_ (name, fnp_no, hsla, la_no, subchan); if fnp_no < 0 then fnp_no = 0; end; if index (name, "..") ^= 0 then go to bad_chan_name; if substr (name, length (name), 1) = "." then go to bad_chan_name; if substr (name, 1, 1) = "." then goto bad_chan_name; end; do i = 1 to cdt.current_size; p = addr (cdt.cdt_entry (i)); if p -> cdte.name = name then call semant_error (13, name, ""); end; return; end check_chan_name; /* let the multiplexer rule on the validity of any of its sub-channels */ process_subchans: proc (cdt_entryp, mpx_name, mpx_type); dcl cdt_entryp ptr; /* cdtep or fnpep */ dcl mpx_name char (*); dcl mpx_type fixed bin; dcl (star_name, segname, entryname) char (32); dcl i fixed bin; dcl p ptr; dcl entvar entry (ptr, ptr, char (*), ptr, entry) variable; dcl 1 cdt_list aligned, 2 count fixed bin, 2 cdte_ptr (cdt.current_size) ptr unal; star_name = rtrim (mpx_name) || ".*"; cdt_list.count = 0; do i = 1 to cdt.current_size; p = addr (cdt.cdt_entry (i)); call match_star_name_ ((p -> cdte.name), star_name, code); if code = 0 then do; cdt_list.count = cdt_list.count + 1; cdt_list.cdte_ptr (cdt_list.count) = p; end; end; if cdt_list.count > 1 then call sort_items_$general (addr (cdt_list), chan_name_compare); segname = "as_" || rtrim (mpx_types (mpx_type)) || "_mpx_"; entryname = rtrim (mpx_types (mpx_type)) || "_cv_cmf"; call hcs_$make_entry (null (), segname, entryname, entvar, code); if code ^= 0 then call semant_error (54, rtrim (segname) || "$" || rtrim (entryname), mpx_name); else do; mpx_type_value = mpx_type; call entvar (cdtp, cdt_entryp, mpx_name, addr (cdt_list), mpx_error); end; end process_subchans; chan_name_compare: proc (p, q) returns (fixed bin (1)); dcl (p, q) ptr unal; if p -> cdte.name < q -> cdte.name then return (-1); if p -> cdte.name > q -> cdte.name then return (+1); return (0); end chan_name_compare; open_fnp: proc; if length (token_value) > 1 then call ERROR (23); fnpno = index ("ABCDEFGH", token_value); if fnpno = 0 then fnpno = index ("abcdefgh", token_value); if fnpno = 0 then do; call ERROR (23); fnpno = 1; /* to avoid blowing up later */ end; fnpep = addr (cdt.fnp_entry (fnpno)); if fnpe.state > 0 then call ERROR (24); fnpe.state = FNP_DOWN; /* configured, not loaded */ fnpe.service_type = ACTIVE; /* defaults */ fnpe.mpx_type = MCS_MPX; return; end open_fnp; close_fnp: proc; return; end close_fnp; check_terminal_type: proc; terminal_type_value = translate (token_value, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); if terminal_type_value = "NONE" then terminal_type_value = ""; else do; call ttt_info_$terminal_data (terminal_type_value, -1, 0, null, code); if code ^= 0 then call statement_error (46, token_value, ""); /* warn them about this */ end; end check_terminal_type; semant_error: proc (error_num, parm1, parm2); dcl error_num fixed bin, (parm1, parm2) char (*); dcl (stmt_ptr, token_ptr) ptr init (null); goto call_error; statement_error: entry (error_num, parm1, parm2); stmt_ptr = token.Pstmt; /* print the source statement */ token_ptr = Pthis_token; call_error: if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)), MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL, (error_control_table.message (error_num)), (error_control_table.brief_message (error_num)), parm1, parm2); else do; MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity); SERROR_PRINTED (error_num) = "1"b; end; return; end; /* this error routine is the interface to rdc errors for multiplexer parsers */ mpx_error: proc (error_num, severity, long_text, short_text, parm1, parm2); dcl error_num fixed bin; dcl severity fixed bin; dcl (long_text, short_text) char (*); dcl (parm1, parm2) char (*); dcl (i, j) fixed bin; i = error_num; if i < 1 | i > 99 then i = 99; j = 100 * mpx_type_value + i; if severity >= MIN_PRINT_SEVERITY then call lex_error_ (j, mpx_error_printed (mpx_type_value, i), severity, MERROR_SEVERITY, null (), null (), SERROR_CONTROL, long_text, short_text, parm1, parm2); else do; MERROR_SEVERITY = max (MERROR_SEVERITY, severity); mpx_error_printed (mpx_type_value, i) = "1"b; end; return; end mpx_error; dcl 1 error_control_table (55) aligned int static, 2 severity fixed bin (17) unal init ((5) 3, /* 1-5 */ 1, /* 6 */ (2) 3, /* 7 - 8 */ 3, /* 9 */ (7) 3, /* 10-16 */ (2) 1, /* 17-18 */ (6) 3, /* 19-24 */ 3, /* 25 */ (20) 3, /* 26-45 */ 1, /* 46 */ (7) 3, /* 47-53 */ 1, /* 54 */ 3), /* 55 */ 2 Soutput_stmt bit (1) unaligned initial ("1"b, /* 1 */ "0"b, /* 2 */ (2) (1)"1"b, /* 3-4 */ "0"b, /* 5 */ "0"b, /* 6 */ "0"b, /* 7 */ (9) (1)"1"b, /* 8-16 */ (2) (1)"0"b, /* 17-18 */ (6) (1)"1"b, /* 19-24 */ "0"b, /* 25 */ "0"b, /* 26 */ "1"b, /* 27 */ (2) (1)"1"b, /* 28-29 */ (8) (1)"0"b, /* 30-37 */ "1"b, /* 38 */ "0"b, /* 39 */ (2) (1)"1"b, /* 40-41 */ (2) (1)"0"b, /* 42-43 */ (2) (1)"1"b, /* 44-45 */ "0"b, /* 46 */ "1"b, /* 47 */ (3) (1)"0"b, /* 48-50 */ "1"b, /* 51 */ (4) (1)"0"b), /* 52-55 */ 2 message char (100) var init ("", /* 1 */ "CMF is empty.", /* 2 */ "Unrecognizable statement.", /* 3 */ "Syntax error.", /* 4 */ "Premature end of CMF encountered. Check for a missing end statement.", /* 5 */ "^a ^a", /* MSG is from cdt_mgr_ */ /* 6 */ "Premature end of CMF during attribute statement.", /* 7 */ "Invalid terminal type ""^a"".", /* 8 */ "Too many channels declared in CMF. Maximum is ^a.", /* 9 */ "Invalid access class ""^a"".", /* 10 */ "Invalid line type ""^a"".", /* 11 */ "Invalid charge ""^a""", /* 12 */ "Channel ^a is specified more than once in the CMF.", /* 13 */ "Invalid attribute ""^a"".", /* 14 */ "Syntax error. The ""none"" attribute must be followed by a semi-colon.", /* 15 */ "Invalid service type ""^a"".", /* 16 */ """^a"" appears to have the wrong line type. ARPANET channels must specify 'line_type: ^a;'", /* 17 */ "The comment for ""^a"" contains non-printing ASCII characters.", /* 18 */ "Invalid FNP type ""^a"".", /* 19 */ "Invalid FNP memory size ""^a"".", /* 20 */ """^a"" is not a valid lsla/hsla count.", /* 21 */ "Syntax error. No image specified.", /* 22 */ "Invalid FNP identifier ""^a"".", /* 23 */ "FNP ^a is specified more than once.", /* 24 */ "Fatal error while threading CDT tree. ^a ^a.", /* 25 */ "Premature of CMF while in check_acs statement.", /* 26 */ "Unrecognized check acs flag ""^a"".", /* 27 */ """^a"" is not a valid channel name.", /* 28 */ """^a"" is not a valid baud rate.", /* 29 */ "NOT USED", /* 30 */ "NOT USED", /* 31 */ "NOT USED", /* 32 */ "NOT USED", /* 33 */ "NOT USED", /* 34 */ "NOT USED", /* 35 */ "NOT USED", /* 36 */ "NOT USED", /* 37 */ "Invalid dataset type ""^a"".", /* 38 */ "NOT USED", /* 39 */ "Unrecognized dataset option. ""^a""", /* 40 */ "Unrecognized line_type option. ""^a""", /* 41 */ "NOT USED", /* 42 */ "NOT USED", /* 43 */ "Invalid FNP required up time ""^a"".", /* 44 */ "Invalid channel name pair ""^a"".", /* 45 */ "Terminal type ""^a"" not found in TTT.", /* 46 */ "Invalid spare channel count ""^a"".", /* 47 */ "Multiplexer type not specified for multiplexer ""^a"".", /* 48 */ "Neither initial command nor generic destination can be specified for multiplexer: ""^a"".", /* 49 */ "Multiplexer type specified for non-multiplexer channel ""^a"".", /* 50 */ "Illegal multiplexer type: ""^a"".", /* 51 */ "Channel ""^a"" configured, but its parent, ""^a"", is not configured as a multiplexer.", /* 52 */ "Channel ""^a"" configured, but its parent, ""^a"", is not.", /* 53 */ "Cannot find ""^a"" to check configuration of ""^a"".", /* 54 */ "Only one of initial command and generic destination may be specified: ""^a""."), /* 55 */ 2 brief_message char (20) var init ((7) (1)"", /* 1-7 */ "^a", /* 8 */ "", /* 9 */ (5) (1)"^a", /* 10-14 */ "", /* 15 */ (6) (1)"^a", /* 16-21 */ "", /* 22 */ (3) (1)"^a", /* 23-25 */ (2) (1)"FNP ^a ^a",/* 26-27 */ (24) (1)"^a", /* 28-51 */ (2) (1)"^a on ^a", /* 52-53 */ "^a for ^a", /* 54 */ "^a"); /* 55 */ /* ======================================================== */  cv_rtmf.rd 03/17/86 1521.0rew 03/17/86 1432.9 286110 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* CV_RTMF - Compile a Resource Type Master File into a Resource Type Description Table. */ /* Ripp'd untimely from the womb of cv_pmf on 03/10/78 by C. D. Tavares */ /* Modified 04/12/79 by CDT for precanonicalization of resource names */ /* Modified 8/81 by M.R. Jordan for Time: open; and change error 19 severity */ /* Modified January 1982 BIM for author changes. */ /* Modified July 1982 by E. N. Kittlitz for [severity] and rtmf suffix. */ /*++ BEGIN /Device : ; /LEX (2) open [auto_rtde.name = token_value] LEX (2) / stmt \ /Volume : ; /LEX (2) open [auto_rtde.name = token_value; auto_rtde.is_volume = "1"b] LEX (2) / stmt \ / /ERROR (19) / RETURN \ / /ERROR (19) / RETURN \ stmt /end ; /close LEX (2) / RETURN \ /Device : ; /LEX (2) close open [auto_rtde.name = token_value] LEX (2) / stmt \ /Volume : ; /LEX (2) close open [auto_rtde.name = token_value; auto_rtde.is_volume = "1"b] LEX (2) / stmt \ /Attribute_domain : ; / LEX (3) [auto_rtde.n_defined_attributes = 0] / stmt \ /Attribute_domain : /LEX (2) [attr_type = Defined] PUSH (stmt) / atts \ /Limit : open ; /LEX (4) / stmt \ /Limit : ; /LEX (2) [auto_rtde.process_limit = token.Nvalue] LEX (2) / stmt \ /Time : , ; /LEX (2) [auto_rtde.default_time = token.Nvalue] LEX (2) [auto_rtde.max_time = token.Nvalue] LEX (2) / stmt \ /Time : ; /LEX (2) [auto_rtde.default_time = token.Nvalue] LEX (2) / stmt \ /Time : open ; /LEX (4) [auto_rtde.default_time = FOREVER] / stmt \ /Advance_notice : none ; /LEX (4) [auto_rtde.advance_notice_time = -1] / stmt \ /Advance_notice : ; /LEX (2) [auto_rtde.advance_notice_time = token.Nvalue] LEX (2) / stmt \ /Manual_clear : ; /LEX (2) [auto_rtde.manual_clear = (token_value = "yes")] LEX (2) / stmt \ /Implies : ; /LEX (2) [auto_rtde.n_mates = 1; auto_rtde.mates (1) = token_value] LEX (2) / stmt \ /Accepts : ; /LEX (3) [auto_rtde.n_mates = 0] / stmt \ /Accepts : /LEX (2) [matei = 0] / mates \ /Like : ; /LEX (2) [auto_rtde.is_synonym = "1"b; auto_rtde.n_mates = 0; auto_rtde.syn_to = token_value;] LEX (2) / stmt \ /Canonicalizer : ; /LEX (3) / stmt \ /Canonicalizer : ; /LEX (2) [auto_rtde.precanon_proc = token_value;] LEX (2) / stmt \ /Canonicalizer : /LEX (2) ERROR (4) NEXT_STMT / stmt \ /charge_type : ; /LEX (2) [auto_rtde.registration_defaults.charge_type = find_charge_type (); auto_rtde.registration_defaults.charge_type_given = "1"b] LEX (2) / stmt \ /potential_attributes : ; /LEX (3) [auto_rtde.registration_defaults.potential_attributes_given = "1"b] / stmt \ /potential_attributes : /LEX (2) [attr_type = Main_potential_defaults] PUSH (stmt) [auto_rtde.registration_defaults.potential_attributes_given = "1"b] / atts \ /attributes : ; /LEX (3) [auto_rtde.registration_defaults.attributes_given = "1"b] / stmt \ /attributes : /LEX (2) [attr_type = Main_defaults] PUSH (stmt) [auto_rtde.registration_defaults.attributes_given = "1"b] / atts \ /access_range : ; /LEX (2) [auto_rtde.registration_defaults.aim_range (*) = authorization_values (*); auto_rtde.registration_defaults.aim_range_given = "1"b] LEX (2) / stmt \ /access_range : /LEX (2) ERROR (17) NEXT_STMT / stmt \ /type : ; /LEX (2) [subi, auto_rtde.n_subtypes = auto_rtde.n_subtypes + 1; auto_rtde.subtype_name (subi) = token_value;] LEX (2) / subtype \ / /ERROR (2) NEXT_STMT / stmt \ / /ERROR (1) / RETURN \ subtype /charge_type : ; /LEX (2) [auto_rtde.subtype_defaults (subi).charge_type = find_charge_type (); auto_rtde.subtype_defaults (subi).charge_type_given = "1"b] LEX (2) / subtype \ /potential_attributes : ; /LEX (3) [auto_rtde.subtype_defaults (subi).potential_attributes_given = "1"b] / subtype \ /potential_attributes : /LEX (2) [attr_type = Subtype_potential_defaults] PUSH (subtype) [auto_rtde.subtype_defaults (subi).potential_attributes_given = "1"b] / atts \ /attributes : ; /LEX (3) [auto_rtde.subtype_defaults (subi).attributes_given = "1"b] / subtype \ /attributes : /LEX (2) [attr_type = Subtype_defaults] PUSH (subtype) [auto_rtde.subtype_defaults (subi).attributes_given = "1"b] / atts \ /access_range : ; /LEX (2) [auto_rtde.subtype_defaults (subi).aim_range (*) = authorization_values (*); auto_rtde.subtype_defaults (subi).aim_range_given = "1"b] LEX (2) / subtype \ /access_range : /LEX (2) ERROR (17) NEXT_STMT / stmt \ / / / stmt \ / /ERROR (1) / RETURN \ atts / , /add_attribute LEX (2) / atts \ / ; /add_attribute LEX (2) / STACK_POP \ / /ERROR (3) NEXT_STMT / STACK_POP \ / /ERROR (1) / RETURN \ mates / /[matei, auto_rtde.n_mates = matei + 1; auto_rtde.mates (matei) = token_value] LEX / matepunct \ / /ERROR (4) NEXT_STMT / stmt \ / /ERROR (1) / RETURN \ matepunct /, /LEX / mates \ /; /LEX / stmt \ / /ERROR (5) NEXT_STMT / stmt \ / /ERROR (1) / RETURN \ ++*/ /* format: style4 */ cv_rtmf: procedure; /* automatic */ dcl (APstmt, APtoken, areap, rtmfp) ptr; dcl 1 auto_rtde aligned automatic, 2 fixed_info like rtde.fixed_info aligned, 2 mates (6) char (32) aligned, 2 subtypes (32) like rtde.subtypes aligned; dcl 1 auto_ctt aligned, 2 n_charge_types fixed bin, 2 charge_types (100) char (32); dcl authorization_values (2) bit (72) aligned, access_ceiling bit (72) aligned; dcl attr_type fixed bin, (matei, subi) fixed bin, dn char (168), (supplied_en, rtmf_en, rtdt_en) char (32), entry_active bit (1) aligned, (i, j, k, n) fixed bin, time_now fixed bin (71), bitc fixed bin (24), target_name char (32), volume_ind bit (1), ap ptr, al fixed bin, arg based (ap) char (al), (ec, code) fixed bin (35); dcl created_table_segment bit (1) aligned; dcl (SYSTEM_LOW, SYSTEM_HIGH) bit (72) aligned, last_block_ptr pointer; dcl got_mandatory (100) bit (1) unaligned, mytoken char (256), temp_ptr pointer, loop_ptr pointer, found bit (1) aligned; dcl argc fixed bin; dcl argx fixed bin; dcl fb35 fixed bin (35); dcl 1 auto_token aligned automatic like token; /* based */ dcl bchr char (al) unal based (ap); /* builtin */ declare (addr, binary, collate, clock, dimension, divide, index, length, null, nullo, offset, pointer, rel, reverse, rtrim, size, string, substr, unspec, verify) builtin; /* conditions */ declare cleanup condition; /* entries */ dcl translator_temp_$get_segment entry (char (*) aligned, ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); dcl define_area_ ext entry (pointer, fixed bin (35)), ioa_$rsnnl ext entry options (variable), convert_authorization_$from_string entry (bit (72) aligned, char (*), fixed bin (35)), convert_authorization_$from_string_range entry ((2) bit (72) aligned, char (*), fixed bin (35)), system_info_$access_ceiling entry (bit (72) aligned), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cv_entry_ ext entry (char (*), pointer, fixed bin (35)) returns (entry), get_wdir_ entry () returns (char (168) aligned), get_group_id_ entry () returns (char (32) aligned), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), com_err_ entry options (variable), lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) var, char (*) var, char (*) var, char (*) var), lex_string_$lex entry (ptr, fixed bin, fixed bin, ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) var, char (*) var, char (*) var, char (*) var, ptr, ptr, fixed bin (35)); dcl com_err_$suppress_name entry () options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); /* internal static */ dcl (first bit (1) initial ("1"b), (Defined initial (0), Main_potential_defaults initial (1), Main_defaults initial (2), Subtype_potential_defaults initial (3), Subtype_defaults initial (4)) fixed bin, my_name char (8) aligned initial ("cv_rtmf"), (LEXDLM, LEXCTL) char (128) var, BREAKS char (128) var, IGBREAKS char (128) var) internal static; dcl FOREVER fixed bin initial (4880) static options (constant); /* external static */ dcl (error_table_$translation_failed, error_table_$badopt, error_table_$too_many_args, error_table_$seg_not_found, error_table_$no_ext_sym, error_table_$noentry, error_table_$noarg, error_table_$bad_conversion, error_table_$zero_length_seg) fixed bin (35) external static; dcl sys_info$max_seg_size fixed bin (18) external static; dcl cv_rtmf_severity_ fixed bin (35) external static init (0); /* include files */ %include rtdt; %include rcp_mandatories; %include area_info; %include access_mode_values; %include terminate_file; dcl 1 auto_area_info automatic like area_info aligned; /* program */ rtmfp = null; /* Initialize for cleanup handler */ rtdtp = null; /* .. */ areap = null; /* .. */ rtdep = null; dn, supplied_en, rtmf_en, rtdt_en = ""; created_table_segment = ""b; on cleanup begin; call clean_up; cv_rtmf_severity_ = 5; end; call cu_$arg_count (argc, ec); if ec ^= 0 then do; call com_err_ (ec, my_name); go to severity_5_failure; end; if argc = 0 then do; give_usage: call com_err_$suppress_name (ec, my_name, "Usage: cv_rtmf RTMF (-brief|-bf|-long|-lg)"); go to severity_5_failure; end; do argx = 1 to argc; call cu_$arg_ptr (argx, ap, al, ec); if character (bchr, 1) ^= "-" then do; if supplied_en ^= "" then do; call com_err_ (error_table_$too_many_args, my_name, "Only one pathname may be given. ^a was the second.", bchr); go to severity_5_failure; end; call expand_pathname_ (bchr, dn, supplied_en, ec); if ec ^= 0 then do; path_error: call com_err_ (ec, my_name, "^a", bchr); go to severity_5_failure; end; call expand_pathname_$add_suffix (bchr, "rtmf", dn, rtmf_en, ec); if ec ^= 0 then go to path_error; call suffixed_name_$new_suffix (supplied_en, "rtmf", "rtdt", rtdt_en, ec); /* if we get this far, how can we fail? */ if ec ^= 0 /* still, let's have a look */ then go to path_error; end; /* Pathname case */ else if bchr = "-bf" then SERROR_CONTROL = "01"b; else if bchr = "-brief" then SERROR_CONTROL = "01"b; else if bchr = "-long" | bchr = "-lg" then SERROR_CONTROL = "10"b; else if bchr = "-severity" | bchr = "-sv" then do; if argx >= argc then do; call com_err_ (error_table_$noarg, my_name, "After ""^a"".", bchr); go to severity_5_failure; end; argx = argx + 1; call cu_$arg_ptr (argx, ap, al, ec); fb35 = cv_dec_check_ (bchr, ec); if ec ^= 0 | fb35 < 0 | fb35 > 5 then do; call com_err_ (error_table_$bad_conversion, my_name, "Severity must be an integer in the range 0 - 5, not ""^a"".", bchr); go to severity_5_failure; end; MIN_PRINT_SEVERITY = fb35; end; else do; call com_err_ (error_table_$badopt, my_name, "^a", bchr); go to severity_5_failure; end; end; /* argument loop */ if supplied_en = "" then go to give_usage; call system_info_$access_ceiling (access_ceiling); time_now = clock; call initiate_file_ (dn, rtmf_en, R_ACCESS, rtmfp, bitc, ec); if ec = error_table_$noentry then if rtmf_en ^= supplied_en then do; call initiate_file_ (dn, supplied_en, R_ACCESS, rtmfp, bitc, ec); if ec = 0 then do; call com_err_ (0, my_name, "Warning: converting ^a. The segment should be named ^a.", pathname_ (dn, supplied_en), rtmf_en); rtmf_en = supplied_en; end; end; if ec ^= 0 then do; rtmf_error: call com_err_ (ec, my_name, "^a.", pathname_ (dn, rtmf_en)); go to severity_5_failure; end; n = divide (bitc + 8, 9, 24, 0); if n = 0 then do; ec = error_table_$zero_length_seg; go to rtmf_error; end; dn = get_wdir_ (); call hcs_$make_seg (dn, rtdt_en, "", 1010b, rtdtp, ec); created_table_segment = (ec = 0); if rtdtp = null then do; rtdt_error: call com_err_ (ec, my_name, "^a", pathname_ (dn, rtdt_en)); go to severity_5_failure; end; call hcs_$truncate_seg (rtdtp, 0, ec); if ec ^= 0 then go to rtdt_error; rtdt.author.proc_group_id = get_group_id_ (); /* Initialize the header of the new rtdt */ rtdt.author.table = "RTDT"; rtdt.author.w_dir = dn; rtdt.author.lock = ""b; rtdt.author.last_install_time = 0; rtdt.version = RTDT_version_3; rtdt.charge_type_table_ptr, rtdt.first_resource = nullo; last_block_ptr = null; RTDT_area_len = 0; RTDT_area_len = sys_info$max_seg_size - size (rtdt); /* "clever" in the worst sense of the word */ unspec (auto_area_info) = ""b; auto_area_info.version = area_info_version_1; auto_area_info.no_freeing, auto_area_info.dont_free = "1"b; auto_area_info.owner = my_name; auto_area_info.size = RTDT_area_len; auto_area_info.areap = addr (rtdt.rtdt_area); call define_area_ (addr (auto_area_info), ec); if ec ^= 0 then goto rtdt_error; auto_ctt.n_charge_types = 0; call convert_authorization_$from_string (SYSTEM_LOW, "system_low", code); if code ^= 0 then goto badacc; call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code); if code ^= 0 then do; badacc: call com_err_ (code, "cv_rtmf", "While converting canned access classes."); go to severity_5_failure; end; call translator_temp_$get_segment (my_name, areap, ec); if ec ^= 0 then do; call com_err_ (ec, my_name, "Getting temporary segment."); go to severity_5_failure; end; if first then do; BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "(),.:;"; IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24); call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL); first = "0"b; end; entry_active = ""b; call lex_string_$lex (rtmfp, n, 0, areap, "100"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, ec); Pthis_token = APtoken; call SEMANTIC_ANALYSIS (); abort: if MERROR_SEVERITY > 2 then do; call com_err_ (error_table_$translation_failed, my_name, rtmf_en); if created_table_segment then bitc = -1; /* delete it it we made the branch */ bitc = 0; /* otherwise just zap it */ end; else do; N_CHARGE_TYPES = auto_ctt.n_charge_types; allocate charge_type_table in (rtdt_area); unspec (charge_type_table) = unspec (auto_ctt); rtdt.charge_type_table_ptr = offset (cttp, rtdt.rtdt_area); /* Now perform a number of "gullibility checks" on each RTDE. */ Ptoken = addr (auto_token); /* hate to diddle with RDC databases, but... */ Pthis_token = Ptoken; Pstmt, token.Pstmt = null; token.line_no = 0; token.Pvalue = addr (mytoken); got_mandatory (*) = ""b; do loop_ptr = pointer (rtdt.first_resource, rtdt.rtdt_area) repeat (pointer (loop_ptr -> rtde.next_resource, rtdt.rtdt_area)) while (loop_ptr ^= null); rtdep = loop_ptr; if rtde.is_synonym then do; mytoken = rtde.name; target_name = rtde.syn_to; volume_ind = rtde.is_volume; found = ""b; do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area) repeat (pointer (rtde.next_resource, rtdt.rtdt_area)) while (rtdep ^= null & ^found); if rtde.name = target_name then do; found = "1"b; if rtde.is_synonym then call ERROR (Syn_chain); if rtde.is_volume ^= volume_ind then call ERROR (Device_syn_volume); end; end; if ^found then call ERROR (Syn_undefined); /* fell thru loop, lose. */ end; else do; /* Check to see if this is a mandatory resource name */ do i = 1 to dimension (rcp_mandatories.resource_name, 1) while (rtde.name ^= rcp_mandatories.resource_name (i)); end; if i <= dimension (rcp_mandatories.resource_name, 1) then do; got_mandatory (i) = "1"b; /* Make sure all mandatory attributes for this resource name are defined. */ do j = 1 to dimension (rcp_mandatories.attributes, 2) while (rcp_mandatories.attributes (i, j) ^= ""); do k = 1 to rtde.n_defined_attributes while (rtde.attribute_names (k) ^= rcp_mandatories.attributes (i, j)); end; if k > rtde.n_defined_attributes then do; call ioa_$rsnnl ("""^a"" for ""^a""", mytoken, token.Lvalue, rcp_mandatories.attributes (i, j), rtde.name); call ERROR (Mandatory_attr_missing); end; end; end; /* Now make sure the mates for this resource are "consenting". */ do i = 1 to rtde.n_mates; found = ""b; do temp_ptr = pointer (rtdt.first_resource, rtdt.rtdt_area) repeat (pointer (temp_ptr -> rtde.next_resource, rtdt.rtdt_area)) while ((temp_ptr ^= null) & ^found); if rtde.mates (i) = temp_ptr -> rtde.name then do; do j = 1 to temp_ptr -> rtde.n_mates while (temp_ptr -> rtde.mates (j) ^= rtde.name); end; if j > temp_ptr -> rtde.n_mates then do; call ioa_$rsnnl ("""^a"" and ""^a""", mytoken, token.Lvalue, temp_ptr -> rtde.name, rtde.name); call ERROR (Unrequited_mating); end; else if rtde.is_volume = temp_ptr -> rtde.is_volume then do; call ioa_$rsnnl ("""^a"" and ""^a""", mytoken, token.Lvalue, temp_ptr -> rtde.name, rtde.name); call ERROR (Mates_same_type); end; else found = "1"b; end; end; if ^found then do; call ioa_$rsnnl ("""^a"" for ""^a""", mytoken, token.Lvalue, rtde.mates (i), rtde.name); call ERROR (No_such_mate); end; end; end; end; do i = 1 to dimension (rcp_mandatories.resource_name, 1); if ^got_mandatory (i) then do; mytoken = rcp_mandatories.resource_name (i); token.Lvalue = length (rtrim (mytoken, " ")); call ERROR (Mandatory_resource_missing); end; end; /* Well, it SEEMS kosher enough, close it out. */ bitc = (binary (rel (addr (charge_type_table.flagword))) + 1) * 36; end; if bitc >= 0 then do; call terminate_file_ (rtdtp, bitc, TERM_FILE_TRUNC_BC_TERM, ec); if ec ^= 0 then do; call com_err_ (ec, my_name, "Unable to set bitcount on ^a to ^d.", pathname_ (dn, rtdt_en), bitc); go to severity_5_failure; end; end; call clean_up; cv_rtmf_severity_ = MERROR_SEVERITY; return; severity_5_failure: call clean_up; cv_rtmf_severity_ = 5; return; %page; clean_up: procedure; if rtmfp ^= null then call terminate_file_ (rtmfp, (0), TERM_FILE_TERM, (0)); if areap ^= null then call translator_temp_$release_all_segments (areap, (0)); if rtdtp ^= null then if created_table_segment then do; call hcs_$delentry_seg (rtdtp, (0)); rtdtp = null; end; call terminate_file_ (rtdtp, (0), TERM_FILE_TRUNC_BC_TERM, (0)); end clean_up; /* SYNTAX FUNCTIONS */ yes_no: proc returns (bit (1) aligned); return (token_value = "yes" | token_value = "no"); end yes_no; authorization_range: procedure () returns (bit (1) aligned); call convert_authorization_$from_string_range (authorization_values, token_value, code); return (code = 0); end authorization_range; canon_virtual_entry: proc () returns (bit (1) aligned); dcl entryvar entry variable; entryvar = cv_entry_ (rtrim (token_value), null, code); if (code = error_table_$seg_not_found) | (code = error_table_$no_ext_sym) then do; /* not fatal err, but warn him */ call ERROR (Canonicalizer_nonexistent); code = 0; end; return (code = 0); end canon_virtual_entry; /* SEMANTIC FUNCTIONS */ open: proc; unspec (auto_rtde) = ""b; auto_rtde.name, auto_rtde.precanon_proc, auto_rtde.attribute_names, auto_rtde.mates (*), auto_rtde.subtype_name (*) = ""; auto_rtde.n_defined_attributes, auto_rtde.process_limit, auto_rtde.n_mates, auto_rtde.advance_notice_time = -1; auto_rtde.default_time, auto_rtde.max_time = FOREVER; /* if that's not enough, hang it up. */ entry_active = "1"b; return; end open; find_charge_type: proc returns (fixed bin); dcl i fixed bin; do i = 1 to auto_ctt.n_charge_types while (auto_ctt.charge_types (i) ^= token_value); end; if i > auto_ctt.n_charge_types then do; auto_ctt.n_charge_types = i; auto_ctt.charge_types (i) = token_value; end; return (i); end find_charge_type; add_attribute: proc; dcl implies bit (1) aligned, i fixed bin, copy_token char (12) aligned; if substr (token_value, 1, 1) = "^" then do; call ERROR (Negative_attr); return; end; if substr (token_value, length (token_value), 1) = "*" then implies = "1"b; else implies = ""b; if length (token_value) > 12 + (binary (implies)) then call ERROR (Attr_too_long); if implies then copy_token = substr (token_value, 1, length (token_value) - 1); else copy_token = token_value; do i = 1 to auto_rtde.n_defined_attributes while (auto_rtde.attribute_names (i) ^= copy_token); end; if attr_type ^= Defined then if i > auto_rtde.n_defined_attributes then call ERROR (Undefined_attr); else ; else if i <= auto_rtde.n_defined_attributes then do; call ERROR (Multiply_dcl_attr); return; end; if attr_type = Defined then do; auto_rtde.attribute_names (i) = copy_token; if auto_rtde.is_volume then substr (auto_rtde.attributes_to_match, i, 1) = implies; else if implies then call ERROR (Starred_attribute); substr (auto_rtde.attributes_valid, i, 1) = "1"b; auto_rtde.n_defined_attributes = i; return; end; else if implies then call ERROR (Starred_attribute); if attr_type = Main_potential_defaults then substr (auto_rtde.registration_defaults.potential_attributes, i, 1) = "1"b; else if attr_type = Main_defaults then substr (auto_rtde.registration_defaults.attributes, i, 1) = "1"b; else if attr_type = Subtype_potential_defaults then substr (auto_rtde.subtype_defaults (subi).potential_attributes, i, 1) = "1"b; else substr (auto_rtde.subtype_defaults (subi).attributes, i, 1) = "1"b; return; end add_attribute; close: proc; dcl (j, prefidx) fixed bin; dcl save_Lvalue fixed bin (21), save_Pvalue pointer, fake_token_value char (128); dcl 1 effective_flags like rtde.registration_defaults.default_flags aligned automatic; dcl error_table_$out_of_sequence fixed bin (35) external static, sub_err_ ext entry options (variable); if ^entry_active then /* close called before open */ call sub_err_ (error_table_$out_of_sequence, "cv_rtmf", "s", null, 0, "Attempt to use an undefined RTDE."); if auto_rtde.name = "" then call ERROR (No_name); save_Lvalue = token.Lvalue; save_Pvalue = token.Pvalue; token.Pvalue = addr (auto_rtde.name); token.Lvalue = length (rtrim (auto_rtde.name, " ")); /* so error messages make sense */ if ^auto_rtde.is_synonym then do; /* don't bother checking syns */ if auto_rtde.n_mates = -1 then do; call ERROR (No_mates); auto_rtde.n_mates = 0; end; if auto_rtde.n_defined_attributes = -1 then call ERROR (No_Domain_stmt); if auto_rtde.n_defined_attributes = 0 then auto_rtde.registration_defaults.potential_attributes_given = "1"b; effective_flags = auto_rtde.registration_defaults.default_flags; if auto_rtde.n_subtypes = 0 then call validate_type (auto_rtde.registration_defaults, effective_flags); else do i = 1 to auto_rtde.n_subtypes; call ioa_$rsnnl ("""^a"" in ""^a""", fake_token_value, 0, auto_rtde.subtypes (i).subtype_name, auto_rtde.name); token.Pvalue = addr (fake_token_value); token.Lvalue = length (rtrim (fake_token_value, " ")); call validate_type (auto_rtde.subtype_defaults (i), effective_flags); end; /* Now construct the exclusion specs for all attributes of the type "name=". */ auto_rtde.n_exclusion_specs = 0; do i = 1 to auto_rtde.n_defined_attributes; prefidx = index (auto_rtde.attribute_names (i), "="); if prefidx > 0 then do; do j = 1 to auto_rtde.n_exclusion_specs while (substr (auto_rtde.exclusion_specs (j), i, 1) = ""b); end; if j > auto_rtde.n_exclusion_specs then do; auto_rtde.n_exclusion_specs = auto_rtde.n_exclusion_specs + 1; do j = i to auto_rtde.n_defined_attributes; if substr (auto_rtde.attribute_names (i), 1, prefidx) = substr (auto_rtde.attribute_names (j), 1, prefidx) then substr (auto_rtde.exclusion_specs (auto_rtde.n_exclusion_specs), j, 1) = "1"b; end; end; end; end; end; N_MATES = auto_rtde.n_mates; N_SUBTYPES = auto_rtde.n_subtypes; allocate rtde in (rtdt.rtdt_area); unspec (rtde.fixed_info) = unspec (auto_rtde.fixed_info); unspec (rtde.mates) = unspec (auto_rtde.mates); unspec (rtde.subtypes) = unspec (auto_rtde.subtypes); rtde.next_resource = nullo; rtde.valid = "1"b; if last_block_ptr = null then rtdt.first_resource = offset (rtdep, rtdt.rtdt_area); else last_block_ptr -> rtde.next_resource = offset (rtdep, rtdt.rtdt_area); last_block_ptr = rtdep; token.Pvalue = save_Pvalue; token.Lvalue = save_Lvalue; rtdep = null; /* catches bugs */ return; validate_type: proc (arg_struc, flag_struc); dcl 1 arg_struc parameter like rtde.registration_defaults aligned; dcl 1 flag_struc parameter like rtde.registration_defaults.default_flags aligned; dcl 1 temp_flags like rtde.registration_defaults.default_flags aligned automatic; temp_flags = effective_flags | arg_struc.default_flags; if ^string (temp_flags) = ""b then return; /* all are given */ if auto_rtde.n_defined_attributes > 0 then do; if ^temp_flags.potential_attributes_given then call ERROR (No_potential_attributes); if ^temp_flags.attributes_given then call ERROR (No_attributes); end; if ^temp_flags.aim_range_given then do; call ERROR (No_aim_range); arg_struc.aim_range = SYSTEM_LOW; end; if ^temp_flags.charge_type_given then call ERROR (No_charge_type); end validate_type; end close; dcl (Premature_EOF initial (1), Unrecognized initial (2), Bad_attribute_syntax initial (3), Bad_identifier initial (4), Bad_syntax initial (5), No_name initial (6), No_potential_attributes initial (7), No_mates initial (8), No_attributes initial (9), No_aim_range initial (10), Canonicalizer_nonexistent initial (11), No_charge_type initial (12), Undefined_attr initial (13), Multiply_dcl_attr initial (14), Negative_attr initial (15), Attr_too_long initial (16), Bad_access_class initial (17), No_Domain_stmt initial (18), Bad_first_stmt initial (19), Starred_attribute initial (20), Mandatory_attr_missing initial (21), Mandatory_resource_missing initial (22), Unrequited_mating initial (23), Mates_same_type initial (24), No_such_mate initial (25), Syn_undefined initial (26), Syn_chain initial (27), Device_syn_volume initial (28)) fixed bin static options (constant); dcl 1 error_control_table (28) aligned internal static options (constant), 2 severity fixed bin (17) unal init (4, (5) 3, (3) 1, 3, 1, (2) 3, 1, 3, (3) 3, 4, 1, (8) 3), 2 Soutput_stmt bit (1) unaligned initial ("0"b, (5) (1)"1"b, (4) (1)"0"b, "1"b, "0"b, (5) (1)"1"b, "0"b, (2) (1)"1"b, (8) (1)"0"b), 2 message char (100) var init ("Premature end of RTMF encountered.", /* 1 */ "Unrecognized keyword or invalid punctuation in recognized statement.", /* 2 */ "Improper syntax in attribute string.", /* 3 */ "Improper identifier ""^a"" in statement.", /* 4 */ "Improper syntax in statement.", /* 5 */ "No resource name supplied.", /* 6 */ "No potential attributes supplied for ^a.", /* 7 */ "No Implies or Accepts statement for ^a.", /* 8 */ "No attributes statement supplied for ^a; assuming null list.", /* 9 */ "No access range supplied for ^a-- assuming ""system_low : system_low"".", /* 10 */ "Specified canonicalization procedure does not seem to exist.", /* 11 */ "No charge type supplied for ^a.", /* 12 */ "Default attribute ""^a"" not defined in ""Attributes"" statement.", /* 13 */ "Attribute ""^a"" has been multiply declared.", /* 14 */ "Negated attributes such as ""^a"" serve no useful purpose.", /* 15 */ "Attribute name ""^a"" is too long.", /* 16 */ "Unrecognized access class ""^a"".", /* 17 */ "No Attribute_domain statement for ^a.", /* 18 */ "First statement is not Volume or Device statement.", /* 19 */ "Asterisk is only meaningful in volume potential attribute list.", /* 20 */ "Mandatory attribute ^a not defined.", /* 21 */ "Mandatory resource ^a not defined.", /* 22 */ "Resources ^a mate in one direction but not in the other.", /* 23 */ "Mating resources ^a are both devices or both volumes.", /* 24 */ "Undefined mate ^a.", /* 25 */ "Synonym reference for ^a is undefined.", /* 26 */ "Synonym ^a refers to another synonym.", /* 27 */ "Device and volume cannot be synonymous-- ^a"), /* 28 */ 2 brief_message char (30) var init ("Premature EOF.", /* 1 */ "Unrecognizable.", /* 2 */ "Syntax.", /* 3 */ "", /* 4 */ "Syntax.", /* 5 */ "No resource name.", /* 6 */ (12) (1)"^a.", /* 7-18 */ "No Device/Volume stmt.", /* 19 */ "Meaningless asterisk.", /* 20 */ (8) (1)"^a."); /* 21-28 */ /* ======================================================== */  cv_ttf.rd 10/17/88 1108.5rew 10/17/88 1029.4 1037781 /* *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* cv_ttf converts a terminal-type file (TTF) into a terminal-type table (TTT) which can then be installed using the install command. The cv_ttf command is generated by the reduction_compiler. Usage: cv_ttf TTF_NAME { -brief | -long } */ /* HISTORY COMMENTS: 1) change(77-05-20,RCoren), approve(), audit(), install(): Written Modified 04/25/78 by Robert S. Coren to add framing_chars Modified 05/03/78 by Robert S. Coren & David R. Vinograd to increase conversion/translation tables to 256 characters Modified May 1979 by Larry Johnson and Bernie Greenberg for extended tty-char support. Modified June 1979 by Bernie Greenberg for video features. Modified February/March 1980 by Larry Johnson to finish video features. Modified 5/29/81 by Suzanne Krupp to add function key information. Modified: 9 June 1981 by G. Palter to recognize can_type mode and replace X/Y with LINE/COLUMN in video sequences Modified January 1982 BIM for author changes. Modified April 1982 by Robert Coren for changes to baud_rates.incl.pl1. Modified July 1982 by E. N. Kittlitz for [severity], ttf suffix. Modified September 1984 by Robert Coren to reject var_tab_delays and horz_delays > 1.00. 2) change(86-09-21,Beattie), approve(86-09-21,MCR7542), audit(86-10-31,Brunelle), install(86-11-12,MR12.0-1211): Remove references to the 963 and 029 preaccess commands and remove support for ARDS, 202_ETX, 2741 and 1050 in system interfaces. 3) change(87-03-06,LJAdams), approve(87-04-03,MCR7646), audit(87-05-05,Gilcrease), install(87-05-08,MR12.1-1030): Added reduction to check the protocol field in the terminal type entry table. 4) change(87-05-21,LJAdams), approve(87-05-21,MCR7699), audit(87-07-31,Gilcrease), install(87-08-04,MR12.1-1055): Added support for MOWSE_FANSI protocol. Changed name of include file from terminal_type_protocols.incl.pl1 which was to long to term_type_protocols.incl.pl1 5) change(87-07-02,LJAdams), approve(87-07-13,MCR7742), audit(87-07-31,Gilcrease), install(87-08-04,MR12.1-1055): Added support for the reductions required by DSA. 6) change(88-01-25,Brunelle), approve(88-01-25,MCR7813), audit(88-10-13,Blair), install(88-10-17,MR12.2-1171): 1. Correct for repetition factors > 256 in initial_strings or additional_info. 2. Expand special chars to 15 chars from current limit of 3. 3. Add additional Global statements (including Input_suspend/resume, Output_suspend/resume, Buffer_size, Output_end_of_block, Output_acknowledge and Line_delimiter). 4. Remove Additional_info statement. 5. Correct problem of LIKE terminal_type loop. END HISTORY COMMENTS */ %page; /*++ \" REDUCTIONS FOR cv_ttf BEGIN / / ERROR (1) / RETURN \ \" Scan for main delimiting statements mainloop / terminal_type : / LEX (2) init_type LEX / type_entry \ / terminal_type : / LEX (2) NEXT_STMT / mainloop \ / conversion_table : ; / LEX (2) define_ct_table (CONV_TYPE) LEX (2) / table_entries \ / conversion_table : / LEX (2) NEXT_STMT / mainloop \ / translation_table : ; / LEX (2) define_ct_table (TRANS_TYPE) LEX (2) / table_entries \ / translation_table : / LEX (2) NEXT_STMT / mainloop \ / special_table : ; / LEX (2) define_special LEX (2) / special_entries \ / special_table : / LEX (2) NEXT_STMT / mainloop \ / function_key_table : ; / LEX (2) define_fkey_table LEX (2) / fkey_entries \ / function_key_table : / LEX (2) NEXT_STMT / mainloop \ / default_types : / LEX (2) [default_count = 1] / default_types \ / answerback : / LEX (2) set_up_answerback / answerback \ / preaccess_command : / LEX (2) / preaccess \ \" \" global statements / Modes : / LEX (2) PUSH (mainloop) PUSH (dft_modes) / check_modes \ / Bauds : / LEX (2) [baudx = 1] / default_bauds \ / Bps : / LEX (2) [baudx = 1] / default_bauds \ / BPS : / LEX (2) [baudx = 1] / default_bauds \ / Cps : / LEX (2) [baudx = 1] / default_cps \ / CPS : / LEX (2) [baudx = 1] / default_cps \ / Line_types : / LEX (2) PUSH (mainloop) PUSH (dft_line_types) / line_types \ / Erase : ; / LEX (2) [dft.erase = make_char ()] LEX (2) / mainloop \ / Erase : / LEX (2) ERROR (3) NEXT_STMT / mainloop \ / Kill : ; / LEX (2) [dft.kill = make_char ()] LEX (2) / mainloop \ / Kill : / LEX (2) ERROR (3) NEXT_STMT / mainloop \ / Framing_chars : ; / LEX (2) [dft.frame_begin = make_char ()] LEX [dft.frame_end = make_char ()] LEX (2) / mainloop \ / Framing_chars : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Line_delimiter : ; / LEX (2) [dft.line_delimiter = make_char ()] LEX (2) / mainloop \ / Line_delimiter : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Input_suspend : ; / LEX (2) [dft.input_suspend = make_char ()] LEX (2) / mainloop \ / Input_suspend : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Input_resume : ; / LEX (2) [dft.input_resume = make_char ()] LEX (2) / mainloop \ / Input_resume : , timeout ; / LEX (2) [dft.input_resume = make_char (); dft.input_timeout = "1"b] LEX (4) / mainloop \ / Input_resume : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Output_suspend : ; / LEX (2) [if dft.output_block_acknowledge then call ERROR (42); else do; dft.output_suspend_etb = make_char (); dft.output_block_acknowledge = "0"b; out_sus_set = "1"b; end] LEX (2) / mainloop \ / Output_suspend : / LEX (2) ERROR (6) LEX (2) / mainloop \ / Output_resume : ; / LEX (2) [if dft.output_block_acknowledge then call ERROR (42); else do; dft.output_resume_ack = make_char (); dft.output_block_acknowledge = "0"b; out_sus_set = "1"b; end] LEX (2) / mainloop \ / Output_resume : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Buffer_size : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; dft.output_buffer_size = token.Nvalue; dft.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / mainloop \ / Buffer_size : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Output_end_of_block : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; dft.output_suspend_etb = make_char (); dft.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / mainloop \ / Output_end_of_block : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Output_acknowledge : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; dft.output_resume_ack = make_char (); dft.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / mainloop \ / Output_acknowledge : / LEX (2) ERROR (6) NEXT_STMT / mainloop \ / Keyboard_addressing : / LEX (2) [bitp = addr (dft.keyboard_addressing)] PUSH (mainloop) / yes_no \ / Print_preaccess_message : / LEX (2) [bitp = addr (dft.print_preaccess_message)] PUSH (mainloop) / yes_no \ / Conditional_printer_off : / LEX (2) [bitp = addr (dft.conditional_printer_off)] PUSH (mainloop) / yes_no \ / Input_conversion : ; / LEX (3) [dft.input_conversion_rp = 0] / mainloop \ / Input_conversion : ; / LEX (2) set_table (dft.input_conversion_rp, CONV_TYPE) LEX (2) / mainloop \ / Output_conversion : ; / LEX (3) [dft.output_conversion_rp = 0] / mainloop \ / Output_conversion : ; / LEX (2) set_table (dft.output_conversion_rp, CONV_TYPE) LEX (2) / mainloop \ / Input_translation : ; / LEX (3) [dft.input_translation_rp = 0] / mainloop \ / Input_translation : ; / LEX (2) set_table (dft.input_translation_rp, TRANS_TYPE) LEX (2) / mainloop \ / Output_translation : ; / LEX (3) [dft.output_translation_rp = 0] / mainloop \ / Output_translation : ; / LEX (2) set_table (dft.output_translation_rp, TRANS_TYPE) LEX (2) / mainloop \ / Special : ; / LEX (3) [dft.special_rp = 0] / mainloop \ / Special : ; / LEX (2) set_table (dft.special_rp, SPEC_TYPE) LEX (2) / mainloop \ / Function_keys : ; / LEX (3) [tte.fkey_rp = 0] / mainloop \ / Function_keys : ; / LEX (2) set_table (tte.fkey_rp, FKEY_TYPE) LEX (2) / mainloop \ / Video_info : ; / LEX (3) [dft_extended_tablesp -> extended_tables.tables_rp (VIDEO_RP) = 0] / mainloop \ / Video_info : / LEX (2) [extended_tablesp = dft_extended_tablesp] define_video [dft_extended_tables_defined = "1"b] PUSH (mainloop) / video_table \ / Dsatm_device : ; / LEX (3) [dft_extended_tablesp -> extended_tables.tables_rp (DSATM_DEVICE_RP) = 0] / mainloop \ / Dsatm_device : / LEX (2) [extended_tablesp = dft_extended_tablesp] define_dsatm_device [dft_extended_tables_defined = "1"b] PUSH (mainloop) / dsatm_device_table \ / Old_type : ; / LEX (2) [dft.old_type = token.Nvalue] LEX (2) / mainloop \ / end ; / LEX (2) / finish \ / : / ERROR (5) NEXT_STMT / mainloop \ / / ERROR (6) NEXT_STMT / mainloop \ / / ERROR (7) / RETURN \ \" terminal type entry statements type_entry / ; / LEX / type_statements \ / like ; / LEX copy_type LEX (2) / type_statements \ / / ERROR (6) NEXT_STMT / type_statements \ type_statements / modes : / LEX (2) PUSH (type_statements) PUSH (entry_modes) / check_modes \ / additional_info : / LEX (2) PUSH (type_statements) [p = addr (tte.additional_info)] / char_string \ / initial_string : / LEX (2) PUSH (type_statements) [p = addr (tte.initial_string)] / char_string \ / comment : / LEX (2) PUSH (type_statements) [p = addr (tte.comment)] / char_string \ / bauds : / LEX (2) [baudx = 1] / bauds \ / bps : / LEX (2) [baudx = 1] / bauds \ / cps : / LEX (2) [baudx = 1] / cps \ / vert_nl_delays : / LEX (2) [delayx = 1] / delays \ / horz_nl_delays : / LEX (2) [delayx = 2] / delays \ / const_tab_delays : / LEX (2) [delayx = 3] / delays \ / var_tab_delays : / LEX (2) [delayx = 4] / delays \ / backspace_delays : / LEX (2) [delayx = 5] / delays \ / vt_ff_delays : / LEX (2) [delayx = 6] / delays \ / line_types : / LEX (2) PUSH (type_statements) PUSH (entry_line_types) / line_types \ / erase : ; / LEX (2) [tte.erase = make_char ()] LEX (2) / type_statements \ / erase: / LEX (2) ERROR (3) NEXT_STMT / type_statements \ / kill : ; / LEX (2) [tte.kill = make_char ()] LEX (2) / type_statements \ / kill : / LEX (2) ERROR (3) NEXT_STMT / type_statements \ / framing_chars : ; / LEX (2) [tte.frame_begin = make_char ()] LEX [tte.frame_end = make_char ()] LEX (2) / type_statements \ / framing_chars : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / line_delimiter : ; / LEX (2) [tte.line_delimiter = make_char ()] LEX (2) / type_statements \ / line_delimiter : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / input_suspend : ; / LEX (2) [tte.input_suspend = make_char ()] LEX (2) / type_statements \ / input_suspend : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / input_resume : ; / LEX (2) [tte.input_resume = make_char ()] LEX (2) / type_statements \ / input_resume : , timeout ; / LEX (2) [tte.input_resume = make_char (); tte.input_timeout = "1"b] LEX (4) / type_statements \ / input_resume : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / output_suspend : ; / LEX (2) [if block_ack_set then call ERROR (42); else do; tte.output_suspend_etb = make_char (); tte.output_block_acknowledge = "0"b; out_sus_set = "1"b; end] LEX (2) / type_statements \ / output_suspend : / LEX (2) ERROR (6) LEX (2) / type_statements \ / output_resume : ; / LEX (2) [if block_ack_set then call ERROR (42); else do; tte.output_resume_ack = make_char (); tte.output_block_acknowledge = "0"b; out_sus_set = "1"b; end] LEX (2) / type_statements \ / output_resume : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / buffer_size : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; tte.output_buffer_size = token.Nvalue; tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / type_statements \ / buffer_size : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / output_end_of_block : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; tte.output_suspend_etb = make_char (); tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / type_statements \ / output_end_of_block : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / output_acknowledge : ; / LEX (2) [if out_sus_set then call ERROR (42); else do; tte.output_resume_ack = make_char (); tte.output_block_acknowledge = "1"b; block_ack_set = "1"b; end] LEX (2) / type_statements \ / output_acknowledge : / LEX (2) ERROR (6) NEXT_STMT / type_statements \ / keyboard_addressing : / LEX (2) [bitp = addr (tte.keyboard_addressing)] PUSH (type_statements) / yes_no \ / print_preaccess_message : / LEX (2) [bitp = addr (tte.print_preaccess_message)] PUSH (type_statements) / yes_no \ / conditional_printer_off : / LEX (2) [bitp = addr (tte.conditional_printer_off)] PUSH (type_statements) / yes_no \ / input_conversion : ; / LEX (3) [tte.input_conversion_rp = 0] / type_statements \ / input_conversion : ; / LEX (2) set_table (tte.input_conversion_rp, CONV_TYPE) LEX (2) / type_statements \ / output_conversion : ; / LEX (3) [tte.output_conversion_rp = 0] / type_statements \ / output_conversion : ; / LEX (2) set_table (tte.output_conversion_rp, CONV_TYPE) LEX (2) / type_statements \ / input_translation : ; / LEX (3) [tte.input_translation_rp = 0] / type_statements \ / input_translation : ; / LEX (2) set_table (tte.input_translation_rp, TRANS_TYPE) LEX (2) / type_statements \ / output_translation : ; / LEX (3) [tte.output_translation_rp = 0] / type_statements \ / output_translation : ; / LEX (2) set_table (tte.output_translation_rp, TRANS_TYPE) LEX (2) / type_statements \ / special : ; / LEX (3) [tte.special_rp = 0] / type_statements \ / special : ; / LEX (2) set_table (tte.special_rp, SPEC_TYPE) LEX (2) / type_statements \ / function_keys : ; / LEX (3) [tte.fkey_rp = 0] / type_statements \ / function_keys : ; / LEX (2) set_table(tte.fkey_rp, FKEY_TYPE) LEX(2) / type_statements \ / protocol : ; / LEX (3) [tte.protocol = 0] / type_statements \ / protocol : / LEX (2) [tte.protocol = get_protocol()] LEX(2) / type_statements \ / video_info : ; / LEX (3) set_extended [extended_tables.tables_rp (VIDEO_RP) = 0] / type_statements \ / video_info : / LEX (2) set_extended define_video PUSH (type_statements) / video_table \ / dsatm_device : ; / LEX (3) set_extended [extended_tables.tables_rp (DSATM_DEVICE_RP) = 0] / type_statements \ / dsatm_device : / LEX (2) set_extended define_dsatm_device PUSH (type_statements) / dsatm_device_table \ / old_type : ; / LEX (2) [tte.old_type = token.Nvalue] LEX (2) / type_statements \ / / finish_type / mainloop \ / / ERROR (7) / RETURN \ \" yes_no subroutine yes_no / yes ; / [bitp -> based_bit1 = "1"b] LEX (2) / STACK_POP \ / YES ; / [bitp -> based_bit1 = "1"b] LEX (2) / STACK_POP \ / no ; / [bitp -> based_bit1 = "0"b] LEX (2) / STACK_POP \ / NO ; / [bitp -> based_bit1 = "0"b] LEX (2) / STACK_POP \ / ; / ERROR (4) NEXT_STMT / STACK_POP \ / / ERROR (6) NEXT_STMT / STACK_POP \ / / ERROR (7) / RETURN \ \" default_bauds subroutine default_bauds / / [dft_bauds (baudx) = token.Nvalue; baudx = baudx + 1] LEX / default_bauds \ / / PUSH (default_bauds) / general_dft_baud \ general_dft_baud / other / [dft_bauds (baudx) = 0; baudx = baudx + 1] LEX / STACK_POP \ / ; / [n_dft_bauds = baudx - 1] LEX POP / mainloop \ / / ERROR (8) POP NEXT_STMT / mainloop \ / / ERROR (7) / RETURN \ default_cps / / [dft_bauds (baudx) = cps_baud_value; baudx = baudx + 1] LEX / default_cps \ / / PUSH (default_cps) / general_dft_baud \ \" bauds subroutine bauds / / make_delay_entry ((token.Nvalue)) [baudx = baudx + 1] LEX / bauds \ / / PUSH (bauds) / general_baud \ general_baud / other / make_delay_entry (0) LEX / STACK_POP \ / ; / LEX POP / type_statements \ / / ERROR (8) POP NEXT_STMT / type_statements \ / / ERROR (7) / RETURN \ cps / / make_delay_entry (cps_baud_value) [baudx = baudx + 1] LEX / cps \ / / PUSH (cps) / general_baud \ \" subroutine for initial_string, comment or additional_info char_string / ; / [p -> based_two_words (*) = 0] LEX / STACK_POP \ / ; / copy_string (p) LEX (2) / STACK_POP \ / / [exp_char_index, unexp_char_index = 1; rep_depth, expanded(*), unexpanded(*) = 0; rep_error, rep_used = "0"b;] / string_item \ string_item / / NEXT_STMT / STACK_POP \ / / insert_quoted_string LEX / string_item \ / / [ call insert_single_char ((token.Nvalue)) ] LEX / string_item \ / ( ) <_ / LEX push_rep LEX (3) / string_item \ / >_ / pop_rep LEX / string_item \ / ; / store_string (p) LEX / STACK_POP \ / / ERROR (6) NEXT_STMT / STACK_POP \ / / ERROR (7) / RETURN \ \" subroutine for delay statements delays / / [n_spec = 0; delay_error_printed = "0"b] / delay_token \ delay_token / / set_delay LEX / delay_token \ / ; / LEX / type_statements \ / / ERROR (9) NEXT_STMT / type_statements \ / / ERROR (7) / RETURN \ \" line_types subroutine line_types / ; / LEX / STACK_POP \ / / [line_type_str = ""b] / line_type_values \ line_type_values / / [substr (line_type_str, token.Nvalue, 1) = "1"b] LEX / next_line_type \ / / ERROR (10) NEXT_STMT / STACK_POP \ / / ERROR (7) / RETURN \ next_line_type / , / LEX / line_type_values \ / ; / LEX / STACK_POP \ entry_line_types / / [tte.line_types = line_type_str] / STACK_POP \ dft_line_types / / [dft.line_types = line_type_str] / STACK_POP \ \" subroutine to construct conversion/translation tables table_entries / / NEXT_STMT / mainloop \ / / [entryx = 0] / table_entry \ table_entry / / [if entryx > hbound (tablep -> cv_trans.value, 1) then call semant_error (11, cur_table_name, ""); else temp_table (entryx) = token.Nvalue; entryx = entryx + 1] LEX / table_entry \ / ; / [if entryx < 128 then call semant_error (12, cur_table_name, "")] LEX / mainloop \ / / semant_error (13, cur_table_name, token_value) NEXT_STMT / mainloop \ / / ERROR (7) / RETURN \ \" subroutine for constructing special_chars table special_entries / new_line : / LEX (2) [p = addr (temp_special_table.nl_seq)] PUSH (single_sequence) / sequence \ / carriage_return : / LEX (2) [p = addr (temp_special_table.cr_seq)] PUSH (single_sequence) / sequence \ / backspace : / LEX (2) [p = addr (temp_special_table.bs_seq)] PUSH (single_sequence) / sequence \ / tab : / LEX (2) [p = addr (temp_special_table.tab_seq)] PUSH (single_sequence) / sequence \ / vertical_tab : / LEX (2) [p = addr (temp_special_table.vt_seq)] PUSH (single_sequence) / sequence \ / form_feed : / LEX (2) [p = addr (temp_special_table.ff_seq)] PUSH (single_sequence) / sequence \ / printer_on : / LEX (2) [p = addr (temp_special_table.printer_on)] PUSH (single_sequence) / sequence \ / printer_off : / LEX (2) [p = addr (temp_special_table.printer_off)] PUSH (single_sequence) / sequence \ / red_shift : / LEX (2) [p = addr (temp_special_table.red_ribbon_shift)] PUSH (single_sequence) / sequence \ / black_shift : / LEX (2) [p = addr (temp_special_table.black_ribbon_shift)] PUSH (single_sequence) / sequence \ / end_of_page : / LEX (2) [p = addr (temp_special_table.end_of_page)] PUSH (single_sequence) / sequence \ / output_escapes : / LEX (2) [esc_p = addr (not_edited); not_edited (*) = 0] / output_escapes \ / edited_output_escapes : / LEX (2) [esc_p = addr (edited); edited (*) = 0] / output_escapes \ / input_escapes : / LEX (2) [count = 0] / input_escapes \ / / check_special / mainloop \ / / ERROR (7) / RETURN \ output_escapes / / [max_output_escapes = 0] / \ output_indicator / / PUSH (escape_sequences) [p = addr (esc_p -> escapes (token.Nvalue - 16)); max_output_escapes = max (max_output_escapes, token.Nvalue - 16)] LEX / sequence \ / / ERROR (14) NEXT_STMT / special_entries \ / / ERROR (7) / RETURN \ sequence / / NEXT_STMT [STACK_DEPTH = 0] / special_entries \ / / [count = 0] / sequence_values \ sequence_values / / [count = count + 1; if count > hbound (c_chars.chars, 1) then call ERROR (15); else addr (p -> c_chars.chars (count)) -> based_fb8 = token.Nvalue] LEX / sequence_values \ / / / STACK_POP \ / / ERROR (7) / RETURN \ escape_sequences / , / [p -> c_chars.count = count] LEX / output_indicator \ single_sequence / ; / [p -> c_chars.count = count] LEX / special_entries \ / / ERROR (16) NEXT_STMT / special_entries \ / / ERROR (7) / RETURN \ input_escapes / / NEXT_STMT / special_entries \ / / [count = count + 1; addr (input_escapes.str) -> fb8_array (count) = token.Nvalue] LEX / input_result \ input_esc_error / / ERROR (6) NEXT_STMT / special_entries \ / / ERROR (7) / RETURN \ input_result / / [addr (input_results.str) -> fb8_array (count) = token.Nvalue] LEX / next_esc \ / / / input_esc_error \ next_esc / , / LEX / input_escapes \ / ; / LEX [input_escapes.len = count] / special_entries \ / / / input_esc_error \ \" function_key_data table fkey_entries fkey_loop / home : / LEX (2) start_fkey_seq(addr(function_key_data.home(0))) / fkey_entry \ / left : / LEX (2) start_fkey_seq(addr(function_key_data.left(0))) / fkey_entry \ / right : / LEX (2) start_fkey_seq(addr(function_key_data.right(0))) / fkey_entry \ / up : / LEX (2) start_fkey_seq(addr(function_key_data.up(0))) / fkey_entry \ / down : / LEX (2) start_fkey_seq(addr(function_key_data.down(0))) / fkey_entry \ / key ( ) : / LEX (2) [token.Nvalue = bin(token_value, 35, 0)] init_fkey_area((token.Nvalue)) start_fkey_seq(addr(function_key_data.function_keys(token.Nvalue, 0))) LEX (3) / fkey_entry \ / / finish_fkey_table / mainloop \ / / ERROR (7) / RETURN \ fkey_entry / / statement_error(52, cur_table_name, "") NEXT_STMT / fkey_entries \ fkey_seq / / insert_quoted_string LEX / fkey_seq \ / / insert_single_char((token.Nvalue)) LEX / fkey_seq \ / , / end_fkey_seq LEX / fkey_entry \ / ; / end_fkey_seq LEX / fkey_entries \ / / ERROR (50) NEXT_STMT / fkey_entries \ / / ERROR (7) / RETURN \ \" default_types table default_types / / [temp_dftte (default_count).baud = token.Nvalue] LEX / dftt_line_type \ / any / [temp_dftte (default_count).baud = 0] LEX / dftt_line_type \ / / ERROR (8) LEX / dftt_line_type \ / / ERROR (7) / RETURN \ dftt_line_type / / [temp_dftte (default_count).line_type = token.Nvalue] LEX / dft_term_type \ / any / [temp_dftte (default_count).line_type = 0] LEX / dft_term_type \ / / ERROR (10) LEX / dft_term_type \ / / ERROR (7) / RETURN \ dft_term_type / / [temp_dftte (default_count).term_type_index = token.Nvalue] LEX / next_default \ / / [temp_dftte (default_count).type_name = token_value] LEX / next_default \ / / LEX / next_default \ next_default / , / [default_count = default_count + 1] LEX / default_types \ / ; / LEX [temp_dftt.dft_count = default_count] check_for_any / mainloop \ / / ERROR (6) NEXT_STMT / mainloop \ / / ERROR (7) / RETURN \ \" answerback table answerback / match / [answerback_entry.def_string.chars (ansbck_char_index) = "m"] LEX / match_string \ / search / [answerback_entry.def_string.chars (ansbck_char_index) = "s"] LEX / match_string \ / skip / LEX [answerback_entry.def_string.chars (ansbck_char_index) = "k"; addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Nvalue; ansbck_char_index = ansbck_char_index + 2] LEX / next_spec \ / id / LEX [answerback_entry.def_string.chars (ansbck_char_index) = "i"; addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Nvalue; ansbck_char_index = ansbck_char_index + 2] LEX / next_spec \ / id rest / [answerback_entry.def_string.chars (ansbck_char_index) = "i"; answerback_entry.def_string.chars (ansbck_char_index+1) = NUL_CHAR; ansbck_char_index = ansbck_char_index + 2] LEX (2) / next_spec \ ansbck_error / / ERROR (17) NEXT_STMT / ans_back_type \ / / ERROR (7) / RETURN \ match_string / / [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = token.Lvalue; substr (answerback_entry.def_string.chars (1), ansbck_char_index+2, token.Lvalue) = token_value; ansbck_char_index = ansbck_char_index + token.Lvalue + 2] LEX / next_spec \ / digit / [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = -2; ansbck_char_index = ansbck_char_index + 2] LEX / next_spec \ / letter / [addr (answerback_entry.def_string.chars (ansbck_char_index+1)) -> based_fb8 = -1; ansbck_char_index = ansbck_char_index + 2] LEX / next_spec \ / / ERROR (17) LEX / next_spec \ / / ERROR (7) / RETURN \ next_spec / , / LEX / answerback \ / ; / LEX [answerback_entry.def_string.length = ansbck_char_index - 1] / ans_back_type \ / / / ansbck_error \ ans_back_type / type : ; / LEX (3) / mainloop \ / type : ; / LEX (2) [answerback_entry.term_type_index = token.Nvalue] LEX (2) / mainloop \ / type : / LEX (2) ERROR (18) NEXT_STMT / mainloop \ / / / mainloop \ / / ERROR (7) / RETURN \ \"Video stuff 6/3/79 - BSG video_table video_loop / clear_screen : / LEX (2) start_vseq (CLEAR_SCREEN) / vseq \ / clear_to_eos : / LEX (2) start_vseq (CLEAR_TO_EOS) / vseq \ / home : / LEX (2) start_vseq (HOME) / vseq \ / clear_to_eol : / LEX (2) start_vseq (CLEAR_TO_EOL) / vseq \ / cursor_up : / LEX (2) start_vseq (CURSOR_UP) / vseq \ / cursor_right : / LEX (2) start_vseq (CURSOR_RIGHT) / vseq \ / cursor_down : / LEX (2) start_vseq (CURSOR_DOWN) / vseq \ / cursor_left : / LEX (2) start_vseq (CURSOR_LEFT) / vseq \ / insert_chars : / LEX (2) start_vseq (INSERT_CHARS) / vseq \ / end_insert_chars : / LEX (2) start_vseq (END_INSERT_CHARS) / vseq \ / delete_chars : / LEX (2) start_vseq (DELETE_CHARS) / vseq \ / insert_lines : / LEX (2) start_vseq (INSERT_LINES) / vseq \ / delete_lines : / LEX (2) start_vseq (DELETE_LINES) / vseq \ / abs_pos : / LEX (2) start_vseq (ABS_POS) / vseq \ / screen_height : ; / LEX (2) [tty_video_table.screen_height = token.Nvalue] LEX (2) / video_loop \ / screen_line_length : ; / LEX (2) [tty_video_table.screen_line_length = token.Nvalue] LEX (2) / video_loop \ / scroll_count : ; / LEX (2) [tty_video_table.scroll_count = token.Nvalue] LEX (2) / video_loop \ / / finish_video_table / STACK_POP \ / / ERROR (7) / RETURN \ vseq vseq_loop / / insert_quoted_string LEX / vseq_loop \ / ; / LEX end_vseq / video_loop \ / ( / LEX / vseq_numeric_expr \ / / insert_single_char ((token.Nvalue)) LEX / vseq_loop \ / , pad ms / LEX (2) video_encode_pad (1000 * token.Nvalue) LEX (2) / vseq_loop \ / , pad us / LEX (2) video_encode_pad ((token.Nvalue)) LEX (2) / vseq_loop \ / , pad / LEX (2) [tty_video_seq.flags.cpad_present, tty_video_seq.flags.cpad_in_chars = "1"b] [tty_video_seq.cpad = token.Nvalue] LEX / vseq_loop \ / / ERROR (48) NEXT_STMT / video_loop \ / / ERROR (7) / RETURN \ vseq_numeric_expr / / [unspec (temp_numeric_encoding) = "0"b] [temp_numeric_encoding.must_be_on = "1"b] / \ \" Open paren pre-parsed out / binary / LEX / vseq_numencode_1 \ / decimal / [temp_numeric_encoding.flags.express_in_decimal = "1"b] LEX [temp_numeric_encoding.num_digits = token.Nvalue] LEX / vseq_numencode_1 \ / decimal / LEX [temp_numeric_encoding.num_digits = 0] [temp_numeric_encoding.express_in_decimal = "1"b] / vseq_numencode_1 \ / octal / [temp_numeric_encoding.flags.express_in_octal = "1"b] LEX [temp_numeric_encoding.num_digits = token.Nvalue] LEX / vseq_numencode_1 \ / octal / LEX [temp_numeric_encoding.num_digits = 0] [temp_numeric_encoding.express_in_octal = "1"b] / vseq_numencode_1 \ vseq_numencode_1 / line / [temp_numeric_encoding.l_c_or_n = 0] LEX / vseq_numencode_2 \ / LINE / [temp_numeric_encoding.l_c_or_n = 0] LEX / vseq_numencode_2 \ / column / [temp_numeric_encoding.l_c_or_n = 1] LEX / vseq_numencode_2 \ / COLUMN / [temp_numeric_encoding.l_c_or_n = 1] LEX / vseq_numencode_2 \ / n / [temp_numeric_encoding.l_c_or_n = 2] LEX / vseq_numencode_2 \ / N / [temp_numeric_encoding.l_c_or_n = 2] LEX / vseq_numencode_2 \ / / ERROR (46) NEXT_STMT POP / video_loop \ / / ERROR (7) / RETURN \ vseq_numencode_2 / + / LEX [temp_numeric_encoding.offset = token.Nvalue] LEX / vseq_numencode_3 \ / - / LEX [temp_numeric_encoding.offset = - token.Nvalue] LEX / vseq_numencode_3 \ vseq_numencode_3 / ) / LEX [if temp_numeric_encoding.offset = 0 then temp_numeric_encoding.offset_is_0 = "1"b] / \ / / insert_single_char (bin (substr (unspec (temp_numeric_encoding), 1, 9))) [if ^temp_numeric_encoding.offset_is_0 then call insert_single_char (bin (substr (unspec (temp_numeric_encoding), 10, 9)))] [if temp_numeric_encoding.l_c_or_n = 2 then tty_video_seq.flags.able_to_repeat = "1"b] [tty_video_seq.flags.interpret = "1"b] / vseq_loop \ / / ERROR (46) NEXT_STMT POP / video_loop \ / / ERROR (7) / RETURN \ \"DSA TM stuff 12/21/84 Roger Negaret \" description of the negotiation information for a logical device dsatm_device_table dsatmdev_loop / data_presentation : ; / LEX (3) / dsatmdev_loop \ / data_presentation : / LEX (2) / dpp \ / sdp_class : ; / LEX (3) /dsatmdev_loop \ / sdp_class : / LEX (2) / sdp_class \ / real_class : ; / LEX (3) / dsatmdev_loop \ / real_class : / LEX (2) / real_class \ / device_id : ; / LEX (3) / dsatmdev_loop \ / device_id : ; / LEX (2) [dsatm_device.dev_id = token.Nvalue] LEX (2) / dsatmdev_loop \ / device_type : ; / LEX (3) / dsatmdev_loop \ / device_type : ; / LEX (2) [dsatm_device.dev_type = name_idx] LEX (2) / dsatmdev_loop \ / shareability : ; / LEX (3) / dsatmdev_loop \ / shareability : ; / LEX (2) [dsatm_device.shareability = name_idx] LEX (2) / dsatmdev_loop \ / allocation_unit : ; / LEX (3) / dsatmdev_loop \ / allocation_unit : / LEX (2) set_alloc_unit LEX / alloc_unit \ / line_overflow : ; / LEX (3) / dsatmdev_loop \ / line_overflow : ; / LEX (2) [dsatm_device.line_overflow = name_idx] LEX (2) / dsatmdev_loop \ / page_overflow : ; / LEX (3) / dsatmdev_loop \ / page_overflow : ; / LEX (2) [dsatm_device.page_overflow = name_idx] LEX (2) / dsatmdev_loop \ / character_encoding : ; / LEX (3) / dsatmdev_loop \ / character_encoding : / LEX (2) / char_encoding \ / character_set : ; / LEX (3) / dsatmdev_loop \ / character_set : / LEX (2) / char_set \ / character_subset : ; / LEX (3) / dsatmdev_loop \ / character_subset : / LEX (2) / char_subset \ / national_language : ; / LEX (3) / dsatmdev_loop \ / national_language: / LEX (2) / nat_lang \ / compression_algorithm : ; / LEX (3) / dsatmdev_loop \ / compression_algorithm : / LEX (2) / compression \ / character_font : ; / LEX (3) / dsatmdev_loop \ / character_font : / LEX (2) / char_font \ / max_record_size : ; / LEX (3) / dsatmdev_loop \ / max_record_size : ; / LEX (2) [dsatm_device.max_rec_size = token.Nvalue] LEX (2) / dsatmdev_loop \ / attd : ; / LEX (3) / dsatmdev_loop \ / attd : ; / LEX (4) / dsatmdev_loop \ / att1 : ; / LEX (3) / dsatmdev_loop \ / att1 : ; / LEX (4) / dsatmdev_loop \ / stc_available : / LEX (2) [bitp = addr (dsatm_device.stc_available)] PUSH (dsatmdev_loop) / yes_no \ / / finish_dsatm_device / STACK_POP \ / / ERROR (7) / RETURN \ dpp / ; / [dsatm_device.dpp_nb = dppx] LEX / dsatmdev_loop \ / / set_dpp LEX / dpp \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ sdp_class / ; / [dsatm_device.sc_nb = scx] LEX / dsatmdev_loop \ / / set_sdp_class LEX / sdp_class \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ real_class / ; / [dsatm_device.rc_nb = rcx] LEX / dsatmdev_loop \ / / set_real_class LEX / real_class \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ alloc_unit / ; / LEX / dsatmdev_loop \ / / set_alloc_unit LEX / alloc_unit \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ char_encoding / ; / [dsatm_device.ce_nb = cex] LEX / dsatmdev_loop \ / / set_char_encoding LEX / char_encoding \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ char_set / ; / [dsatm_device.cs_nb = csx] LEX / dsatmdev_loop \ / / set_char_set LEX / char_set \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ char_subset / ; / [dsatm_device.css_nb = cssx] LEX / dsatmdev_loop \ / / set_char_subset LEX / char_subset \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ char_font / ; / [dsatm_device.cf_nb = cfx] LEX / dsatmdev_loop \ / / set_char_font LEX / char_font \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ nat_lang / ; / [dsatm_device.nl_nb = nlx] LEX / dsatmdev_loop \ / / set_nat_lang LEX / nat_lang \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ compression / ; / [dsatm_device.ca_nb = cax] LEX / dsatmdev_loop \ / / set_compression LEX / compression \ / / ERROR (55) NEXT_STMT / dsatmdev_loop \ / / ERROR (7) / RETURN \ \" END of the DSA TM stuff \" preaccess command types preaccess / MAP ; / [p = addr (ttt.type_map); pa_type = 1] LEX (2) / preaccess_type \ / map ; / [p = addr (ttt.type_map); pa_type = 1] LEX (2) / preaccess_type \ / / ERROR (34) NEXT_STMT / mainloop \ / / ERROR (7) / RETURN \ preaccess_type / type : ; / LEX (2) [p -> based_fb = token.Nvalue] LEX (2) / mainloop \ / type : / LEX (2) ERROR (18) NEXT_STMT / mainloop \ / / semant_error (35, pa_name (pa_type), "") / mainloop \ / / ERROR (7) / RETURN \ \" mode checking check_modes / / [mode_string = ""] / \ / ; / LEX / STACK_POP \ next_mode / / [mode_string = mode_string || token_value] LEX / delim \ / / ERROR (2) [mode_string = mode_string || token_value] LEX / delim \ mode_err / / ERROR (7) / RETURN \ delim / , / [mode_string = mode_string || ","] LEX / next_mode \ / ; / LEX / STACK_POP \ / / ERROR (40) NEXT_STMT POP / STACK_POP \ / / / mode_err \ dft_modes / / [dft.modes = mode_string] / STACK_POP \ entry_modes / / [tte.modes = mode_string] / STACK_POP \ \" end statement handler finish / / ERROR (27) / RETURN \ / / / RETURN \ ++*/ %page; /* format: style4 */ cv_ttf: proc; /* External Entries */ dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl ioa_ entry options (variable); dcl lex_error_ entry options (variable); dcl lex_string_$init_lex_delims entry (char (*), char (*), char (*), char (*), char (*), bit (*), char (*) varying, char (*) varying, char (*) varying, char (*) varying); dcl lex_string_$lex entry (ptr, fixed bin (21), fixed bin (21), ptr, bit (*), char (*), char (*), char (*), char (*), char (*), char (*) varying, char (*) varying, char (*) varying, char (*) varying, ptr, ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl suffixed_name_$new_suffix entry (char (*), char (*), char (*), char (32), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl translator_temp_$get_segment entry (char (*), ptr, fixed bin (35)); dcl translator_temp_$release_all_segments entry (ptr, fixed bin (35)); /* External Static */ dcl cv_ttf_severity_ fixed bin (35) ext init (0); dcl dsatm_data_$device_multics_dft ext aligned; dcl (error_table_$badopt, error_table_$noentry, error_table_$too_many_args, error_table_$zero_length_seg, error_table_$noarg, error_table_$bad_conversion, error_table_$translation_failed) fixed bin (35) ext static; /* Internal Static */ dcl ALL_CAPS char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl ALL_LOWERCASE char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl BS char (1) int static options (constant) init (""); /* backspace */ dcl LEGAL_CHARS char (63) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_"); dcl NUL_CHAR char (1) int static options (constant) init (""); /* NUL char (all zero) */ dcl already_called bit (1) int static init ("0"b); dcl breaks char (43) varying int static; dcl ctl_chars char (32) varying int static; dcl lexctl char (80) varying int static; dcl lexdlm char (80) varying int static; dcl max_rep_depth fixed bin int static options (constant) init (2); dcl prog_name char (6) int static options (constant) init ("cv_ttf"); dcl translation_failure fixed bin int static options (constant) init (3); /* Automatic */ dcl ans_back_table_ptr ptr init (null ()); /* ptr to work area for answerback tables */ dcl ans_size fixed bin (18); /* # words in specific answerback table entry */ dcl ansbck_char_index fixed bin; /* used in storing parsed answerback entry */ dcl arg char (argl) based (argp); /* overlay for input arg */ dcl argc fixed bin; /* # input args */ dcl argl fixed bin; /* length of specific input arg */ dcl argp ptr; /* ptr to specific input arg */ dcl argx fixed bin; /* which input arg being processed */ dcl baud_error_printed bit (1); /* flag for single output of baud error statement */ dcl baudx fixed bin; /* baud table entry index */ dcl bit_count fixed bin (24); /* input TTF bit_count */ dcl bitp ptr init (null ()); /* misc bit string ptr */ dcl block_ack_set bit (1); /* flag to denote block ACK used in this type entry */ dcl cax fixed bin; /* used in dsatm_device coding (compression index) */ dcl cex fixed bin; /* used in dsatm_device coding (character encoding index) */ dcl cfx fixed bin; /* used in dsatm_device coding (character font index) */ dcl check_0nums bit (1); dcl code fixed bin (35); /* general error code */ dcl count fixed bin; /* c_chars.count temp counter */ dcl cps_baud_value fixed bin; /* equivalent of specified CPS expressed as bps */ dcl created_table_segment bit (1) aligned; /* flag to show cv_ttf created output TTT segment */ dcl cssx fixed bin; /* used in dsatm_device coding (character subset index) */ dcl csx fixed bin; /* used in dsatm_device coding (character set index) */ dcl ct_table_offset fixed bin (18); /* offset to next conversion table entry */ dcl cur_delay_value fixed bin; /* temp value of current delay value being processed */ dcl cur_table_name char (32); /* name of current table being processed */ dcl default_count fixed bin; /* counter for default_types temp entry */ dcl defined fixed bin; /* denotes new table name has entry for it in table_names */ dcl delay_error_printed bit (1); /* flag for single output of delay error statement */ dcl delay_stmt bit (1); /* flag to denote delay statement found */ dcl delayx fixed bin; /* delay table type index */ dcl dft_bauds (12) fixed bin; /* array of baud rates specified in Bauds statement */ dcl dft_extended_tables_defined bit (1); /* denotes have one or more default extended tables defined */ dcl dft_extended_tablesp ptr init (null ()); /* ptr to any default extended tables */ dcl dirname char (168); /* directory for input TTF */ dcl dppx fixed bin; /* used in dsatm_device coding */ dcl edited (1024) fixed bin; /* placeholders for output escape sequences */ dcl entryx fixed bin; /* count of entries in conversion/translation table */ dcl esc_p ptr init (null ()); /* ptr to special string to store edited/non-edited output escape values in */ dcl extended_tables_workp ptr init (null ()); /* ptr to work area for all extended tables */ dcl fb35 fixed bin (35); /* general fixed bin (35) storage value */ dcl fkey_table_offset fixed bin (18); /* offset to start next function key table at */ dcl fkey_tables_ptr ptr init (null ()); /* ptr to work area for function key tables */ dcl floating_delay_value float bin; /* general floating value for delay item */ dcl got_temps bit (1); /* flag to show have temp segments */ dcl highest fixed bin; dcl i fixed bin; dcl increment fixed bin (18); dcl j fixed bin; dcl length_in_words fixed bin; dcl line_type_str bit (72); dcl max_output_escapes fixed bin; dcl max_values char (2); dcl maxind fixed bin (8); dcl misc_relocs_count fixed bin; dcl misc_relocs_ptr ptr init (null ()); /* ptr to work area for all relocs */ dcl misc_tables_ptr ptr init (null ()); /* ptr to work area where will build all misc tables */ dcl mode_line_length fixed bin; dcl mode_page_length fixed bin; dcl mode_string char (256) varying; dcl n_answerbacks fixed bin; dcl n_dft_bauds fixed bin; dcl n_fkey_tables fixed bin; dcl n_spec fixed bin; /* number of delay values specified */ dcl n_special_tables fixed bin; dcl n_table_names fixed bin; dcl n_tables fixed bin; dcl name_idx fixed bin; dcl name_to_test_for char (32); /* translated name to check tables for */ dcl new_delay_table_ptr ptr init (null ()); dcl next_misc_offset fixed bin (18); dcl next_offset fixed bin (18); dcl nlx fixed bin; dcl not_edited (1024) fixed bin; dcl num_0nums fixed bin; dcl off_sw bit (1); dcl out_sus_set bit (1); dcl p ptr init (null ()); dcl pa_type fixed bin; dcl prev_ptr ptr init (null ()); dcl rcx fixed bin; dcl real_name char (32); dcl rep_depth fixed bin; dcl rep_error bit (1); dcl rep_factor (2) fixed bin; dcl rep_length fixed bin; dcl rep_start (2) fixed bin; dcl rep_used bit (1); dcl scx fixed bin; dcl seqs_index fixed bin; dcl size_of_ttt fixed bin (18); dcl sourcep ptr init (null ()); dcl spec_offset fixed bin (18); dcl special_tables_ptr ptr init (null ()); /* ptr to area where special tables will be built */ dcl specialp ptr init (null ()); dcl stmtp ptr init (null ()); dcl supplied_ename char (32); dcl table_names_ptr ptr init (null ()); /* ptr to work area for names of all tables */ dcl table_size fixed bin (18); dcl tables_ptr ptr init (null ()); /* ptr to work area for tables entries */ dcl targetp ptr init (null ()); dcl temp_dfttp ptr init (null ()); /* ptr to temp copy of dftt with type names */ dcl temp_strings_ptr ptr init (null ()); /* ptr to work area for all temp strings */ dcl temp_ptr (10) ptr init ((10) null ()); dcl temp_ttep ptr init (null ()); dcl tempp ptr init (null ()); dcl test_value char (8); dcl ttf_ename char (32); dcl ttfp ptr init (null ()); dcl ttt_ename char (32); dcl wdir char (168); dcl 1 dft aligned like tte; /* for default values */ dcl 1 input_escapes aligned, 2 len fixed bin (8) unal, 2 str char (128) unal; dcl 1 input_results aligned like input_escapes; /* Based */ dcl based_bit1 bit (1) based; dcl based_fb fixed bin based; dcl based_fb8 fixed bin (8) unal based; dcl based_fb17 fixed bin (17) unal based; dcl based_two_words (2) fixed bin based; dcl exp_string char (2048) based (addr (expanded)); dcl fb8_array (count) fixed bin (8) unal based; dcl misc_strings (next_misc_offset) fixed bin based; dcl temp_table (0:255) fixed bin (8) unal based (tablep); dcl unexp_string char (2048) based (addr (unexpanded)); dcl 1 dummy_dftte based aligned like dftt.dftte; /* for taking "size" of */ dcl 1 escapes (max_output_escapes) aligned based like c_chars; dcl 1 extended_tables_work aligned based (extended_tables_workp), 2 seqs char (4096), 2 table fixed bin (71); /* put a table here */ dcl 1 table_names (n_table_names) based (table_names_ptr) aligned, 2 name char (32) unal, 2 type fixed bin, /* 1 = conv/trans, 2 = special */ 2 offset fixed bin (18); /* -1 = undefined */ dcl misc_relocs (misc_relocs_count) ptr unal based (misc_relocs_ptr); dcl 1 temp_dftt based (temp_dfttp), /* temporary copy of dftt, with type names */ 2 dft_count fixed bin, 2 temp_dftte (0 refer (temp_dftt.dft_count)), 3 entry like dftt.dftte, 3 type_name char (32); dcl temp_key_index fixed bin; dcl temp_key_infop ptr init (null ()); dcl 1 temp_key_info (0:3) aligned based (temp_key_infop) like key_info; dcl 1 temp_special_table aligned based (tablep), 2 nl_seq aligned like c_chars, /* new-line sequence */ 2 cr_seq aligned like c_chars, /* carriage-return sequence */ 2 bs_seq aligned like c_chars, /* backspace sequence */ 2 tab_seq aligned like c_chars, /* horizontal tab sequence */ 2 vt_seq aligned like c_chars, /* vertical tab sequence */ 2 ff_seq aligned like c_chars, /* form-feed sequence */ 2 printer_on aligned like c_chars, /* printer-on sequence */ 2 printer_off aligned like c_chars, /* printer_off sequence */ 2 red_ribbon_shift aligned like c_chars, /* red ribbon shift sequence */ 2 black_ribbon_shift aligned like c_chars, /* black ribbon shift sequence */ 2 end_of_page aligned like c_chars, /* end-of-page warning sequence */ 2 escape_length fixed bin, /* number of escape sequences */ 2 not_edited_escapes (sc_escape_len refer (temp_special_table.escape_length)) like c_chars, /* use in ^edited mode */ 2 edited_escapes (sc_escape_len refer (temp_special_table.escape_length)) like c_chars, /* use in edited mode */ 2 input_escapes aligned, 3 len fixed bin (8) unaligned, /* length of string */ 3 str char (sc_input_escape_len refer (temp_special_table.input_escapes.len)) unaligned, /* escape sequence characters */ 2 input_results aligned, 3 pad bit (9) unaligned, /* so that strings will look the same */ 3 str char (sc_input_escape_len refer (temp_special_table.input_escapes.len)) unaligned; /* results of escape sequences */ dcl 1 temp_numeric_encoding unaligned like tty_numeric_encoding automatic; dcl 1 temp_strings aligned based (temp_strings_ptr), 2 exp_char_index fixed bin, 2 unexp_char_index fixed bin, 2 expanded (2048) fixed bin (8) unal, 2 unexpanded (2048) fixed bin (8) unal, 2 rep_item char (2048) varying; /* Conditions */ dcl (cleanup, conversion) condition; /* Builtins */ dcl (addr, addrel, baseno, bin, byte, char, collate, currentsize, dimension, divide, float, hbound, index, lbound, length, ltrim, max, mod, null, ptr, rank, rel, rtrim, size, substr, translate, unspec, verify) builtin; %page; %include access_mode_values; %page; %include author_dcl; %page; %include baud_rates; %page; %include dsatm_attn_fcn_info; %page; %include dsatm_negotiate_info; %page; %include dsatm_tty_modes; %page; %include function_key_data; %page; %include line_types; %page; %include term_type_protocols; %page; %include terminate_file; %page; %include ttt; %page; %include tty_can_types; %page; %include tty_mode_names; %page; %include tty_video_tables; %page; /* introductory setup */ ttfp, tttp, tempp, temp_ptr (*) = null; /* setup for clean_up */ dft_extended_tablesp = null; c_chars_ptr = null; /* make the compiler happy */ got_temps = ""b; created_table_segment = ""b; dirname, supplied_ename, ttf_ename, ttt_ename = ""; check_0nums = "0"b; on cleanup begin; call clean_up; cv_ttf_severity_ = 5; end; call cu_$arg_count (argc, code); if code ^= 0 then do; call com_err_ (code, prog_name); go to severity_5_failure; end; if argc < 1 then do; give_usage: call com_err_$suppress_name (0, prog_name, "Usage: cv_ttf ttf_name [-brief | -long]"); go to severity_5_failure; end; do argx = 1 to argc; call cu_$arg_ptr (argx, argp, argl, code); if char (arg, 1) ^= "-" then do; if supplied_ename ^= "" then do; call com_err_ (error_table_$too_many_args, prog_name, "Only one pathname may be given. ^a was the second.", arg); go to severity_5_failure; end; call expand_pathname_ (arg, dirname, supplied_ename, code); if code ^= 0 then do; path_error: call com_err_ (code, prog_name, "^a", arg); go to severity_5_failure; end; call expand_pathname_$add_suffix (arg, "ttf", dirname, ttf_ename, code); if code ^= 0 then go to path_error; call suffixed_name_$new_suffix (supplied_ename, "ttf", "ttt", ttt_ename, code); /* if we get this far, how can we fail? */ if code ^= 0 /* still, let's have a look */ then go to path_error; end; /* Pathname case */ else if arg = "-bf" | arg = "-brief" then SERROR_CONTROL = "01"b; else if arg = "-lg" | arg = "-long" then SERROR_CONTROL = "10"b; else if arg = "-ck1dig" then do; check_0nums = "1"b; /* they made me change the name from ck0num to ck1dig */ num_0nums = 0; end; else if arg = "-severity" | arg = "-sv" then do; if argx >= argc then do; call com_err_ (error_table_$noarg, prog_name, "After ""^a"".", arg); go to severity_5_failure; end; argx = argx + 1; call cu_$arg_ptr (argx, argp, argl, code); fb35 = cv_dec_check_ (arg, code); if code ^= 0 | fb35 < 0 | fb35 > 5 then do; call com_err_ (error_table_$bad_conversion, prog_name, "Severity must be an integer in the range 0 - 5, not ""^a"".", arg); go to severity_5_failure; end; MIN_PRINT_SEVERITY = fb35; end; else do; code = error_table_$badopt; arg_error: call com_err_ (code, prog_name, arg); go to severity_5_failure; end; end; /* argument processing loop */ if supplied_ename = "" then go to give_usage; /* initialize some variables */ n_tables, n_answerbacks, n_table_names, n_dft_bauds, ct_table_offset, spec_offset, fkey_table_offset, default_count = 0; dsatmdevp = null; next_misc_offset = 1; /* so that no valid offset will be zero */ call initiate_file_ (dirname, ttf_ename, R_ACCESS, ttfp, bit_count, code); if code = error_table_$noentry then if ttf_ename ^= supplied_ename then do; call initiate_file_ (dirname, supplied_ename, R_ACCESS, ttfp, bit_count, code); if code = 0 then do; call com_err_ (0, prog_name, "Warning: converting ^a. The segment should be named ^a.", pathname_ (dirname, supplied_ename), ttf_ename); ttf_ename = supplied_ename; end; end; if code ^= 0 then do; ttf_error: call com_err_ (code, prog_name, "^a.", pathname_ (dirname, ttf_ename)); go to severity_5_failure; end; if bit_count = 0 then do; code = error_table_$zero_length_seg; go to ttf_error; end; /* now create segment in which to build TTT */ wdir = get_wdir_ (); call hcs_$make_seg (wdir, ttt_ename, "", 01010b, tttp, code); created_table_segment = (code = 0); if tttp = null then go to ttt_error; call hcs_$truncate_seg (tttp, 0, code); /* start clean */ if code ^= 0 then do; ttt_error: call com_err_ (code, prog_name, ttt_ename); go to severity_5_failure; end; /* get a bunch of temporary segments for pieces of TTT */ call get_temp_segments_ (prog_name, temp_ptr, code); if code ^= 0 then do; call com_err_ (code, prog_name, "Creating temporary segments"); go to severity_5_failure; end; got_temps = "1"b; tables_ptr = temp_ptr (1); special_tables_ptr = temp_ptr (2); misc_tables_ptr = temp_ptr (3); ans_back_table_ptr = temp_ptr (4); table_names_ptr = temp_ptr (5); temp_dfttp = temp_ptr (6); extended_tables_workp = temp_ptr (7); misc_relocs_ptr = temp_ptr (8); fkey_tables_ptr = temp_ptr (9); temp_strings_ptr = temp_ptr (10); misc_relocs_count = 0; /* Set up TTT header */ ttt.author.proc_group_id = get_group_id_ (); ttt.last_install_time = 0; ttt.lock = ""b; ttt.author.table = "TTT"; ttt.author.w_dir = substr (wdir, 1, length (ttt.author.w_dir)); ttt.version = TTT_version_4; /* initialize default structure */ ttep = addr (ttt.tt_entries (1)); dft = tte; /* all zero */ dft.name = ""; dft.modes = ""; dft.protocol = 0; dft.line_types = (72)"1"b; /* all valid initially */ dft.erase = "#"; dft.kill = "@"; allocate extended_tables set (dft_extended_tablesp); dft_extended_tablesp -> extended_tables.tables_rp (*) = 0; dft_extended_tables_defined = "0"b; /* set up for lex_string_ */ call translator_temp_$get_segment (prog_name, tempp, code); if tempp = null then do; call com_err_ (code, prog_name, "From translator_temp_$get_segment"); go to severity_5_failure; end; if ^already_called then do; ctl_chars = substr (collate (), 1, 8) || substr (collate (), 10, 24); breaks = ctl_chars || "()<>*,:;"; call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, breaks, ctl_chars, lexdlm, lexctl); already_called = "1"b; end; call lex_string_$lex (ttfp, divide (bit_count, 9, 21, 0), 0, tempp, "1000"b, """", """", "/*", "*/", ";", breaks, ctl_chars, lexdlm, lexctl, stmtp, Pthis_token, code); /* Go to it! */ call SEMANTIC_ANALYSIS (); /* put everything together */ if MERROR_SEVERITY >= translation_failure then call com_err_ (error_table_$translation_failed, prog_name); else do; do i = 1 to n_table_names; /* append conv/trans tables to TTT */ if table_names (i).offset = -1 /* oops, this one was never defined */ then call semant_error (28, table_names (i).name, ""); else if table_names (i).type ^= SPEC_TYPE & table_names (i).type ^= FKEY_TYPE then do; n_tables = n_tables + 1; tablep = addr (ttt.tables (n_tables)); table_entry.name = table_names (i).name; table_entry.type = table_names (i).type; sourcep = ptr (tables_ptr, table_names (i).offset); table_entry.table = sourcep -> cv_trans_struc; table_names (i).offset = bin (rel (tablep), 18); /* update offset for later use */ end; end; ttt.n_tables = n_tables; /* now special tables */ specialp = addr (ttt.rest_of_ttt); next_offset = bin (rel (specialp), 18); n_special_tables = 0; do i = 1 to n_table_names; if table_names (i).type = SPEC_TYPE & table_names (i).offset ^= -1 then do; n_special_tables = n_special_tables + 1; specialp -> special_table.name = table_names (i).name; sourcep = ptr (special_tables_ptr, table_names (i).offset); specialp -> special_table.version = SPECIAL_VERSION_2; specialp -> special_table.default = 0; specialp -> special_table.table.special_chars = sourcep -> special_chars; table_names (i).offset = next_offset; table_size = divide (length (unspec (sourcep -> special_chars)) + 35, 36, 18, 0); next_offset = next_offset + table_size + 11; /* include name and header */ specialp = ptr (tttp, next_offset); end; end; ttt.n_special_tables = n_special_tables; /* now function key tables */ n_fkey_tables = 0; ttt.fkey_offset = next_offset; do i = 1 to n_table_names; if table_names (i).type = FKEY_TYPE & table_names (i).offset ^= -1 then do; n_fkey_tables = n_fkey_tables + 1; fkey_tablep = ptr (tttp, next_offset); function_key_data_ptr = ptr (fkey_tables_ptr, table_names (i).offset); fkey_table.name = table_names (i).name; fkey_table.version = function_key_data.version; fkey_table.highest = function_key_data.highest; fkey_table.cursor_motion_keys = function_key_data.cursor_motion_keys; fkey_table.function_keys = function_key_data.function_keys; sourcep = function_key_data.seq_ptr; /* move corresponding fkey sequences */ targetp = ptr (tttp, next_offset + currentsize (fkey_table)); targetp -> function_key_seqs = sourcep -> function_key_seqs; fkey_table.seq_offset = bin (rel (targetp)); fkey_table.seq_len = function_key_data.seq_len; table_names (i).offset = next_offset; next_offset = next_offset + currentsize (fkey_table) + currentsize (targetp -> function_key_seqs); end; end; ttt.n_fkey_tables = n_fkey_tables; increment = next_offset - 1; /* to be added to all relative ptrs in tte */ targetp = ptr (tttp, next_offset); /* pointer to next free spot in TTT */ misc_tables_ptr = addrel (misc_tables_ptr, 1); /* skip over first (unused) word */ next_misc_offset = next_misc_offset - 1; /* so size of array is right */ targetp -> misc_strings = misc_tables_ptr -> misc_strings; /* fill it in */ next_offset = next_offset + next_misc_offset; if default_count = 0 then do; ttt.default_type_offset = 0; call ERROR (32); end; else do; ttt.default_type_offset = next_offset; dfttp = ptr (tttp, next_offset); /* this is where we will put default_types table */ do i = 1 to default_count; dftte (i) = temp_dftte (i).entry; if temp_dftte (i).term_type_index = 0 /* default type specified before type defined */ then do; name_to_test_for = translate (temp_dftte (i).type_name, ALL_CAPS, ALL_LOWERCASE); do j = 1 to ttt.n_tt_entries; /* find it now */ ttep = addr (ttt.tt_entries (j)); if tte.name = name_to_test_for then go to found_match; end; if j > ttt.n_tt_entries then call semant_error (29, temp_dftte (i).type_name, ""); else found_match: dftte (i).term_type_index = j; end; end; dftt.dft_count = default_count; next_offset = next_offset + default_count * size (dummy_dftte) + 1; end; if n_answerbacks > 0 then ttt.answerback_offset = next_offset; else ttt.answerback_offset = 0; /* now append answerback table */ answerback_entry_ptr = ans_back_table_ptr; /* get pointer to base of temp seg */ do i = 1 to n_answerbacks; targetp = ptr (tttp, next_offset); if i > 1 /* not first one */ then prev_ptr -> answerback_entry.next = next_offset; answerback_length = answerback_entry.length; /* so refer will work when we assign it */ targetp -> answerback_entry = answerback_entry; ans_size = divide (answerback_length + 3, 4, 18, 0) + 3; /* total number of words in entry */ next_offset = next_offset + ans_size; answerback_entry_ptr = addrel (answerback_entry_ptr, ans_size); prev_ptr = targetp; end; size_of_ttt, ttt.total_ttt_size = next_offset; /* go through all entries. for each one, update the relative pointers, * and check for reasonable consistency between output_conversions and * special tables */ call perform_misc_relocs; highest = 0; do i = 1 to ttt.n_tt_entries; ttep = addr (ttt.tt_entries (i)); call set_table_offset (tte.input_translation_rp); call set_table_offset (tte.output_translation_rp); call set_table_offset (tte.input_conversion_rp); call set_table_offset (tte.output_conversion_rp); call set_table_offset (tte.special_rp); call set_table_offset (tte.fkey_rp); if tte.special_rp <= 0 /* no special table */ then if tte.output_conversion_rp > 0 /* but there is an output_conversion table */ then call semant_error (30, tte.name, ""); else ; /* it's all right not to have either */ else if tte.output_conversion_rp > 0 /* if we have both, cross-check */ then do; tablep = ptr (tttp, tte.output_conversion_rp); specialp = ptr (tttp, tte.special_rp); specialp = addr (specialp -> special_table.special_chars); maxind = table_entry.cv_trans.value (0); do j = 1 to hbound (tablep -> cv_trans.value, 1); /* make sure all indicators are represented by sequences */ if table_entry.cv_trans.value (j) > maxind then maxind = table_entry.cv_trans.value (j); end; if maxind > 16 /* any escape sequences at all */ then if maxind - 16 > specialp -> special_chars.escape_length then call semant_error (31, tte.name, table_entry.name); end; /* check for consistent framing characters */ if tte.frame_begin ^= NUL_CHAR & tte.frame_end = NUL_CHAR then call semant_error (41, tte.name, ""); /* check for consistent flow control specifications */ if tte.output_block_acknowledge then if tte.output_buffer_size = 0 | tte.output_suspend_etb = NUL_CHAR | tte.output_resume_ack = NUL_CHAR then call semant_error (43, tte.name, ""); else ; else if (tte.output_suspend_etb = NUL_CHAR & tte.output_resume_ack ^= NUL_CHAR) | (tte.output_suspend_etb ^= NUL_CHAR & tte.output_resume_ack = NUL_CHAR) then call semant_error (43, tte.name, ""); if (tte.input_suspend = NUL_CHAR & tte.input_resume ^= NUL_CHAR & ^tte.input_timeout) | (tte.input_suspend ^= NUL_CHAR & tte.input_resume = NUL_CHAR) then call semant_error (44, tte.name, ""); /* make sure coded type is reasonable in case this is site's first TTT */ highest, tte.coded_type = highest + 1; end; ttt.highest_coded_type = highest; /* if install/up_ttt_ is used, this will be overwritten */ if ttt.type_map = 0 then call semant_error (35, "MAP", ""); /* warn if preaccess types omitted */ /* essentially all done */ if check_0nums then if num_0nums > 0 then call com_err_ (0, prog_name, "^d incompatible character specification^[s^] found", num_0nums, num_0nums ^= 1); else call ioa_ ("No incompatible character specifications found."); if MERROR_SEVERITY >= translation_failure then do; call com_err_ (error_table_$translation_failed, prog_name); if created_table_segment then size_of_ttt = -1; else size_of_ttt = 0; end; if size_of_ttt >= 0 then do; call terminate_file_ (tttp, 36 * size_of_ttt, TERM_FILE_TRUNC_BC_TERM, code); if code ^= 0 then do; call com_err_ (code, prog_name, "Could not set bit count of TTT"); go to severity_5_failure; end; end; end; call clean_up; /* final wrapup */ cv_ttf_severity_ = MERROR_SEVERITY; return; severity_5_failure: call clean_up; cv_ttf_severity_ = 5; return; %page; clean_up: proc; /* cleanup handler -- makes sure anything we initiated gets terminated, anything we allocated gets freed */ if ttfp ^= null then call terminate_file_ (ttfp, (0), TERM_FILE_TERM, (0)); if tttp ^= null then if created_table_segment then do; call hcs_$delentry_seg (tttp, (0)); tttp = null; end; else call terminate_file_ (tttp, (0), TERM_FILE_TRUNC_BC_TERM, (0)); if tempp ^= null then call translator_temp_$release_all_segments (tempp, (0)); tempp = null; if got_temps then call release_temp_segments_ (prog_name, temp_ptr, code); got_temps = "0"b; if dft_extended_tablesp ^= null () then free dft_extended_tablesp -> extended_tables; return; end /* clean_up */; add_increment: proc (rp); /* internal procedure to add increment to offsets in misc_tables */ dcl rp fixed bin (18); /* input as offset in misc_tables, output as correct offset in TTT */ if rp <= 0 then return; /* no target */ else rp = rp + increment; return; end /* add_increment */; set_table_offset: proc (rp); /* internal procedure to set offsets in tte from table_names array */ dcl rp fixed bin (18); /* input as index in array, output as correct offset */ if rp <= 0 then return; /* no table, leave it alone */ else rp = table_names (rp).offset; return; end /* set_table_offset */; statement_error: proc (error_num, parm1, parm2); dcl error_num fixed bin; dcl parm1 char (*); dcl parm2 char (*); dcl (stmt_ptr, token_ptr) ptr init (null); stmt_ptr = token.Pstmt; token_ptr = Pthis_token; semant_error: entry (error_num, parm1, parm2); if error_control_table (error_num).severity >= MIN_PRINT_SEVERITY then call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)), MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL, (error_control_table.message (error_num)), (error_control_table.brief_message (error_num)), parm1, parm2); else do; MERROR_SEVERITY = max (MERROR_SEVERITY, error_control_table (error_num).severity); SERROR_PRINTED (error_num) = "1"b; end; return; end /* statement_error */; /* Syntax Functions */ /* returns TRUE if token contains upper/lower case, numeric or underscore */ legal_name: proc returns (bit (1) aligned); return (verify (token_value, LEGAL_CHARS) = 0); end legal_name; /* returns TRUE if legal name and token_value is either a new table name (defined = 0) or references a table which has not been filled in yet (defined = table index) */ new_table_name: proc returns (bit (1) aligned); if ^legal_name () then do; call statement_error (19, token_value, ""); return ("0"b); end; if token.Lvalue > 32 then do; call statement_error (39, token_value, ""); return ("0"b); end; do i = 1 to n_table_names; if table_names.name (i) = token_value then if table_names.offset (i) >= 0 then do; call statement_error (21, token_value, ""); return ("0"b); end; else do; defined = i; /* to be used by action routine */ return ("1"b); end; end; defined = 0; return ("1"b); end new_table_name; /* returns TRUE if legal name and not a currently defined terminal type */ new_type_name: proc returns (bit (1) aligned); if ^legal_name () then do; call statement_error (19, token_value, ""); return ("0"b); end; if token.Lvalue > 32 then do; call statement_error (39, token_value, ""); return ("0"b); end; name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do i = 1 to ttt.n_tt_entries; ttep = addr (ttt.tt_entries (i)); if tte.name = name_to_test_for then do; call statement_error (20, token_value, ""); return ("0"b); end; end; return ("1"b); end new_type_name; valid_mode: procedure () returns (bit (1) aligned); if substr (token_value, 1, 1) = "^" then do; test_value = substr (token_value, 2); off_sw = "1"b; end; else do; test_value = token_value; off_sw = "0"b; end; do i = lbound (modestr, 1) to hbound (modestr, 1);/* see if MCS value */ if modestr (i) = test_value then return ("1"b); end; do i = lbound (TTY_BOOLEAN_MODE_DSA_NAME, 1) to /* see if DSA value */ hbound (TTY_BOOLEAN_MODE_DSA_NAME, 1); if DSA_modestr (i) = test_value then return ("1"b); end; do i = lbound (CAN_TYPE_NAMES, 1) to hbound (CAN_TYPE_NAMES, 1); if token_value = CAN_TYPE_NAMES (i) then return ("1"b); end; if (test_value = "force") then /* either "force" or "^force" */ return ("1"b); if (token_value = "default") | (token_value = "init") then return ("1"b); /* these modes can't be negated */ if (substr (test_value, 1, 2) = "ll") then if (token.Lvalue <= 2) then return ("0"b); else do; if off_sw then do; if dsatmdevp = null () then mode_line_length = 0; else dsatm_device.line_length = 0; return ("1"b); end; else do; if substr (test_value, 3, 1) = "=" then i = cv_dec_check_ (substr (test_value, 4, token.Lvalue - 3), code); else i = cv_dec_check_ (substr (test_value, 3, token.Lvalue - 2), code); if code ^= 0 then return ("0"b); else do; if dsatmdevp = null () then mode_line_length = i; else dsatm_device.line_length = i; return ("1"b); end; end; end; if (substr (test_value, 1, 2) = "pl") then if (token.Lvalue <= 2) then return ("0"b); else do; if off_sw then do; if dsatmdevp = null () then mode_page_length = 0; else dsatm_device.page_length = 0; return ("1"b); end; else do; if substr (test_value, 3, 1) = "=" then i = cv_dec_check_ (substr (test_value, 4, token.Lvalue - 3), code); else i = cv_dec_check_ (substr (test_value, 3, token.Lvalue - 2), code); if code ^= 0 then return ("0"b); else do; if dsatmdevp = null () then mode_page_length = i; else dsatm_device.page_length = i; return ("1"b); end; end; end; return ("0"b); /* here iff not recognized */ end valid_mode; valid_edit: proc returns (bit (1) aligned); if tty_char () then return (token.Nvalue ^= rank (BS)); else return ("0"b); end /* valid_edit */; valid_baud: proc returns (bit (1) aligned); token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); do i = 1 to hbound (baud_table, 1); if token.Nvalue = baud_table (i) then return ("1"b); end; return ("0"b); end /* valid_baud */; valid_cps: proc returns (bit (1) aligned); token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if token.Nvalue = 10 then do; cps_baud_value = 110; return ("1"b); end; else do; cps_baud_value = token.Nvalue * 10; do i = 1 to hbound (baud_table, 1); if cps_baud_value = baud_table (i) then return ("1"b); end; return ("0"b); end; end /* valid_cps */; delay_value: proc returns (bit (1) aligned); /* floating point values 0.0 < X < 1.0 */ if delayx = 2 | delayx = 4 then do; on conversion go to bad_delay; floating_delay_value = float (token_value); revert conversion; if floating_delay_value < 0 | floating_delay_value > 1.0 then bad_delay: return ("0"b); else return ("1"b); end; /* fixed point values */ else do; token.Nvalue = cv_dec_check_ (token_value, code); if code ^= 0 then return ("0"b); if delayx = 1 | delayx = 5 then do; if token.Nvalue < -127 | token.Nvalue > 127 then return ("0"b); end; else if delayx = 3 then do; if token.Nvalue < 0 | token.Nvalue > 127 then return ("0"b); end; else if delayx = 6 then do; if token.Nvalue < 0 | token.Nvalue > 511 then return ("0"b); end; return ("1"b); end; end /* delay_value */; defined_type: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do i = 1 to ttt.n_tt_entries; temp_ttep = addr (ttt.tt_entries (i)); if temp_ttep -> tte.name = name_to_test_for then do; token.Nvalue = i; return ("1"b); end; end; return ("0"b); end /* defined_type */; valid_line_type: proc returns (bit (1) aligned); dcl lowest fixed bin; lowest = 1; go to check_line_type; valid_dft_line_type: entry returns (bit (1) aligned); lowest = -2; check_line_type: do i = lowest to max_line_type; if token_value = line_types (i) then do; token.Nvalue = i; return ("1"b); end; end; return ("0"b); end /* valid_line_type */; octal_char: proc returns (bit (1) aligned); if token.Lvalue > 3 then return ("0"b); token.Nvalue = cv_oct_check_ (token_value, code); return (code = 0); end /* octal_char */; tty_char: proc returns (bit (1) aligned); dcl i fixed bin; dcl asc_mnemonic char (3); dcl asc_value (0:32) char (3) static options (constant) init ("nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel", "bs ", "tab", "lf ", "vt ", "ff ", "cr ", "so ", "si ", "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb", "can", "em ", "sub", "esc", "fs ", "gs ", "rs ", "us ", "sp "); if token.quoted_string & token.Lvalue = 1 then call return_tty_char (bin (unspec (token_value))); if token.Lvalue = 1 then do; if index ("01234567", token_value) ^= 0 then do; if check_0nums then do; call ERROR (49); num_0nums = num_0nums + 1; if octal_char () then return ("1"b); end; end; if index (breaks, token_value) = 0 then call return_tty_char (bin (unspec (token_value))); end; if octal_char () then return ("1"b); if token.Lvalue = 2 & substr (token_value, 1, 1) = "^" then do; i = index ("@abcdefghijklmnopqrstuvwxyz[\]^_", substr (token_value, 2, 1)); if i = 0 then i = index ("@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_", substr (token_value, 2, 1)); if i = 0 then return ("0"b); call return_tty_char (i - 1); end; if token.Lvalue <= 3 then do; asc_mnemonic = translate (token_value, ALL_LOWERCASE, ALL_CAPS); if asc_mnemonic = "del" then call return_tty_char (127); if asc_mnemonic = "nl " then call return_tty_char (10); if asc_mnemonic = "pad" then call return_tty_char (0); if asc_mnemonic = "ht" then call return_tty_char (9); do i = lbound (asc_value, 1) to hbound (asc_value, 1); if asc_value (i) = asc_mnemonic then call return_tty_char (i); end; end; return ("0"b); return_tty_char: proc (a_value); dcl a_value fixed bin; token.Nvalue = a_value; go to nlret; end return_tty_char; nlret: return ("1"b); end tty_char; indicator_value: proc returns (bit (1) aligned); if ^octal_char () then return ("0"b); return (token.Nvalue > 16); end /* indicator_value */; no_table: proc returns (bit (1) aligned); return (tablep = null); end /* no_table */; rep_err_found: proc returns (bit (1) aligned); return (rep_error); end /* rep_err_found */; /* Syntax functions for function_key tables */ fkey_entry_err: proc returns (bit (1) aligned); if temp_key_index > KEY_CTRL_AND_SHIFT then return ("1"b); else return ("0"b); end fkey_entry_err; /* ACTION ROUTINES */ init_type: proc; /* set up a new terminal type entry */ mode_line_length, mode_page_length = -1; dsatmdevp = null (); ttt.n_tt_entries = ttt.n_tt_entries + 1; ttep = addr (ttt.tt_entries (ttt.n_tt_entries)); unspec (tte.tables) = "0"b; tte = dft; tte.name = translate (token_value, ALL_CAPS, ALL_LOWERCASE); baud_error_printed, delay_stmt, block_ack_set, out_sus_set = "0"b; if dft_extended_tables_defined then do; call set_extended; extended_tables = dft_extended_tablesp -> extended_tables; end; return; end /* init_type */; finish_type: proc; if tte.initial_string.offset ^= 0 then call register_misc_reloc (tte.initial_string.offset); if tte.additional_info.offset ^= 0 then call register_misc_reloc (tte.additional_info.offset); if tte.delay_rp ^= 0 then call register_misc_reloc (tte.delay_rp); if tte.extended_tables_rp ^= 0 then call register_misc_reloc (tte.extended_tables_rp); return; end finish_type; get_protocol: proc returns (fixed bin); do i = 1 to hbound (protocol_names, 1); if rtrim (token_value) = protocol_names (i) then return (protocol_values (i)); end; call ERROR (54); return (-1); end get_protocol; define_table: proc (table_type, a_ptr, next_offset); /* assign an offset to a table */ dcl table_type fixed bin; dcl a_ptr ptr; dcl next_offset fixed bin (18); if defined > 0 /* its name has been used */ then if table_names.type (defined) ^= table_type then do; /* wrong type */ call statement_error (22, token_value, table_types (table_names.type (defined))); tablep = null; return; end; else ; else do; defined, n_table_names = n_table_names + 1; table_names.name (defined) = token_value; table_names.type (defined) = table_type; end; table_names.offset (defined) = next_offset; cur_table_name = token_value; tablep = ptr (a_ptr, next_offset); return; end /* define_table */; define_ct_table: proc (table_type); dcl table_type fixed bin; call define_table (table_type, tables_ptr, ct_table_offset); if tablep = null then return; ct_table_offset = ct_table_offset + size (cv_trans) + 2; tablep -> cv_trans_struc.version = CV_TRANS_VERSION; tablep -> cv_trans_struc.default = 0; tablep = addrel (tablep, 2); return; end /* define_ct_table */; set_extended: proc; dcl i fixed bin; if tte.extended_tables_rp = 0 then do; extended_tablesp = get_misc_space (size (extended_tables)); tte.extended_tables_rp = bin (rel (extended_tablesp)); unspec (extended_tables) = "0"b; extended_tables.ntables = extended_tables_ntables; do i = 1 to extended_tables.ntables; call register_misc_reloc (extended_tables.tables_rp (i)); end; end; extended_tablesp = ptr (misc_tables_ptr, tte.extended_tables_rp); return; end set_extended; define_video: proc; ttyvtblp = addr (extended_tables_work.table); /* build a table here temporarily */ tty_video_table.nseq = N_VIDEO_SEQUENCES; tty_video_table.video_chars_len = 4096; /* to clear max space */ unspec (tty_video_table) = "0"b; tty_video_table.nseq = N_VIDEO_SEQUENCES; tty_video_table.version = tty_video_tables_version_1; extended_tables_work.seqs = ""; seqs_index = 0; return; end define_video; finish_video_table: proc; /* Make a lotta checks: abspos, screenlinelne, screenheight must be defined, abspos char syntax, extensions, */ dcl p ptr; tty_video_table.video_chars_len = seqs_index; if seqs_index > 0 then tty_video_table.video_chars = substr (extended_tables_work.seqs, 1, seqs_index); p = get_misc_space (currentsize (tty_video_table)); extended_tables.tables_rp (VIDEO_RP) = bin (rel (p)); p -> tty_video_table = tty_video_table; ttyvtblp = p; return; end finish_video_table; /* start define a new video sequence */ start_vseq: proc (a_seqn); dcl a_seqn fixed bin; ttyvseqp = addr (tty_video_table.sequences (a_seqn)); unspec (tty_video_seq) = "0"b; exp_char_index, unexp_char_index = 1; tty_video_seq.present = "1"b; return; end start_vseq; end_vseq: proc; if exp_char_index <= 1 then do; /* not really any sequence */ tty_video_seq.present = "0"b; return; end; tty_video_seq.len = exp_char_index - 1; tty_video_seq.seq_index = seqs_index + 1; seqs_index = seqs_index + tty_video_seq.len; substr (extended_tables_work.seqs, tty_video_seq.seq_index, tty_video_seq.len) = substr (exp_string, 1, tty_video_seq.len); return; end end_vseq; /* DSA stuffs */ define_dsatm_device: proc; dcl dftdevp ptr init (null ()); dsatmdevp = addr (extended_tables_work.table); /* build a table here temporarily */ /*** initialization with the structure defined in dsatm_data_ */ dftdevp = addr (dsatm_data_$device_multics_dft); dsatmdevp -> dsatm_device = dftdevp -> dsatm_device; /*** update of the line and page length from the modes statement */ if mode_line_length ^= -1 then dsatm_device.line_length = mode_line_length; if mode_page_length ^= -1 then dsatm_device.page_length = mode_page_length; /*** initialization of the internal variables */ dppx, scx, rcx, cex, csx, cssx, cfx, nlx, cax = 0; /*** initialization of dsatm_device structure */ dsatm_device.init_accept_confg = 0; dsatm_device.dpp (*) = 0; dsatm_device.sdp_dpp.version = 0; dsatm_device.sdp_dpp.sdp_class (*) = 0; dsatm_device.real_dpp.version = 0; dsatm_device.real_dpp.real_class (*) = 0; dsatm_device.real_dpp.real_model = ""; dsatm_device.trans_dpp.version = 0; dsatm_device.dev_id = 0; dsatm_device.dev_type = 0; dsatm_device.attribute.shareability = 0; dsatm_device.attribute.alloc_unit = "0"b; dsatm_device.line_length = 0; dsatm_device.page_length = 0; dsatm_device.line_overflow = 0; dsatm_device.page_overflow = 0; dsatm_device.char_encoding (*) = 0; dsatm_device.char_set (*) = 0; dsatm_device.char_subset (*) = 0; dsatm_device.nat_lang (*) = 0; dsatm_device.compression (*) = 0; dsatm_device.char_font (*) = 0; dsatm_device.terminal_type = ""; dsatm_device.ete_ack_level = 0; dsatm_device.max_rec_size = 0; unspec (dsatm_device.attentions) = "0"b; dsatm_device.stc_available = "0"b; unspec (dsatm_device.repetitive_parm_nb) = "0"b; unspec (dsatm_device.parm_rejected) = "0"b; return; end define_dsatm_device; legal_dpp: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (DPP_NAME, 1); if name_to_test_for = DPP_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_dpp: proc; dppx = dppx + 1; max_values = ltrim (char (hbound (dsatm_device.dpp, 1))); if dppx > hbound (dsatm_device.dpp, 1) then call statement_error (56, max_values, ""); dsatm_device.dpp (dppx) = name_idx; end; legal_sdp_class: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (SC_NAME, 1); if name_to_test_for = SC_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_sdp_class: proc; scx = scx + 1; max_values = ltrim (char (hbound (dsatm_device.sdp_dpp.sdp_class, 1))); if scx > hbound (dsatm_device.sdp_dpp.sdp_class, 1) then call statement_error (56, max_values, ""); dsatm_device.sdp_dpp.sdp_class (scx) = name_idx; end; legal_real_class: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (RC_NAME, 1); if name_to_test_for = RC_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_real_class: proc; rcx = rcx + 1; max_values = ltrim (char (hbound (dsatm_device.real_dpp.real_class, 1))); if rcx > hbound (dsatm_device.real_dpp.real_class, 1) then call statement_error (56, max_values, ""); dsatm_device.real_dpp.real_class (rcx) = name_idx; end; legal_dev_type: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 0 to hbound (DT_NAME, 1); if name_to_test_for = DT_NAME (name_idx) then return ("1"b); end; return ("0"b); end; legal_shareability: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (SH_NAME, 1); if name_to_test_for = SH_NAME (name_idx) then return ("1"b); end; return ("0"b); end; legal_alloc_unit: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (AU_NAME, 1); if name_to_test_for = AU_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_alloc_unit: proc; dsatm_device.alloc_unit = dsatm_device.alloc_unit | AU_VALUE (name_idx); end; legal_line_overflow: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 2 to hbound (LO_NAME, 1); if name_to_test_for = LO_NAME (name_idx) then return ("1"b); end; return ("0"b); end; legal_page_overflow: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 2 to hbound (PO_NAME, 1) - 1; if name_to_test_for = PO_NAME (name_idx) then return ("1"b); end; return ("0"b); end; legal_char_encoding: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (CE_NAME, 1); if name_to_test_for = CE_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_char_encoding: proc; cex = cex + 1; max_values = ltrim (char (hbound (dsatm_device.char_encoding, 1))); if cex > hbound (dsatm_device.char_encoding, 1) then call statement_error (56, max_values, ""); dsatm_device.char_encoding (cex) = name_idx; end; legal_char_set: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (CS_NAME, 1); if name_to_test_for = CS_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_char_set: proc; csx = csx + 1; max_values = ltrim (char (hbound (dsatm_device.char_set, 1))); if csx > hbound (dsatm_device.char_set, 1) then call statement_error (56, max_values, ""); dsatm_device.char_set (csx) = name_idx; end; legal_char_subset: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (CSS_NAME, 1); if name_to_test_for = CSS_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_char_subset: proc; cssx = cssx + 1; max_values = ltrim (char (hbound (dsatm_device.char_subset, 1))); if cssx > hbound (dsatm_device.char_subset, 1) then call statement_error (56, max_values, ""); dsatm_device.char_subset (cssx) = name_idx; end; legal_char_font: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (CF_NAME, 1); if name_to_test_for = CF_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_char_font: proc; cfx = cfx + 1; max_values = ltrim (char (hbound (dsatm_device.char_font, 1))); if cfx > hbound (dsatm_device.char_font, 1) then call statement_error (56, max_values, ""); dsatm_device.char_font (cfx) = name_idx; end; legal_nat_lang: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (NL_NAME, 1); if name_to_test_for = NL_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_nat_lang: proc; nlx = nlx + 1; max_values = ltrim (char (hbound (dsatm_device.nat_lang, 1))); if nlx > hbound (dsatm_device.nat_lang, 1) then call statement_error (56, max_values, ""); dsatm_device.nat_lang (nlx) = name_idx; end; legal_compression: proc returns (bit (1) aligned); name_to_test_for = translate (token_value, ALL_CAPS, ALL_LOWERCASE); do name_idx = 1 to hbound (CA_NAME, 1); if name_to_test_for = CA_NAME (name_idx) then return ("1"b); end; return ("0"b); end; set_compression: proc; cax = cax + 1; max_values = ltrim (char (hbound (dsatm_device.compression, 1))); if cax > hbound (dsatm_device.compression, 1) then call statement_error (56, max_values, ""); dsatm_device.compression (cax) = name_idx; end; legal_attd: proc returns (bit (1) aligned); dcl attx fixed bin; attx = 0; go to common; legal_att1: entry returns (bit (1) aligned); attx = 1; go to common; common: if /* case */ token_value = "BREAK" | token_value = "break" then dsatm_device.attentions.attn (attx).invocation.break = "1"b; else if token_value = "SEC_DIALOG" | token_value = "sec_dialog" then dsatm_device.attentions.attn (attx).invocation.sec_dialog = "1"b; else if tty_char () | (token.quoted_string & token.Lvalue = 2) then do; dsatm_device.attentions.attn (attx).invocation.string = "1"b; dsatm_device.attentions.attn (attx).string_value (1) = token_value; end; else return ("0"b); return ("1"b); end; finish_dsatm_device: proc; dcl p ptr; p = get_misc_space (currentsize (dsatm_device)); extended_tables.tables_rp (DSATM_DEVICE_RP) = bin (rel (p)); p -> dsatm_device = dsatm_device; dsatmdevp = p; return; end /* finish_dsatm_device */; define_special: proc; call define_table (SPEC_TYPE, special_tables_ptr, spec_offset); max_output_escapes, input_escapes.len = 0; return; end /* define_special */; check_special: proc; if tablep -> special_chars.nl_seq.count = 0 then call semant_error (23, table_names.name (defined), "new_line"); if tablep -> special_chars.cr_seq.count = 0 & tablep -> special_chars.bs_seq.count = 0 then call semant_error (23, table_names.name (defined), "carriage_return and backspace"); tablep -> special_chars.escape_length = max_output_escapes; tablep -> special_chars.not_edited_escapes = addr (not_edited) -> escapes; tablep -> special_chars.edited_escapes = addr (edited) -> escapes; tablep -> special_chars.input_escapes.len = input_escapes.len; tablep -> special_chars.input_escapes.str = input_escapes.str; tablep -> special_chars.input_results.str = input_results.str; length_in_words = divide (length (unspec (tablep -> special_chars)) + 35, 36, 17); spec_offset = spec_offset + length_in_words; return; end /* check_special */; copy_string: proc (targetp); dcl targetp ptr; dcl 1 target aligned based (targetp), 2 offset fixed bin (18), 2 len fixed bin; dcl stringp ptr; dcl stringl fixed bin; dcl target_string char (stringl) based aligned; dcl target_string_array (stringl) char (1) based; stringl = token.Lvalue + 2; stringp = get_misc_char_space (stringl); target.len = token.Lvalue; target.offset = bin (rel (stringp)); stringp -> target_string = token_value; addr (stringp -> target_string_array (stringl - 1)) -> based_fb17 = 0; return; end /* copy_string */; push_rep: proc; /* for starting repetition factors in string specifications */ if rep_depth >= max_rep_depth then do; call ERROR (37); rep_error = "1"b; return; end; if token.Nvalue <= 0 then do; call statement_error (36, token_value, ""); rep_error = "1"b; return; end; rep_depth = rep_depth + 1; rep_factor (rep_depth) = token.Nvalue; if token.Nvalue > 1 then do; rep_used = "1"b; addr (unexpanded (unexp_char_index)) -> based_fb17 = -token.Nvalue; unexp_char_index = unexp_char_index + 2; rep_start (rep_depth) = exp_char_index; end; return; end /* push_rep */; pop_rep: proc; /* processes ">" at end of repeated spec */ if rep_depth <= 0 then do; call ERROR (38); rep_error = "1"b; return; end; if rep_factor (rep_depth) > 1 then do; addr (unexpanded (unexp_char_index)) -> based_fb17 = -1; unexp_char_index = unexp_char_index + 2; rep_length = exp_char_index - rep_start (rep_depth); rep_item = substr (exp_string, rep_start (rep_depth), rep_length); do i = 2 to rep_factor (rep_depth); /* copy the string the requisite number of times */ substr (exp_string, exp_char_index, rep_length) = rep_item; exp_char_index = exp_char_index + rep_length; end; end; rep_depth = rep_depth - 1; return; end /* pop_rep */; insert_single_char: proc (n); dcl n fixed bin (18); expanded (exp_char_index) = n; unexpanded (unexp_char_index) = n; exp_char_index = exp_char_index + 1; unexp_char_index = unexp_char_index + 1; return; end insert_single_char; insert_quoted_string: proc; dcl i fixed bin; dcl c char (1); do i = 1 to token.Lvalue; c = substr (token_value, i, 1); call insert_single_char (rank (c)); end; return; end insert_quoted_string; video_encode_pad: proc (time); dcl time fixed bin (35); tty_video_seq.cpad_present = "1"b; if time < 100 then do; call ERROR (48); return; end; tty_video_seq.cpad = divide (time + 99, 100, 18, 0); return; end video_encode_pad; store_string: proc (targetp); /* sets up pointer and length of string specified in octal */ dcl targetp ptr; dcl 1 target based (targetp) aligned, 2 offset fixed bin (18), 2 len fixed bin; dcl target_string char (stringl) based; dcl target_string_array (stringl) char (1) based; dcl stringl fixed bin; dcl stringp ptr; if rep_depth ^= 0 then do; call ERROR (38); return; end; exp_char_index = exp_char_index - 1; unexp_char_index = unexp_char_index - 1; stringl = exp_char_index + 2; if rep_used then stringl = stringl + unexp_char_index; stringp = get_misc_char_space (stringl); target.len = exp_char_index; target.offset = bin (rel (stringp)); substr (stringp -> target_string, 1, exp_char_index) = substr (exp_string, 1, exp_char_index); if ^rep_used /* in this case, no need to store unexpanded version */ then addr (stringp -> target_string_array (exp_char_index + 1)) -> based_fb17 = -1; else do; addr (stringp -> target_string_array (exp_char_index + 1)) -> based_fb17 = unexp_char_index; substr (stringp -> target_string, exp_char_index + 3, unexp_char_index) = substr (unexp_string, 1, unexp_char_index); end; return; end /* store_string */; set_table: proc (target, table_type); dcl target fixed bin (18); dcl table_type fixed bin; do i = 1 to n_table_names; if table_names.name (i) = token_value then if table_names.type (i) ^= table_type then do; call statement_error (22, token_value, table_types (table_names.type (i))); target = 0; return; end; else do; target = i; /* use index into names table for now */ return; end; end; /* didn't find it, have to add entry */ n_table_names = i; /* i.e., n_tables_names + 1 */ table_names.name (n_table_names) = token_value; table_names.type (n_table_names) = table_type; table_names.offset (n_table_names) = -1; target = n_table_names; return; end /* set_table */; copy_type: proc; dcl hold_extended_tables_rp fixed bin (18); /* for like attribute */ temp_ttep = addr (ttt.tt_entries (token.Nvalue)); real_name = tte.name; /* hang on to name of new type */ hold_extended_tables_rp = tte.extended_tables_rp; tte = temp_ttep -> tte; tte.name = real_name; /* put correct name back */ tte.like_type = token.Nvalue; /* display_ttt needs this */ tte.bauds_overridden, tte.delay_overridden (*) = "0"b; if tte.extended_tables_rp ^= 0 then do; /* must have one of our own */ tte.extended_tables_rp = hold_extended_tables_rp; call set_extended; extended_tables = ptr (misc_tables_ptr, temp_ttep -> tte.extended_tables_rp) -> extended_tables; end; return; end /* copy_type */; make_delay_entry: proc (baud_rate); /* when a new baud rate specified, set up an array of delay values for it */ dcl baud_rate fixed bin; if delay_stmt then do; if ^baud_error_printed then do; call statement_error (24, tte.name, ""); baud_error_printed = "1"b; end; return; end; if baudx = 1 /* first one for this terminal type */ then do; tte.delay_rp = next_misc_offset; delay_tablep = ptr (misc_tables_ptr, next_misc_offset); next_misc_offset = next_misc_offset + 1; delay_table.n_bauds = 1; if tte.like_type ^= 0 then tte.bauds_overridden = "1"b; end; else delay_table.n_bauds = delay_table.n_bauds + 1; delay_table.baud_rate (delay_table.n_bauds) = baud_rate; delay_table.version (delay_table.n_bauds) = DELAY_VERSION; delay_table.mbz (delay_table.n_bauds) = 0; /* "default" word */ next_misc_offset = next_misc_offset + 9; /* for baud rate, version, default word, 6 delay values */ return; end /* make_delay_entry */; set_delay: proc; if tte.delay_rp = 0 then do; if n_dft_bauds <= 0 then do; if ^delay_error_printed then do; call statement_error (25, tte.name, ""); delay_error_printed = "1"b; end; return; end; do baudx = 1 to n_dft_bauds; call make_delay_entry (dft_bauds (baudx)); end; end; delay_tablep = ptr (misc_tables_ptr, tte.delay_rp); if tte.like_type ^= 0 /* overriding "like" */ then if ^tte.bauds_overridden /* but using same bauds statement */ then do; if ^delay_stmt /* first one */ then do; /* copy delay table of original type */ new_delay_table_ptr = ptr (misc_tables_ptr, next_misc_offset); new_delay_table_ptr -> delay_table.n_bauds = delay_table.n_bauds; do baudx = 1 to delay_table.n_bauds; new_delay_table_ptr -> delay_table.delay_array (baudx) = delay_table.delay_array (baudx); end; tte.delay_rp = next_misc_offset; next_misc_offset = next_misc_offset + 1 + 9 * (baudx - 1); delay_tablep = new_delay_table_ptr; end; tte.delay_overridden (delayx) = "1"b; end; delay_stmt = "1"b; /* we've got one now */ n_spec = n_spec + 1; if n_spec > delay_table.n_bauds /* more values than we have room for */ then do; if ^delay_error_printed then do; call ERROR (26); delay_error_printed = "1"b; end; return; end; if delayx = 2 | delayx = 4 then cur_delay_value = addr (floating_delay_value) -> based_fb; /* fake the floating ones */ else cur_delay_value = token.Nvalue; delay_table.delay_array (n_spec).delays (delayx) = cur_delay_value; return; end /* set_delay */; set_up_answerback: proc; if n_answerbacks = 0 then answerback_entry_ptr = ans_back_table_ptr; else answerback_entry_ptr = addrel (answerback_entry_ptr, divide (length (unspec (answerback_entry)) + 35, 36, 17, 0)); n_answerbacks = n_answerbacks + 1; answerback_entry.next, answerback_entry.term_type_index = 0; ansbck_char_index = 1; return; end /* set_up_answerback */; check_for_any: proc; if temp_dftte (default_count).baud ^= 0 | temp_dftte (default_count).line_type ^= 0 then call ERROR (33); return; end /* check_for_any */; /* Get current token numeric value in character form */ make_char: proc returns (char (1)); return (byte (token.Nvalue)); end make_char; /* get some space in the misc_tables segment */ get_misc_space: proc (n) returns (ptr); dcl n fixed bin; dcl p ptr; p = ptr (misc_tables_ptr, next_misc_offset); next_misc_offset = next_misc_offset + n; return (p); end get_misc_space; get_misc_char_space: proc (n) returns (ptr); dcl n fixed bin; return (get_misc_space (divide (n + 3, 4, 17, 0))); end get_misc_char_space; /* keep track of relocations of stuff in misc space */ register_misc_reloc: proc (n); dcl n fixed bin (18); misc_relocs_count = misc_relocs_count + 1; misc_relocs (misc_relocs_count) = addr (n); return; end register_misc_reloc; /* preform the relocations */ perform_misc_relocs: proc; dcl reloc_abort condition; dcl i fixed bin; dcl p ptr; dcl based_rp fixed bin (18) based (p); dcl temp_rp fixed bin (18); do i = 1 to misc_relocs_count; p = misc_relocs (i); if baseno (tttp) = baseno (p) then /* in ttt segment */ call add_increment (based_rp); else if baseno (misc_tables_ptr) = baseno (p) then do; temp_rp = bin (rel (p)); call add_increment (temp_rp); p = ptr (tttp, temp_rp); call add_increment (based_rp); end; else signal reloc_abort; end; return; end perform_misc_relocs; /* Function key table routines */ define_fkey_table: proc; call define_table (FKEY_TYPE, fkey_tables_ptr, fkey_table_offset); function_key_data_ptr = addr (extended_tables_work.table); /* Initialize */ unspec (function_key_data.sequence) = "0"b; unspec (function_key_data.cursor_motion_keys) = "0"b; function_key_data_highest = -1; function_key_data.version = function_key_data_version_1; seqs_index = 0; extended_tables_work.seqs = ""; end define_fkey_table; finish_fkey_table: proc; dcl table_p ptr; dcl seq_p ptr; function_key_data.highest = function_key_data_highest; if function_key_data.highest < 0 /* no function keys defined */ then do; function_key_data.highest = 0; function_key_data.function_keys (0, *) = 0; end; else do i = 1 to function_key_data.highest; key_info_ptr = addr (function_key_data.function_keys (i, 0)); if key_info.sequence_length = 0 then call semant_error (51, cur_table_name, ltrim (char (i))); end; table_p = ptr (fkey_tables_ptr, fkey_table_offset); seq_p = ptr (fkey_tables_ptr, fkey_table_offset + currentsize (function_key_data)); function_key_data.seq_len = seqs_index; function_key_data.seq_ptr = addr (extended_tables_work.seqs); table_p -> function_key_data = function_key_data; seq_p -> function_key_seqs = function_key_seqs; tablep -> function_key_data.seq_ptr = seq_p; fkey_table_offset = fkey_table_offset + currentsize (function_key_data) + currentsize (function_key_seqs); if mod (fkey_table_offset, 2) > 0 then fkey_table_offset = fkey_table_offset + 1; end finish_fkey_table; start_fkey_seq: proc (a_ptr); dcl a_ptr ptr; temp_key_infop = a_ptr; temp_key_index = 0; exp_char_index, unexp_char_index = 1; end start_fkey_seq; end_fkey_seq: proc; if exp_char_index > 1 then do; if temp_key_index = KEY_PLAIN & temp_key_info (temp_key_index).sequence_length > 0 then call statement_error (53, cur_table_name, ""); temp_key_info (temp_key_index).sequence_length = exp_char_index - 1; temp_key_info (temp_key_index).sequence_index = seqs_index + 1; seqs_index = seqs_index + temp_key_info (temp_key_index).sequence_length; substr (extended_tables_work.seqs, temp_key_info (temp_key_index).sequence_index, temp_key_info (temp_key_index).sequence_length) = substr (exp_string, 1, temp_key_info (temp_key_index).sequence_length); end; temp_key_index = temp_key_index + 1; exp_char_index, unexp_char_index = 1; end end_fkey_seq; init_fkey_area: proc (curr_index); dcl curr_index fixed bin; dcl j fixed bin; if curr_index > function_key_data_highest then do; do i = function_key_data_highest + 1 to curr_index; do j = lbound (function_key_data.function_keys, 2) to hbound (function_key_data.function_keys, 2); unspec (function_key_data.function_keys (i, j)) = "0"b; end; end; function_key_data_highest = curr_index; end; end init_fkey_area; /* ERROR CONTROL TABLE */ dcl 1 error_control_table (56) aligned int static options (constant), 2 severity fixed bin (17) unal init ( 3, /* 1 */ 1, /* 2 */ (4) 3, /* 3-6 */ 3, /* 7 */ (4) 3, /* 8-11 */ 1, /* 12 */ (10) 3, /* 13-22 */ 1, /* 23 */ (8) 3, /* 24-31 */ (2) 1, /* 32-33 */ 2, /* 34 */ 1, /* 35 */ (13) 3, /* 36-48 */ 1, /* 49 */ 3, /* 50 */ 3, /* 51 */ 3, /* 52 */ 1, /* 53 */ 1, /* 54 */ (2) 3), /* 55-56 */ 2 Soutput_stmt bit (1) unal init ( "0"b, /* 1 */ (5) (1)"1"b, /* 2-6 */ "0"b, /* 7 */ (3) (1)"1"b, /* 8-10 */ (3) (1)"0"b, /* 11-13 */ (9) (1)"1"b, /* 14-22 */ "0"b, /* 23 */ (3) (1)"1"b, /* 24-26 */ (7) (1)"0"b, /* 27-33 */ "1"b, /* 34 */ "0"b, /* 35 */ (5) (1)"1"b, /* 36-40 */ "0"b, /* 41 */ "1"b, /* 42 */ (2) (1)"0"b, /* 43-44 */ (2) (1)"1"b, /* 45-46 */ "0"b, /* 47 */ (3) (1)"1"b, /* 48-50 */ "0"b, /* 51 */ (2) (1)"1"b, /* 52-53 */ "0"b, /* 54 */ (2) (1)"1"b), /* 55-56 */ 2 message char (100) varying init ( "TTF is empty.", /* 1 */ "Unrecognized mode ""^a"" specified.", /* 2 */ "Invalid editing char ""^a"" specified.", /* 3 */ "Value must be yes or no.", /* 4 */ "Keyword ""^a"" unrecognized or out of order.", /* 5 */ "Syntax error.", /* 6 */ "Unexpected end of TTF encountered.", /* 7 */ "Invalid baud rate ^a specified.", /* 8 */ "Invalid delay value ^a specified.", /* 9 */ "Invalid line type ^a specified.", /* 10 */ "Too many entries in table ""^a"".", /* 11 */ "Table ""^a"" has fewer than 128 entries. Remainder have been set to 0.", /* 12 */ "Table ""^a"" contains invalid entry ""^a"".", /* 13 */ """^a"" is not a valid indicator value.", /* 14 */ "More than 3 items in a sequence.", /* 15 */ """^a"" is not a valid sequence element.", /* 16 */ """^a"" is not a valid answerback specification.", /* 17 */ "Type ""^a"" has not been defined.", /* 18 */ "The name ""^a"" contains an invalid character.", /* 19 */ "Type ""^a"" has already been defined.", /* 20 */ "Table ""^a"" has already been defined.", /* 21 */ "Table ""^a"" has already been specified as a ^a table.", /* 22 */ "Table ""^a"" contains a null ^a sequence.", /* 23 */ "A bauds statement appears after a delay statement for terminal type ""^a"".", /* 24 */ "No baud rates have been specified for terminal type ""^a"".", /* 25 */ "More delay values than baud rates specified.", /* 26 */ "Text follows the end statement.", /* 27 */ "Table ""^a"" has been referenced but not defined.", /* 28 */ "Type ""^a"" has been referenced in default types table but not defined.", /* 29 */ "Type ""^a"" has an output conversion table but no special table.", /* 30 */ "Type ""^a"" uses conversion table ""^a"", which contains an escape not represented in the special table.", /* 31 */ "No default_types statement specified.", /* 32 */ "Last entry in default_types statement does not specify ""any any"".", /* 33 */ "Unrecognized preaccess command ^a specified.", /* 34 */ "No type specified for preaccess command ^a.", /* 35 */ "Invalid repetition factor ^a specified.", /* 36 */ "Repetition factors nested too deep.", /* 37 */ "Unbalanced brackets.", /* 38 */ "Name ""^a"" is too long.", /* 39 */ "Mode delimiter missing at or before ""^a"".", /* 40 */ "Entry for type ^a contains one null and one non-null framing character.", /* 41 */ "Attempt to specify incompatible output flow control protocols.", /* 42 */ "Inconsistency in specification of output flow control for type ^a.", /* 43 */ "Inconsistency in specification of input flow control for type ^a.", /* 44 */ "Invalid token ""^a"" in video control sequence.", /* 45 */ "Invalid token ""^a"" in video argument sequence.", /* 46 */ "Video control sequence too long or empty.", /* 47 */ "Unexpressible padding time: ^a.", /* 48 */ "This character specification will convert invalidly without -ck1dig. Precede it by a zero. ^a", /* 49 */ "Invalid token ""^a"" in function key control sequence.", /* 50 */ "Table ""^a"", missing function key data for key(^a)", /* 51 */ "Table ""^a"", too many control sequences specified for a function key.", /* 52 */ "Table ""^a"", function key control sequence already defined.", /* 53 */ "Invalid protocol ""^a"" specified.", /* 54 */ "Option not defined for this keyword: ^a.", /* 55 */ "Maximum number of allowable options ""^a"" exceeded."), /* 56 */ 2 brief_message char (30) varying init ( "", /* 1 */ (2) (1)"^a", /* 2-3 */ "", /* 4 */ "^a", /* 5 */ (2) (1)"", /* 6-7 */ (5) (1)"^a", /* 8-12 */ """^a"" contains ""^a""", /* 13 */ "^a", /* 14 */ "", /* 15 */ (6) (1)"^a", /* 16-21 */ "^a is ^a", /* 22 */ "^a has null ^a", /* 23 */ (2) (1)"^a", /* 24-25 */ (2) (1)"", /* 26-27 */ (3) (1)"^a", /* 28-30 */ "^a uses ^a", /* 31 */ (2) (1)"", /* 32-33 */ (3) (1)"^a", /* 34-36 */ (2) (1)"", /* 37-38 */ (3) (1)"^a", /* 39-41 */ "", /* 42 */ (4) (1)"^a", /* 43-46 */ "", /* 47 */ (3) (1)"^a", /* 48-50 */ "Table ""^a"" - key(^a)", /* 51 */ (2) (1)"Table ""^a""", /* 52-53 */ "^a", /* 54 */ "Option not defined: ""^a"".", /* 55 */ "Max number of options is ^a."); /* 56 */  disk_usage_stat.pl1 10/27/83 1614.3rew 10/27/83 1441.6 154422 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ disk_usage_stat: proc; /* program to do some disk statistics THVV Fixed up by R. Holmsedt and C. Hornig, September 1979. */ dcl path char (168), /* root of tree */ level fixed bin, /* current depth relative to root. */ ctime char (24), (co, dp) char (128), /* titles for report */ junk char (1), (i, j, k) fixed bin, (t1, t2, t3) fixed bin, half fixed bin, /* Half the number of records. for median ages. */ rolder (0: 90) fixed bin, folder (0: 90) fixed bin, nxt_midnight fixed bin (71), slp ptr, lth fixed bin (24), NL char (1) int static init (" "), kk fixed bin, gap fixed bin, ap ptr, al fixed bin, bchr char (al) unaligned based (ap), ec fixed bin (35); dcl (nsegs (0: 15), ndirs (0: 15), nlinks (0: 15), nrecs (0: 15), ndrecs (0: 15), nnames (0: 15)) fixed bin, (mscale, maxlv) fixed bin, nscale fixed bin, urage (0: 90) fixed bin, ufage (0: 90) fixed bin, mrage (0: 90) fixed bin, mfage (0: 90) fixed bin, max_seg_size fixed bin, rsize (0: 256) fixed bin, n_ents_w_i_names (0: 2048) fixed bin, n_dirs_w_i_names (0: 2048) fixed bin, tnnames fixed bin, max_names_in_dir fixed bin, max_names_on_ent fixed bin, current_pathname char (168), path_with_max_names char (168), dir_with_max_names char (168), bigseg_name char (168), bigdir fixed bin, /* Size of biggest dir, in records. */ bigdir_name char (168), lrm fixed bin, /* Age of least-recently-modified seg */ lrm_segname char (168), lru fixed bin, /* Age of least-recently-used seg */ lru_segname char (168), pending_names (0: 15) fixed bin, /* Pushdown list */ savlvl fixed bin; /* Level in pdl */ dcl has_starstar bit (1) init ("0"b), starname_name (128) char (32), starname_type (128) fixed bin, starname_recs (128) fixed bin, starname_fils (128) fixed bin, starname_lnks (128) fixed bin, nsfx fixed bin; dcl xxx char (120) int static init ((120)"x"); dcl datebin_$this_midnight entry (fixed bin (71)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), system_info_$titles entry (char (*), char (*), char (*), char (*)), sweep_disk_ entry (char (168), entry), absolute_pathname_ entry (char (*), char (*), fixed bin (35)), check_star_name_$entry entry (char (*), fixed bin (35)), match_star_name_ entry (char (*), char (*), fixed bin (35)), (ioa_, ioa_$rsnnl) entry options (variable), com_err_ entry options (variable), date_time_ entry (fixed bin (71), char (*)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), get_wdir_ entry () returns (char (168)), hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl bcs char (262144) based (slp); dcl (binary, clock, divide, substr, addr, null, index, fixed) builtin; /* ======================================================= */ call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then path = ">"; else do; call absolute_pathname_ (bchr, path, ec); if ec ^= 0 then do; call com_err_ (ec, "disk_usage_stat", "^a", bchr); return; end; end; call datebin_$this_midnight (nxt_midnight); bigdir, lrm, lru, mscale, maxlv, savlvl, nsegs (*), nlinks (*), ndirs (*), pending_names (*), nrecs (*), ndrecs (*), nnames (*), max_seg_size, rsize (*), urage (*), mrage (*), ufage (*), mfage (*), n_ents_w_i_names (*), n_dirs_w_i_names (*), starname_recs (*), starname_fils (*), starname_lnks (*), tnnames, max_names_in_dir, max_names_on_ent = 0; nsfx = 0; call hcs_$initiate_count ((get_wdir_ ()), "starname_list", "", lth, 0, slp, ec); if slp = null then go to no_sl; lth = divide (lth, 9, 17, 0); kk = 1; do k = 1 to lth while (nsfx < 100); if substr (bcs, k, 1) = NL then do; if substr (bcs, kk, 1) = "&" then go to skipline; /* Skip comment. */ nsfx = nsfx + 1; starname_name (nsfx) = substr (bcs, kk, k-kk); call check_star_name_$entry (starname_name (nsfx), ec); if ec >= 0 & ec <= 2 then starname_type (nsfx) = ec; else do; call com_err_ (ec, "disk_usage_stat", "^a", starname_name (nsfx)); starname_type (nsfx) = 0; end; if starname_type (nsfx) = 2 then has_starstar = "1"b; skipline: kk = k + 1; end; end; call hcs_$terminate_noname (slp, ec); no_sl: if ^has_starstar then do; nsfx = nsfx + 1; starname_name (nsfx) = "**"; starname_type (nsfx) = 2; end; /* Now, go to work. Call disk sweeper program */ call sweep_disk_ (path, counter); /* On return from sweep of hierarchy, print the report. */ do while (savlvl > 0); i = pending_names (savlvl); n_dirs_w_i_names (i) = n_dirs_w_i_names (i) + 1; if i > max_names_in_dir then do; max_names_in_dir = i; call set_dwmn (); end; savlvl = savlvl - 1; end; call date_time_ ((clock ()), ctime); call system_info_$titles (junk, junk, co, dp); call ioa_ ("^|^a^/^/^-^a", co, dp); call ioa_ ("^/Multics disk usage for ""^a"" - ^a", path, ctime); call ioa_ ("^/Depth^3xSegs^3xDirs Links^3xRecs Dir Recs Names^/"); do i = 0 to maxlv; call ioa_ ("^5d ^6d ^6d ^6d ^6d ^9d ^6d", i, nsegs (i), ndirs (i), nlinks (i), nrecs (i), ndrecs (i), nnames (i)); if i > 0 then do; nsegs (0) = nsegs (0) + nsegs (i); ndirs (0) = ndirs (0) + ndirs (i); nlinks (0) = nlinks (0) + nlinks (i); nrecs (0) = nrecs (0) + nrecs (i); ndrecs (0) = ndrecs (0) + ndrecs (i); nnames (0) = nnames (0) + nnames (i); end; end; call ioa_ ("----- ----- ----- ----- ----- -------- -----"); call ioa_ ("Total ^6d ^6d ^6d ^6d ^9d ^6d", nsegs (0), ndirs (0), nlinks (0), nrecs (0), ndrecs (0), nnames (0)); if nsegs (0) = 0 then do; call ioa_ ("^/No segments exist for ""^a""", path); end; else call ioa_ ("^/^10xAverage segment size:^7x^7.1f records", (1e0*nrecs (0))/nsegs (0)); if ndirs (0) = 0 then do; call ioa_ ("^/No directories exist under ""^a""", path); go to nodirs; end; else call ioa_ ("^10xAverage directory size:^5x^7.1f records", (1e0*ndrecs (0))/ndirs (0)); call ioa_ ("^10xAverage segments/directory: ^7.1f", (1e0*nsegs (0))/ndirs (0)); call ioa_ ("^10xAverage links/directory:^4x^7.1f", (1e0*nlinks (0))/ndirs (0)); call ioa_ ("^10xAverage names/directory:^4x^7.1f", (1e0*nnames (0))/ndirs (0)); nodirs: half = divide (nsegs (0), 2, 17, 0); /* Get half the number of segments. */ t1, t2, t3 = 0; do i = 90 to 0 by -1; t1, rolder (i) = t1 + urage (i); t2, folder (i) = t2 + ufage (i); if t2 > half then if t3 = 0 then t3 = i; end; if nsegs (0) = 0 then goto fini; else call set_scale (100, t1, nscale); call ioa_ ("^/Distribution by date of last reference"); call ioa_ ("^/^10xMedian number of days since last reference is ^d.", t3); if lru = 0 then lru_segname = "(none)"; /* puts out junk otherwise */ call ioa_ ("^10xLeast recently used segment (^d days) is ^a", lru, lru_segname); call ioa_ ("^/Age^3xSegs Older^3xRecs Older Scale: one ""x"" is ^d records", nscale); do i = 0 to 90; call ioa_ ("^3d^7d^7d^7d^7d ^a", i, ufage (i), folder (i), urage (i), rolder (i), substr (xxx, 1, divide (rolder (i)+nscale-1, nscale, 17, 0))); end; t1, t2, t3 = 0; do i = 90 to 0 by -1; t1, rolder (i) = t1 + mrage (i); t2, folder (i) = t2 + mfage (i); if t2 > half then if t3 = 0 then t3 = i; end; call set_scale (100, t1, nscale); call head; call ioa_ ("^/Distribution by date of last modification"); call ioa_ ("^/^10xMedian number of days since last modification is ^d.", t3); if lrm = 0 then lrm_segname = "(none)"; /* puts out junk if =0 days */ call ioa_ ("^10xLeast recently modified segment (^d days) is ^a", lrm, lrm_segname); call ioa_ ("^/Age^3xSegs Older^3xRecs Older Scale: one ""x"" is ^d records", nscale); do i = 0 to 90; call ioa_ ("^3d^7d^7d^7d^7d ^a", i, mfage (i), folder (i), mrage (i), rolder (i), substr (xxx, 1, divide (rolder (i)+nscale-1, nscale, 17, 0))); end; call head; call ioa_ ("^/Distribution by segment size: ^d records total", nrecs (0)); call ioa_ ("^/^10xLargest segment (^d recs) is ^a", max_seg_size, bigseg_name); if ndirs (0) = 0 then call ioa_ ("^/No other directories exist under ""^a""", path); else call ioa_ ("^10xLargest directory (^d recs) is ^a", bigdir, bigdir_name); call set_scale (120, mscale, mscale); call ioa_ ("^/ K Count Scale: one ""x"" is ^d segments", mscale); gap = 0; do i = 0 to max_seg_size; if rsize (i) = 0 then do; /* Check for gap. */ gap = gap + 1; go to sgap1; end; if gap > 0 then do; if gap < 4 then do j = (i-gap) to (i-1); call ioa_ ("^4d^7d", j, 0); end; else call ioa_ ("^4x(^d)", gap); gap = 0; end; call ioa_ ("^4d^7d ^a", i, rsize (i), /* print row of x's */ substr (xxx, 1, divide (rsize (i)+mscale-1, mscale, 17, 0))); sgap1: end; call head; call ioa_ ("^/Distribution by segment name"); call ioa_ ("^/Name^30xSegs^3xRecs Links^/"); t1, t2, t3 = 0; do i = 1 to nsfx; call ioa_ ("^32a^6d^7d^7d", starname_name (i), starname_fils (i), starname_recs (i), starname_lnks (i)); t1 = t1 + starname_fils (i); t2 = t2 + starname_recs (i); t3 = t3 + starname_lnks (i); end; call ioa_ ("^/TOTAL^26x^7d^7d^7d", t1, t2, t3); call head; call ioa_ ("^/Entry distribution by number of names: ^d entries total", nsegs (0) + ndirs (0) + nlinks (0)); call ioa_ ("^/^10xEntry with most names (^d) is ^a", max_names_on_ent, path_with_max_names); t1 = 0; do i = 1 to max_names_on_ent; if n_ents_w_i_names (i) > t1 then t1 = n_ents_w_i_names (i); end; call set_scale (100, t1, nscale); call ioa_ ("^/Nnames Nents Scale: one ""x"" is ^d entries", nscale); gap = 0; do i = 1 to max_names_on_ent; if n_ents_w_i_names (i) = 0 then do; /* Check for gap. */ gap = gap + 1; go to sgap2; end; if gap > 0 then do; if gap < 4 then do j = (i-gap) to (i-1); call ioa_ ("^6d^7d", j, 0); end; else call ioa_ ("^6x(^d)", gap); gap = 0; end; call ioa_ ("^6d^7d ^a", i, n_ents_w_i_names (i), substr (xxx, 1, divide (n_ents_w_i_names (i)+nscale-1, nscale, 17, 0))); sgap2: end; call head; call ioa_ ("^/Directory distribution by number of names: ^d directories total", ndirs (0)); call ioa_ ("^/^10xDirectory containing most names (^d) is ^a", max_names_in_dir, dir_with_max_names); t1, t2 = 0; do i = 1 to max_names_in_dir; /* Empty directories are not scanned. */ if t1 < n_dirs_w_i_names (i) then t1 = n_dirs_w_i_names (i); t2 = t2 + n_dirs_w_i_names (i); end; n_dirs_w_i_names (0) = ndirs (0) - t2; if t1 < n_dirs_w_i_names (0) then t1 = n_dirs_w_i_names (0); call set_scale (100, t1, nscale); if ndirs (0) = 0 then goto sgap; /* attempt to access beyond end of stack if no dirs */ else call ioa_ ("^/Nnames Ndirs Scale: one ""x"" is ^d directories", nscale); gap = 0; do i = 0 to max_names_in_dir; if n_dirs_w_i_names (i) = 0 then do; /* Check for gap. */ gap = gap + 1; go to sgap; end; if gap > 0 then do; if gap < 4 then do j = (i-gap) to (i-1); call ioa_ ("^6d^7d", j, 0); end; else call ioa_ ("^6x(^d)", gap); gap = 0; end; call ioa_ ("^6d^7d ^a", i, n_dirs_w_i_names (i), substr (xxx, 1, divide (n_dirs_w_i_names (i)+nscale-1, nscale, 17, 0))); sgap: end; return; /* -------------------------------------------------------- */ counter: proc (sdn, sen, lvl, een, bptr, nptr); dcl sdn char (168), /* superior dir name */ sen char (32), /* dirname */ lvl fixed bin, /* distance from root */ een char (32), /* entry name */ bptr ptr, /* ptr to info structure */ nptr ptr; /* ptr to names structure */ dcl seg_length fixed bin, /* length of seg in records */ no_of_names fixed bin, /* number of names on segment */ nnames_in_dir fixed bin, /* number of names in a directory */ ndays fixed bin, /* number of days since use or mod */ date_temp fixed bin (71); /* date temp */ dcl ecc fixed bin (35); dcl 1 branch based (bptr) aligned, /* thing returned by star_long */ 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtu bit (36) unal, 2 mode bit (5) unal, 2 pad bit (13) unal, 2 records bit (18) unal; level = lvl; /* save in global. */ if lvl > maxlv then maxlv = lvl; no_of_names = fixed (branch.nname, 16); nnames (lvl) = nnames (lvl) + no_of_names; n_ents_w_i_names (no_of_names) = n_ents_w_i_names (no_of_names) + 1; do while (lvl < savlvl); nnames_in_dir = pending_names (savlvl); n_dirs_w_i_names (nnames_in_dir) = n_dirs_w_i_names (nnames_in_dir) + 1; if nnames_in_dir > max_names_in_dir then do; max_names_in_dir = nnames_in_dir; call set_dwmn (); end; pending_names (savlvl) = 0; savlvl = savlvl - 1; end; savlvl = lvl; pending_names (savlvl) = pending_names (savlvl) + no_of_names; call ioa_$rsnnl ("^a^[>^]^a^[>^]^a", current_pathname, (0), sdn, (sdn ^= ""), sen, (sen ^= ""), een); if no_of_names > max_names_on_ent then do; max_names_on_ent = no_of_names; path_with_max_names = current_pathname; end; if branch.type = "00"b then do; /* link? */ nlinks (lvl) = nlinks (lvl) + 1; end; else if branch.type = "01"b then do; /* seg? */ nsegs (lvl) = nsegs (lvl) + 1; seg_length = fixed (records, 18); if seg_length > max_seg_size then do; /* Biggest? */ max_seg_size = seg_length; bigseg_name = current_pathname; end; nrecs (lvl) = nrecs (lvl) + seg_length; rsize (seg_length) = rsize (seg_length) + 1; if rsize (seg_length) > mscale then mscale = rsize (seg_length); date_temp = binary (branch.dtu) * 1e16b; ndays = divide (nxt_midnight - date_temp, 86400000000, 17, 0); if ndays < 0 then ndays = 0; /* Correct for oprs running system with bad clock. */ if ndays < 5000 then if ndays > lru then do; /* Oldest (no segment is 13 years old) */ lru = ndays; lru_segname = current_pathname; end; if ndays > 90 then ndays = 90; ufage (ndays) = ufage (ndays) + 1; urage (ndays) = urage (ndays) + seg_length; date_temp = binary (branch.dtm) * 1e16b; ndays = divide (nxt_midnight - date_temp, 86400000000, 17, 0); if ndays < 0 then ndays = 0; /* No science-fiction */ if ndays < 5000 then if ndays > lrm then do; /* Oldest? */ lrm = ndays; lrm_segname = current_pathname; end; if ndays > 90 then ndays = 90; mfage (ndays) = mfage (ndays) + 1; mrage (ndays) = mrage (ndays) + seg_length; end; else if branch.type = "10"b then do; /* dir? */ seg_length = fixed (records, 16); if seg_length > bigdir then do; /* Biggest? */ bigdir = seg_length; bigdir_name = current_pathname; end; ndrecs (lvl) = ndrecs (lvl) + seg_length; ndirs (lvl) = ndirs (lvl) + 1; end; do k = 1 to nsfx; /* Classify by type of name */ if starname_type (k) = 0 then ecc = binary (een ^= starname_name (k)); else if starname_type (k) = 2 then ecc = 0; else call match_star_name_ (een, starname_name (k), ecc); if ecc = 0 then do; if branch.type = "01"b then do; starname_recs (k) = starname_recs (k) + seg_length; starname_fils (k) = starname_fils (k) + 1; end; else if branch.type = "00"b then starname_lnks (k) = starname_lnks (k) + 1; go to sf1; end; end; sf1: ; end counter; set_scale: proc (Page_width, Line_max, Scale); dcl (Page_width, Line_max, Scale) fixed bin; dcl (t1, t2, t3) fixed bin; Scale = divide (Line_max, Page_width, 35, 0); t1, t2 = 1; do while (Scale >= t1); t3 = divide (t1, t2, 17, 0); if t3 = 1 then t1 = 2 * t2; else if t3 = 2 then t1 = 5 * t2; else t1, t2 = 10 * t2; end; Scale = t1; end set_scale; set_dwmn: proc (); dcl (i, j, k) fixed bin; k = savlvl - level; /* Going to strip of this many >'s */ j = 168; do while (k > 0); do i = j to 1 by -1 while (substr (current_pathname, i, 1) ^= ">"); end; j = i-1; k = k - 1; end; dir_with_max_names = substr (current_pathname, 1, j); end set_dwmn; head: proc; call ioa_ ("^|Disk usage for ""^a"" - ^a", path, ctime); end; fini: end disk_usage_stat;  display_anst.pl1 08/04/87 1455.5rew 08/04/87 1221.9 67041 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ display_anst: proc; /* DISPLAY_ANST - dump answer table on console. THVV Modified by T. Casey, August 1975 to add dump_autbl and dump_dutbl Modified by D. M. Wells, July 1976, to understand about FTP channels Modified by G. C. Dixon, April 1978: rename entry points to display_anst, display_aut & display_dut and standardize control arguments. Modified by E. N. Kittlitz, September 1982: merge in old dump_anstbl entries. */ /****^ HISTORY COMMENTS: 1) change(87-05-31,GDixon), approve(87-07-13,MCR7741), audit(87-07-24,Hartogs), install(87-08-04,MR12.1-1055): A) Expand length of -channel operand to hold up to 32 characters. B) Allow -channel operand to be a starname. END HISTORY COMMENTS */ dcl al fixed bin (21); dcl ansp ptr; dcl ap ptr; dcl argc fixed bin; dcl argn fixed bin; dcl bchr char (al) based (ap) unaligned; dcl dn char (168); dcl ec fixed bin (35); dcl en char (32); dcl entry_sw fixed bin; dcl hdr bit (1) aligned init ("1"b); dcl mode fixed bin init (1); dcl oct bit (1) aligned init ("0"b); dcl old_dump bit (1) aligned; dcl path char (168); dcl sch_tty char (32) aligned init (""); dcl sch_user char (32) aligned init (""); dcl star_type fixed bin(2); dcl whoami char (12); dcl entry_var variable entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned); dcl ANS fixed bin init (1) static options (constant); dcl AUT fixed bin init (2) static options (constant); dcl DUT fixed bin init (3) static options (constant); dcl (char, null) builtin; dcl cleanup condition; dcl check_star_name_ entry (char(*), bit(36), fixed bin(2), fixed bin(35)); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl dump_anstbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned); dcl dump_autbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned); dcl dump_dutbl_ entry (ptr, bit (1) aligned, bit (1) aligned, fixed bin, char (*) aligned, char (*) aligned, char (*) aligned); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl error_table_$badopt fixed bin (35) ext; %page; /* -------------------------------------------------------- */ whoami = "display_anst"; old_dump = "0"b; go to ans_join; dump_anstbl: entry; whoami = "dump_anstbl"; old_dump = "1"b; ans_join: path = ">system_control_1>answer_table"; entry_sw = ANS; entry_var = dump_anstbl_; JOIN: ansp = null; on cleanup begin; if ansp ^= null then call terminate_file_ (ansp, 0, TERM_FILE_TERM, (0)); end; call cu_$arg_count (argc, ec); if ec ^= 0 then do; call com_err_ (ec, whoami); go to exit; end; do argn = 1 to argc; call cu_$arg_ptr (argn, ap, al, ec); if char (bchr, 1) = "-" then do; if bchr = "-all" then mode = 0; else if bchr = "-a" then mode = 0; else if bchr = "-lock" then mode = 2; else if bchr = "-octal" then oct = "1"b; else if bchr = "-oc" then oct = "1"b; else if bchr = "-o" & old_dump then oct = "1"b; else if bchr = "-no_octal" | bchr = "-noc" then oct = "0"b; else if bchr = "-no_header" then hdr = "0"b; else if bchr = "-nhe" then hdr = "0"b; else if bchr = "-nh" & old_dump then hdr = "0"b; else if bchr = "-header" | bchr = "-he" then hdr = "1"b; else if bchr = "-name" | bchr = "-nm" | old_dump & bchr = "-user" then do; argn = argn + 1; if argn > argc then do; no_arg: call com_err_ (ec, whoami, "Control argument ^a requires an operand.", bchr); go to exit; end; call cu_$arg_ptr (argn, ap, al, ec); if ec ^= 0 then do; cu_fail: call com_err_ (ec, whoami); go to exit; end; mode = 9; sch_user = bchr; end; else if bchr = "-pathname" | bchr = "-pn" then do; argn = argn + 1; if argn > argc then go to no_arg; call cu_$arg_ptr (argn, ap, al, ec); if ec ^= 0 then go to cu_fail; path = bchr; end; else if bchr = "-active" then mode = 1; else if bchr = "-dial" & entry_sw = ANS then mode = 4; else if bchr = "-in" then mode = 3; else if (bchr = "-channel" | bchr = "-chn") & entry_sw = ANS then do; argn = argn + 1; if argn > argc then go to no_arg; call cu_$arg_ptr (argn, ap, al, ec); if ec ^= 0 then go to cu_fail; CHN: call check_star_name_ (bchr, CHECK_STAR_ENTRY_DEFAULT, star_type, ec); if ec ^= 0 then do; call com_err_ (ec, whoami, "channel ^a", bchr); go to exit; end; else if star_type = STAR_TYPE_MATCHES_EVERYTHING then; else do; mode = 9; sch_tty = bchr; end; end; else do; bad_arg: call com_err_ (error_table_$badopt, whoami, "^a", bchr); go to exit; end; end; /* first char is - */ else if old_dump then do; /* old dump, first char not - */ if char (bchr, 3) = "caa" | char (bchr, 3) = "net" | char (bchr, 3) = "ftp" | char (bchr, 3) = "tty" then go to CHN; else path = bchr; /* it's a pathname */ end; else do; /* new dump, first char not - */ go to CHN; end; nxarg: end; call expand_pathname_ (path, dn, en, ec); if ec ^= 0 then do; call com_err_ (ec, whoami, "^a", path); go to exit; end; call initiate_file_ (dn, en, R_ACCESS, ansp, (0), ec); if ansp = null then do; call com_err_ (ec, whoami, "^a", pathname_ (dn, en)); go to exit; end; call entry_var (ansp, hdr, oct, mode, sch_tty, sch_user, "user_output"); exit: call terminate_file_ (ansp, 0, TERM_FILE_TERM, (0)); return; dump_autbl: entry; old_dump = "1"b; whoami = "dump_autbl"; go to aut_join; display_aut: entry; old_dump = ""b; whoami = "display_aut"; aut_join: path = ">system_control_dir>absentee_user_table"; entry_var = dump_autbl_; entry_sw = AUT; goto JOIN; dump_dutbl: entry; old_dump = "1"b; whoami = "dump_dutbl"; go to dut_join; display_dut: entry; old_dump = ""b; whoami = "display_dut"; dut_join: path = ">system_control_dir>daemon_user_table"; entry_var = dump_dutbl_; entry_sw = DUT; goto JOIN; %page; %include access_mode_values; %page; %include check_star_name; %page; %include terminate_file; end display_anst;  display_cdt.pl1 04/09/85 1352.0r w 04/08/85 1134.4 57780 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2 */ display_cdt: procedure; /* DUMP_CDT - dump Channel Definition Table. THVV Modified by Mike Grady 5/10/76 for -cmf arg, also for version 2 CDT. Modified for error code from dump_cdt_ and dump_cmf_ BIM 1/82 */ dcl (path, dn) char (168), en char (32), ec fixed bin, cdtp ptr, sch_tty char (32) init (""), al fixed bin (21), ap ptr, arg char (al) based (ap) unaligned; dcl arg_count fixed bin; dcl arg_list_ptr pointer; dcl argx fixed bin; dcl (addr, null, substr) builtin; dcl dump_cmf_ entry (ptr, ptr); dcl dump_cdt_ entry (ptr, fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), com_err_ entry options (variable); dcl cleanup condition; dcl ( error_table_$noarg, error_table_$badopt, error_table_$too_many_args, error_table_$inconsistent ) fixed bin (35) ext; dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl sc_stat_$sysdir char (168) aligned external; dcl 1 dca aligned like dump_cdt_args; dcl cmf_sw bit (1) aligned; dcl code fixed bin (35); dcl ME char (32) init ("display_cdt") internal static options (constant); call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); goto RETURN; end; if arg_count = 0 then do; call com_err_ (0, ME, "Usage: display_cdt {channel} {-cmf PATH|-all|-header|-pathname PATH|-brief|-long"); return; end; call cu_$arg_list_ptr (arg_list_ptr); /* For rel calls */ cdtp, dca.switch = null; on cleanup call clean_up; unspec (dca) = ""b; dca.channel_name = ""; cmf_sw = "0"b; path = ""; argx = 0; do while (argx < arg_count); call get_next_arg (""); if al > 0 then if substr (arg, 1, 1) = "-" then do; if arg = "-all" | arg = "-a" then dca.all = "1"b; else if arg = "-subtree" then dca.subtree = "1"b; else if arg = "-brief" | arg = "-bf" then dca.brief = "1"b; else if arg = "-long" | arg = "-lg" then dca.brief = "0"b; else if arg = "-no_header" | arg = "-nhe" then dca.hdr = "0"b; else if arg = "-header" | arg = "-he" then dca.hdr = "1"b; else if arg = "-channel" | arg = "-chn" then do; call get_next_arg ("A channel with -channel"); CHANNEL_ARG: if dca.channel_name ^= "" then do; call com_err_ (error_table_$too_many_args, ME, "Multiple -channel args are not permitted."); go to RETURN; end; call check_star_name_$entry (arg, code); dca.channel_name = arg; if code = 0 then dca.all = "0"b; else if code = 1 then do; dca.starname = "1"b; dca.all = "0"b; end; else if code = 2 then dca.all = "1"b; else do; call com_err_ (code, ME, "Bad channel name: ^a", arg); go to RETURN; end; end; else if arg = "-cmf" then do; cmf_sw = "1"b; call get_next_arg ("Pathname following -cmf"); call iox_$attach_name (unique_chars_ (""b) || ".dump_cdt_output_", dca.switch, "vfile_ " || arg, null, code); if code ^= 0 then do; call com_err_ (code, "display_cdt", "Unable to attach output file"); go to RETURN; end; call iox_$open (dca.switch, Stream_output, "0"b, code); if code ^= 0 then do; call com_err_ (code, "display_cdt", "Unable to open output file"); go to RETURN; end; end; else if arg = "-pathname" | arg = "-pn" then do; call get_next_arg ("A pathname following -pathname"); path = arg; end; else do; call com_err_ (error_table_$badopt, "display_cdt", """^a""", arg); go to RETURN; end; end; else go to CHANNEL_ARG; /* positional = -channel */ end; if path = "" then path = pathname_ ((sc_stat_$sysdir), "cdt"); call expand_pathname_ (path, dn, en, code); if code ^= 0 then do; call com_err_ (code, "display_cdt", "^a", path); go to RETURN; end; call initiate_file_ (dn, en, R_ACCESS, cdtp, (0), code); if code ^= 0 then do; call com_err_ (code, "display_cdt", "^a", en); go to RETURN; end; if cmf_sw then call dump_cmf_ (cdtp, dca.switch); /* dump cdt in form of cmf */ else do; dca.switch = iox_$user_output; dca.cdt_ptr = cdtp; call dump_cdt_ (addr (dca), code); if code ^= 0 then call com_err_ (code, ME, "^a", dca.channel_name); end; RETURN: call clean_up; return; clean_up: procedure; if dca.switch ^= null & dca.switch ^= iox_$user_output then do; call iox_$close (dca.switch, code); call iox_$detach_iocb (dca.switch, code); call iox_$destroy_iocb (dca.switch, code); end; if cdtp ^= null then call terminate_file_ (cdtp, (0), TERM_FILE_TERM, (0)); cdtp = null; end clean_up; get_next_arg: procedure (what_did_we_want); declare what_did_we_want char (*); argx = argx + 1; if argx > arg_count then do; call com_err_ (error_table_$noarg, ME, "^a", what_did_we_want); go to RETURN; end; call cu_$arg_ptr_rel (argx, ap, al, (0), arg_list_ptr); end get_next_arg; %include dump_cdt_args_; %include terminate_file; %include access_mode_values; %include iox_dcls; %include iox_modes; end display_cdt;  display_cpu_error.pl1 03/14/85 0810.8rew 03/13/85 1018.4 287262 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4,delnl,insnl,ifthenstmt,indnoniterend */ /* DISPLAY_CPU_ERROR: Command to display MCs and hregs from CPU errors from the syserr log */ /* Written Oct 1982 by Rich Coppola */ /* Most of this program was borrowed from the mos_edac_summary command. */ /* Modified Jan 1984 by Paul Farley to add checking for other syserr entry types (Currently hardware_fault and verify_lock), which is defined by display_cpu_error_binary_defs. This is being implemented by using three new control arguments "-all", "-match" and "-exclude". The default will be to only examine the hardware_fault entries. Modified 1985-02-21, EJ Sharpe: use syserr_fault_msg.incl.pl1, use date_time_$format */ display_cpu_error: proc; /* Automatic */ dcl CPU_TAGS char (16) int static options (constant) init ("ABCDEFGHabcdefgh"); dcl arg char (arg_len) based (arg_ptr); /* A command argument */ dcl arg_copy char (15) varying; /* Temp copy of an argument */ dcl arg_count fixed bin; /* The number of arguments */ dcl arg_len fixed bin; /* Length of an argument */ dcl arg_list_ptr ptr; /* Pointer to commands argument list */ dcl arg_no fixed bin init (1); /* For scanning argument list */ dcl arg_ptr ptr; /* Pointer to an argument */ dcl argc fixed bin; /* for getting cpu args */ dcl def_idx fixed bin; /* binary_def index */ dcl code fixed bin (35); /* Standard system status code */ dcl cpu_cnt fixed bin init (0); /* Number of CPUs requested */ dcl expand_sw bit (1) init ("0"b); /* Set if user just wants hregs interpreted */ dcl for_arg char (for_len) based (for_ptr); /* This is the -for argument */ dcl for_len fixed bin; /* Saved length of -for argument */ dcl for_ptr ptr; /* Saved pointer to the -for argument */ dcl for_sw bit (1) init ("0"b); /* Set if -for used */ dcl for_time fixed bin (71); /* Time specified on -for */ dcl from_sw bit (1) init ("0"b); /* Set if -from used */ dcl from_time fixed bin (71); /* Time specified on -from */ dcl scan_text bit (1) init ("0"b); /* Set if -match used */ dcl match_sw bit (1) init ("0"b); /* Set if -match used */ dcl exclude_sw bit (1) init ("0"b); /* Set if -exclude used */ dcl hr_switches bit (5); dcl mask bit (36) aligned init ("0"b); /* Mask of significant bits in status word */ dcl more_args bit (1); /* Set while there are more arguments to scan */ dcl area_ptr ptr init (null); /* Free area pointer */ dcl free_area area based (area_ptr); /* Free area for allocating strings */ dcl msg_seq fixed bin (35); /* Sequence number */ dcl msg_time fixed bin (71); /* Time of syserr message */ dcl only_scu bit (1) init ("0"b); /* 1 => don't display hregs */ dcl open_status bit (36) aligned; /* Code from syserr_log_util_$open */ dcl plural_sw bit (1); dcl ptr_array (1) ptr; /* An array of pointers as required by get_temp_segment_ */ dcl (print_cnt, read_cnt) fixed bin init (-1); dcl segs_allocated bit (1) init ("0"b); /* Set after work segments created */ dcl tab_cnt fixed bin init (0); /* Number of seperate status found */ dcl thread_sw bit (1) init ("1"b); /* Set to thread hregs */ dcl (tm1, tm2) char (24); /* Used to call date_time_ */ dcl to_sw bit (1) init ("0"b); /* Set if -to used */ dcl to_time fixed bin (71); /* Time specified on -to */ dcl workp ptr; /* Pointer to work segment */ dcl 1 work aligned based (workp), /* Declaration of work segment */ 2 cpureq (8) char (1), /* Table of requested CPUs */ 2 buffer (500) bit (36) aligned; /* Syserr messages are read here */ dcl ctext char (512); /* Text of current message */ dcl ctextl fixed bin; /* Length of current message */ dcl 1 string_data based, /* Data for match or exclude */ 2 first ptr, /* Pointer to first string */ 2 last ptr, /* Pointer to last string */ 2 count fixed bin init (0); /* Number of strings in list */ dcl 1 match_data like string_data automatic; /* List of match strings */ dcl 1 exclude_data like string_data automatic; /* List of exclude strings */ dcl 1 str aligned based, /* Structure allocated for each string */ 2 next ptr init (null), /* Pointer to next in list */ 2 len fixed bin init (arg_len), /* Length of messaage */ 2 data char (arg_len refer (str.len)); /* The string */ /* Constants */ dcl name char (17) int static options (constant) init ("display_cpu_error"); /* Name of procedure */ /* External entries */ dcl com_err_ entry options (variable); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl cv_bin_$oct entry (fixed bin, char (12)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl db_print entry (ptr, char (*) aligned, ptr, char (*), fixed bin, fixed bin, ptr, fixed bin, fixed bin); dcl error_table_$end_of_info ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl hran_$hranl entry (ptr, ptr, bit (1)); dcl hran_$no_thread entry (ptr, ptr, bit (5)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry () options (variable); dcl iox_$user_output ptr ext; dcl print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl syserr_log_util_$open entry (bit (36) aligned, fixed bin (35)); dcl syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl syserr_log_util_$close entry (fixed bin (35)); dcl syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35)); dcl cleanup condition; dcl (length, fixed, addr, addrel, baseptr, substr, null, hbound, lbound, bin, index, rtrim, unspec, verify) builtin; %page; /* Initialization */ on cleanup call clean_up; call get_temp_segments_ (name, ptr_array, code); /* Get a work segment */ if code ^= 0 then do; call com_err_ (code, name, "Can't get temp segment"); go to done; end; segs_allocated = "1"b; /* Recpuber that they are allocated */ workp = ptr_array (1); /* Copy pointer to my segment */ call cu_$arg_list_ptr (arg_list_ptr); /* Need pointer to argument list */ call cu_$arg_count (arg_count); /* And the length */ more_args = (arg_count > 0); /* Set if args to scan */ call scan_args; /* Scan the argument list */ call syserr_log_util_$open (open_status, code); /* Open the syserr log */ if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do; /* If error */ call print_syserr_msg_$open_err (open_status, name, code); if code ^= 0 then go to done; /* Not recoverable */ end; if ^from_sw then do; /* No -from, so start at beginning */ call syserr_log_util_$search (0, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Can't find first message in log."); go to done; end; from_time = msg_time; /* Official starting time */ end; else do; /* -from used, find right message */ call syserr_log_util_$search (from_time, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Locating first message requested."); go to done; end; end; if for_sw then do; /* Now can compute -for limit */ call convert_date_to_binary_$relative (for_arg, to_time, from_time, code); if code ^= 0 then do; call com_err_ (code, name, "-for ^a", for_arg); go to done; end; to_sw = "1"b; /* Now, just as if -to was specified */ end; if ^to_sw then to_time = from_time; /* Initialize last message time */ syserr_msgp = addr (work.buffer); /* Read here */ %page; call print_header; /* Loop thru the file */ read_cnt = 0; loop: call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code); if code ^= 0 then do; if code = error_table_$end_of_info then go to done; call com_err_ (code, name, "Reading syserr log"); go to done; end; read_cnt = read_cnt + 1; if to_sw then do; /* If time limit */ if syserr_msg.time > to_time then go to done; end; else to_time = syserr_msg.time; /* Save last message time */ if scan_text then do; do def_idx = lbound (display_cpu_error_binary_defs, 1) to hbound (display_cpu_error_binary_defs, 1); if display_cpu_error_binary_defs (def_idx) = syserr_msg.data_code then goto continue_check; end; goto loop; /* wrong type */ continue_check: if syserr_msg.data_size <= 0 then goto loop; /* no binary data */ ctextl = syserr_msg.text_len; /* Save length */ substr (ctext, 1, ctextl) = syserr_msg.text; /* Save data */ if match_sw then /* If matching strings */ if ^match_string (addr (match_data)) then goto loop; if exclude_sw then /* If excluding by string */ if match_string (addr (exclude_data)) then goto loop; call print_it; goto loop; end; /* DEFAULT */ if syserr_msg.data_code = SB_hw_fault & syserr_msg.data_size > 0 then call print_it; go to loop; /* End of log reached */ /* End of command */ done: if print_cnt = 0 then do; /* if no messages printed */ if read_cnt = 0 then plural_sw = "1"b; call com_err_ (0, name, "No messages matched criteria given. ^d message^v(s ^) read.", read_cnt, plural_sw) ; end; call clean_up; return; miss_err: call com_err_ (0, name, "Argument required after ^a.", arg_copy); goto done; %page; /* Procedure to scan the argument list */ scan_args: proc; do while (more_args); /* Do while thins to look at */ call get_arg; if arg = "-from" | arg = "-fm" then do; /* Start time */ from_sw = "1"b; call time_arg (from_time); end; else if arg = "-to" then do; /* Ending time */ to_sw = "1"b; call time_arg (to_time); end; else if arg = "-for" then do; /* Time limit */ for_sw = "1"b; call time_arg (for_time); /* For syntax checking only */ for_len = arg_len; /* Save pointer to this argument */ for_ptr = arg_ptr; end; else if arg = "-expand" | arg = "-exp" then do; thread_sw = "0"b; expand_sw = "1"b; end; else if arg = "-nothread" then thread_sw = "0"b; else if arg = "-mc" then only_scu = "1"b; else if arg = "-cpu" then do; /* List of CPUs */ if ^more_args then do; /* Need more args */ no_cpu: call com_err_ (0, name, "Argument missing after -cpu"); go to done; end; call get_arg; if verify (arg, CPU_TAGS) ^= 0 then do; new_cpu: call com_err_ (0, name, "Invalid CPU Tag(s) ^a", arg); return; end; if arg_len > 8 then do; call com_err_ (0, name, "Too many CPUs specified (^a).", arg); return; end; do argc = 1 to arg_len; work.cpureq (argc) = substr (arg, argc, 1); cpu_cnt = cpu_cnt + 1; /* Count CPU found */ end; end; else if arg = "-all" | arg = "-a" then scan_text = "1"b; /* scan all valid syserr types. */ else if arg = "-match" then do; call string_check (addr (match_data)); /* Add to match string */ match_sw = "1"b; scan_text = "1"b; end; else if arg = "-exclude" | arg = "-ex" then do; call string_check (addr (exclude_data));/* Add to exclude list */ exclude_sw = "1"b; scan_text = "1"b; end; else do; /* Bad arg */ call com_err_ (error_table_$badopt, name, "^a", arg); go to done; end; end; if to_sw & for_sw then do; /* Conflict */ call com_err_ (0, name, "Conflicting arguments: -to and -for"); go to done; end; return; end scan_args; %page; /* Procedure to return the next argument from command line */ get_arg: proc; call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then do; /* Should never happen */ call com_err_ (code, name, "Arg ^d", arg_no); go to done; end; arg_no = arg_no + 1; /* For next call */ more_args = (arg_no <= arg_count); return; put_arg: entry; /* Entry to return argument after scanning too far */ arg_no = arg_no - 1; more_args = (arg_no <= arg_count); return; end get_arg; /* Procedure to convert a time argument */ time_arg: proc (t); dcl arg_copy char (10) var; /* Save copy of arg here */ dcl t fixed bin (71); /* The time to ouput */ arg_copy = arg; if ^more_args then do; /* Must be more */ call com_err_ (0, name, "Argument required after ^a.", arg_copy); go to done; end; call get_arg; call convert_date_to_binary_ (arg, t, code); if code ^= 0 then do; call com_err_ (code, name, "^a ^a", arg_copy, arg); go to done; end; return; end time_arg; %page; /* Procedure to add a string to list of strings */ string_check: proc (p); dcl p ptr; /* Pointer to header block */ dcl 1 sdata like string_data based (p); /* The header block */ dcl link ptr; /* A temp pointer */ arg_copy = arg; /* Save copy of control argument */ if ^more_args then go to miss_err; /* Another argument is needed */ call get_arg; /* So get it */ if area_ptr = null then area_ptr = get_system_free_area_ (); /* If this is first allocate */ scheck: allocate str in (free_area) set (link); if sdata.count = 0 then sdata.first = link; /* If first in chain */ else sdata.last -> str.next = link; /* If not first, add to chain */ sdata.last = link; /* This is last in chain */ sdata.count = sdata.count + 1; /* Count it */ link -> str.data = arg; /* Copy the real string */ if ^more_args then return; /* If no more args, then all done here */ call get_arg; /* Get next arg */ if substr (arg, 1, 1) ^= "-" then go to scheck; /* If not control arg, treat as string */ call put_arg; /* Return argument so next user can get it */ return; end string_check; %page; /* Procedure to match a string */ match_string: proc (p) returns (bit (1) aligned); dcl (p, q) ptr; dcl 1 mdata like string_data based (p); /* String list structure */ if mdata.count = 0 then return ("0"b); /* Return no if list empty */ q = mdata.first; /* Get first in list */ do while (q ^= null); /* Do until end */ if index (substr (ctext, 1, ctextl), q -> str.data) ^= 0 then return ("1"b); q = q -> str.next; end; return ("0"b); /* No match */ end match_string; %page; /* Procedure to print a cpu error entry */ print_it: proc; dcl PRS (0:7) ptr aligned; dcl cpu char (1); dcl cpu_tag (8) char (1) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl error_msg char (100) aligned; dcl found bit (1); dcl hr_ptr ptr; dcl tcpu char (1); dcl (i, j) fixed bin; found = "0"b; fmsgp = addr (syserr_msg.data); scup = addr (mach_cond.scu); hr_ptr = addr (fault_msg.hist_reg); i = index (syserr_msg.text, " CPU "); if i = 0 then do; if cpu_cnt = 0 then goto p_data; /* any CPU */ i = fixed (scu.cpu_no, 17) + 1; cpu = cpu_tag (i); do j = 1 to cpu_cnt while (found = "0"b); if cpu = work.cpureq (j) then found = "1"b; end; if ^found then return; /* This cpu not in list */ goto p_data; end; tcpu = substr (syserr_msg.text, i + 5, 1); cpu = cpu_tag (index ("ABCDEFGH", tcpu)); if cpu_cnt > 0 then do j = 1 to cpu_cnt while (found = "0"b); if cpu = work.cpureq (j) then found = "1"b; end; if cpu_cnt > 0 then if ^found then return; /* don't count this one */ p_data: /* found one, print it */ call ioa_ ("^/^a ^d^/^a", date_time_$format ("date_time", (syserr_msg.time), "", ""), syserr_msg.seq_num, syserr_msg.text); unspec (PRS) = unspec (mach_cond.prs); call ioa_ ("^/Pointer Registers:^-^12p ^12p ^12p ^12p^/^2-^12p ^12p ^12p ^12p", PRS); call ioa_ ( "^/Index Registers:^-x0: ^6.3b x1: ^6.3b x2: ^6.3b x3: ^6.3b^/^2-x4: ^6.3b x5: ^6.3b x6: ^6.3b x7: ^6.3b", mach_cond.x); call ioa_ ("^2-A: ^w Q: ^w EXP: ^3.3b^/^2-Timer: ^9.3b Ring Alarm Reg: ^.3b^/", mach_cond.a, mach_cond.q, "0"b || mach_cond.e, mach_cond.t, mach_cond.ralr); if mach_cond.mask ^= "0"b then call ioa_ ("Memory Controller Mask: ^12.3b ^12.3b", substr (mach_cond.mask, 1, 36), substr (mach_cond.mask, 37, 36)); if mach_cond.errcode ^= 0 then do; call convert_status_code_ ((mach_cond.errcode), (""), error_msg); call ioa_ ("MC.ERRCODE:^/^a", rtrim (error_msg)); end; call ioa_ ("MC Fault Time: ^a (^18.3b)", date_time_$format ("date_time", fixed (mach_cond.fault_time, 71), "", ""), mach_cond.fault_time); call interpret_fault_reg ((mach_cond.fault_reg)); if mach_cond.cpu_type ^= 0 then if mach_cond.ext_fault_reg ^= "0"b then call interpret_ext_fault_reg ((mach_cond.ext_fault_reg)); if scu.mif then call ioa_ ("EIS Info:^-^w ^w ^w ^w^/^-^w ^w ^w ^w", mach_cond.eis_info); call ioa_ ("^/SCU Data:^2-^w ^w ^w ^w^/^2-^w ^w ^w ^w^/", mach_cond.scu); call interp_scu (scup); print_cnt = print_cnt + 1; if only_scu = "1"b then return; hr_switches = expand_sw || "1"b || "1"b || "1"b || "1"b; call ioa_ ("^/History Register Data:^/"); if thread_sw then call hran_$hranl (hr_ptr, null, "0"b); else call hran_$no_thread (hr_ptr, null, hr_switches); return; end print_it; %page; /* Procedure to print the header line */ print_header: proc; tm1 = date_time_$format ("date_time", from_time, "", ""); /* Starting time is easy */ if to_sw then tm2 = date_time_$format ("date_time", to_time, "", ""); /* Stop time is easy if given */ else do; /* Otherwise get last message */ call syserr_log_util_$search (-1, msg_time, msg_seq, code); /* Search to eof */ if code ^= 0 then do; /* Should not fail */ log_err: call com_err_ (code, name, "From syserr_log_util_$search."); return; end; tm2 = date_time_$format ("date_time", msg_time, "", ""); /* Edit time */ call syserr_log_util_$search (from_time, msg_time, msg_seq, code); /* Back to first msg */ if code ^= 0 then go to log_err; end; call ioa_ ("^/Syserr log from ^a to ^a", tm1, tm2); print_cnt = 0; return; end print_header; %page; /* Cleanup handler */ clean_up: proc; call syserr_log_util_$close (code); if segs_allocated then do; segs_allocated = "0"b; call release_temp_segments_ (name, ptr_array, code); end; return; end clean_up; %page; /* Internal procedure to print fault reg data */ interpret_fault_reg: proc (fault_reg); dcl fault_reg bit (36); dcl (fault_no, break) fixed bin; dcl 1 illeg_acts based (addr (fault_reg)), ( 2 pad bit (16), 2 IA (4) bit (4), 2 pad1 bit (4) ) unal; dcl port_name (4) char (3) int static options (constant) init ("A: ", "B: ", "C: ", "D: "); dcl (line1, line2) char (80) varying; dcl (line1_sw, line2_sw) bit (1) init ("0"b); dcl FAULT_TYPES (36) char (15) var int static options (constant) init ("ILL OP", "ILL MOD", "ILL SLV", "ILL PROC", "NEM", "OOB", "WRT INH", "PROC PAR-UPR", "PROC PAR-LWR", "$CON A", "$CON B", "$CON C", "$CON D", "ONC (DA ERR1)", "ONC (DA ERR2)", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "", "CACHE-PAR DIR", "CACHE-PAR STR", "CACHE-PAR IA", "CACHE-PAR BLK"); dcl SC_IA_TYPES (1:15) char (42) var int static options (constant) init ("Unassigned (01)", "Non-existent Address (02)", "Stop on Condition (03)", "Unassigned (04)", "Data Parity, Store to SC (05)", "Data Parity in Store (06)", "Data Parity in Store AND Store to SC (07)", "Not Control (10)", "Port Not Enabled (11)", "Illegal Command (12)", "Store Not Ready ( 13)", "ZAC Parity, Active Module to SC (14)", "Data Parity, Active Module to SC (15)", "ZAC Parity, SC to Store (16)", "Data Parity, SC to Store (17)"); if fault_reg = "0"b then return; line1, line2 = ""; do fault_no = 1 to 15; if substr (fault_reg, fault_no, 1) = "1"b then do; line1 = line1 || FAULT_TYPES (fault_no) || ", "; line1_sw = "1"b; end; end; break = 0; do fault_no = 1 to 4 while (break = 0); /* do IAs now */ if IA (fault_no) then do; line2 = "Ilegal Action on CPU Port " || port_name (fault_no); line2 = line2 || SC_IA_TYPES (bin (IA (fault_no), 4)) || ", "; line2_sw = "1"b; break = 1; end; end; do fault_no = 33 to 36; if substr (fault_reg, fault_no, 1) = "1"b then do; line1 = line1 || FAULT_TYPES (fault_no) || ", "; line1_sw = "1"b; end; end; if line1_sw then /* remove trailing comma & space */ line1 = substr (line1, 1, (length (line1) - 2)); if line2_sw then line2 = substr (line2, 1, (length (line2) - 2)); call ioa_ ("^/Fault Register:^-^w^[ (^a)^;^s^]^[^/^18t(^a)^]", fault_reg, line1_sw, line1, line2_sw, line2); return; %page; interpret_ext_fault_reg: entry (ext_fault_reg); dcl ext_fault_reg bit (15); dcl indx fixed bin; dcl EXT_FAULT_TYPES (15) char (39) var int static options (constant) init ("Bffr. Ovflw - Port A", "Bffr. Ovflw - Port B", "Bffr. Ovflw - Port C", "Bffr. Ovflw - Port D", "Bffr. Ovflw - Primary Dir", "Write Notify Parity Error on ANY Port", "Dup. Dir. LVL 0 Parity Error", "Dup. Dir. LVL 1 Parity Error", "Dup. Dir. LVL 2 Parity Error", "Dup. Dir. LVL 3 Parity Error", "Dup. Dir. Multi Match Error", "PTW Ass. Mem. Parity Error", "PTW Ass. Mem. Match Error", "SDW Ass. Mem. Parity Error", "SDW Ass. Mem. Match Error"); line1 = ""; do indx = 1 to 15; if substr (ext_fault_reg, indx, 1) = "1"b then line1 = line1 || EXT_FAULT_TYPES (indx) || ", "; end; if line1 ^= "" then do; line1 = substr (line1, 1, (length (line1) - 2)); call ioa_ ("^/DPS8 Extended Fault Register: ^5.3b^/^32t(^a)", ext_fault_reg, line1); end; return; end interpret_fault_reg; %page; interp_scu: proc (scup); dcl at_by_wd char (2); dcl cpul (0:7) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl cvbinbuf char (12); dcl flt_bf char (24) varying; dcl flt_ln char (100); dcl fltdtab (0:35) bit (1) based (byptr) unaligned; dcl iocbp ptr; dcl scup ptr; /* pointer to SCU Data */ dcl TAG_ptr ptr; /* pointer to tag table */ dcl 1 TAG (64) based (TAG_ptr), 2 code char (4) unal, 2 pad bit (8) unal, 2 chain bit (1); dcl tag_prt bit (1) init ("0"b); dcl tag_ char (4) init (""); dcl (lnpos, flt_lng, inst6, i, j) fixed bin; dcl (byptr, refptr) ptr; dcl tsrpr bit (1); dcl 1 scud based (scup) aligned, 2 wd0 unaligned, /* :: */ 3 prr bit (3), /* Procedure Ring Register */ 3 psr bit (15), /* Procedure Segment Register */ 3 apust bit (18), /* APU Status */ 2 wd1 unaligned, /* :: */ 3 fid bit (20), /* fault/interrupt data */ 3 ill_act_lns bit (4), /* Illegal Action Lines */ 3 ill_act_chan bit (3), /* Illegal Action Channel (Port) */ 3 con_chan bit (3), /* Connect Channel (Port) */ 3 fi bit (6), /* Fault/Interrupt Vector Address */ 2 wd2 unaligned, /* :: */ 3 trr bit (3), /* Temporary Ring Register */ 3 tsr bit (15), /* Temporary Segment Register */ 3 mbz bit (9), /* :: */ 3 cpu bit (3), /* Processor Number */ 3 tmd bit (6), /* :: */ 2 wd3 fixed bin (35), /* :: */ 2 wd4 unaligned, /* :: */ 3 ict bit (18), /* Instruction Counter */ 3 ir bit (18), /* Indicator Register */ 2 wd5 unaligned, /* :: */ 3 ca bit (18), /* Computed Address */ 3 cus bit (12), /* CU Status */ 3 ct_hold bit (6), /* remember mod field */ 2 wd6 fixed bin (35), /* Even Instruction */ 2 wd7 fixed bin (35); /* Odd Instruction */ /* Constants */ dcl ill_act (0:15) char (37) varying int static options (constant) init ("...", "Unassigned", "Non Existent Address", "Fault on Condition", "Unassigned", "Data Parity (Store -> SCU)", "Data Parity in Store", "Data Parity (Store -> SCU & in Store)", "Not Control", "Port Not Enabled", "Illegal Command", "Store Not Ready", "ZAC Parity (Processor -> SCU)", "Data Parity (Processor -> SCU)", "ZAC parity (SCU -> Store)", "Data Parity (SCU -> Store)"); dcl indrs (18:31) char (4) varying int static options (constant) init ("zero", "neg", "cary", "ovfl", "eovf", "eufl", "oflm", "tro", "par", "parm", "^bar", "tru", "mif", "abs"); dcl APU (18:32) char (6) varying int static options (constant) init ("priv", "xsf", "sdwamm", "sd-on", "ptwamm", "pt-on", "pi-ap", "dsptw", "sdwnp", "sdwp", "ptw", "ptw2", "fap", "fanp", "fabs"); dcl CU (18:29) char (3) varying int static options (constant) init ("rf", "rpt", "rd", "rl", "pot", "pon", "xde", "xdo", "itp", "rfi", "its", "fif"); dcl g1and7flts (5) bit (6) int static options (constant) unaligned init ("01"b3, "11"b3, "21"b3, "31"b3, "37"b3); dcl grp1flt (0:19) char (24) varying int static options (constant) init ("Illegal Ring Order", "Not in Execute Bracket", "Execute Bit off", "Not In Read Bracket", "Read Bit Off", "Not In Write Bracket", "Write Bit Off", "Not A Gate", "Not In Call Bracket", "Outward Call", "Bad Outward Call", "Inward Return", "Cross Ring Transfer", "Ring Alarm", "Associative Memory", "Out of Segment Bounds", "Processor Parity Upper", "Processor Parity Lower", "SC To Proc. Seq. Error 1", "SC To Proc. Seq. Error 2"); dcl grp2flt (0:6) char (24) varying int static options (constant) init ("Illegal Segment Number", "Illegal Op Code", "Illegal Address & Mod", "Illegal Slave Procedure", "Illegal Procedure", "Non Existent Address", "Out Of Bounds"); dcl flt_int_typ (0:63) char (24) varying int static options (constant) init ("...", "Shutdown", "...", "Store", "Bulk Store 0 Term", "MME 1", "...", "Fault Tag 1", "IOM 0 Overhead", "Timer Runout", "IOM 1 Overhead", "Command", "IOM 2 Overhead", "Derail", "IOM 3 Overhead", "Lockup", "IOM 0 Terminate Ch 40-77", "Connect", "IOM 1 Terminate Ch 40-77", "Parity", "Bulk Store 1 Term", "Illegal Procedure", "...", "Op Not Complete", "IOM 0 Terminate", "Startup", "IOM 1 Terminate", "Overflow", "IOM 2 Terminate", "Divide Check", "IOM 3 Terminate", "Execute", "IOM 0 Marker Ch 40-77", "(DF0) Segment", "IOM 1 Marker Ch 40-77", "(DF1) Page", "...", "Directed Fault 2", "...", "Directed Fault 3", "IOM 0 Marker", "Access Violation", "IOM 1 Marker", "MME 2", "IOM 2 Marker", "MME 3", "IOM 3 Marker", "MME 4", "...", "(FT2) Linkage", "...", "Fault Tag 3", "...", "...", "...", "...", "IOM 0 Special", "...", "IOM 1 Special", "...", "IOM 2 Special", "...", "IOM 3 Special", "Trouble"); dcl TAG_table (8) char (40) int static options (constant) init ( /* tag table */ " au qu du ic al ql dl ", "x0 x1 x2 x3 x4 x5 x6 x7 ", "n* aau* aqu* ailtg ic* aal* aql* ailtg ", "0* a1* a2* a3* a4* a5* a6* a7* a", "fi itp iltg its sd scr f2 f3 ", "ci i sc ad di dic aid idc a", "*n *au *qu iltg *ic *al *ql iltg ", "*0 *1 *2 *3 *4 *5 *6 *7 "); %page; flt_ln, flt_bf = ""; tsrpr = "0"b; flt_bf = flt_int_typ (fixed (scud.wd1.fi, 6)); if substr (flt_bf, 1, 3) = "..." then call ioa_ ("^/Fault/Interrupt (^o), Undefined", fixed (scud.wd1.fi, 6)); else do; flt_lng = length (flt_int_typ (fixed (scud.wd1.fi, 6))); substr (flt_ln, 1, flt_lng) = substr (flt_bf, 1, flt_lng); byptr = addrel (scup, 1); if fltdtab (35) = "1"b then do; substr (flt_ln, flt_lng + 2, 5) = "Fault"; lnpos = flt_lng + 8; do i = 1 to hbound (g1and7flts, 1); /* If grp 1 or 7 faults, don't print out tsr|ca */ if scud.wd1.fi = g1and7flts (i) then tsrpr = "1"b; end; end; else do; substr (flt_ln, flt_lng + 2, 9) = "Interrupt"; lnpos = flt_lng + 12; tsrpr = "1"b; /* don't print out tsr|ca for interrupts */ end; flt_lng = fixed (scud.wd1.fi, 6); call cv_bin_$oct (flt_lng, cvbinbuf); substr (flt_ln, lnpos, 4) = "(" || substr (cvbinbuf, 11, 2) || ")"; lnpos = lnpos + 4; j = lnpos; do i = 0 to hbound (grp1flt, 1); if fltdtab (i) then do; if substr (flt_ln, 1, 5) = "Store" | substr (flt_ln, 1, 12) = "Illegal Proc" then if i <= 6 then call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp2flt (i)); else ; else call ioa_$rsnnl ("^a, ^a", flt_ln, j, flt_ln, grp1flt (i)); end; end; call ioa_ ("^a", flt_ln); end; if ill_act_lns ^= "0"b then do; /* display illegal action lines if present */ call ioa_ ("Illegal Action Code (^o) - ^a", fixed (scud.wd1.ill_act_lns, 4), ill_act (fixed (scud.wd1.ill_act_lns, 4))); end; if tsrpr then at_by_wd = "At"; /* if not printing tsr */ else at_by_wd = "By"; byptr = addrel (baseptr (fixed (scud.wd0.psr, 18)), fixed (scud.wd4.ict, 18)); if ^tsrpr then refptr = addrel (baseptr (fixed (scud.wd2.tsr, 18)), fixed (scud.wd5.ca, 18)); call ioa_ ("^a: ^p", at_by_wd, byptr); if ^tsrpr then /* if we want to print out tsr|ca */ call ioa_ ("Referencing: ^p", refptr); call ioa_ ("On: cpu ^a (#^o)", cpul (fixed (scud.wd2.cpu, 3)), fixed (scud.wd2.cpu, 3)); flt_ln = ""; byptr = addr (scud.wd4); /* display Indicator register if any bits present */ do i = lbound (indrs, 1) to hbound (indrs, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, indrs (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("Indicators: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd0); /* display interpreted APU status if any bits present */ do i = lbound (APU, 1) to hbound (APU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, APU (i)); end; if flt_ln ^= "" then do; substr (flt_ln, j, 1) = " "; call ioa_ ("APU Status: ^a", flt_ln); flt_ln = ""; end; byptr = addr (scud.wd5); /* display interprted CU status if any bits present */ do i = lbound (CU, 1) to hbound (CU, 1); if fltdtab (i) then call ioa_$rsnnl ("^a ^a,", flt_ln, j, flt_ln, CU (i)); end; TAG_ptr = addr (TAG_table); i = fixed (wd5.ct_hold); if i ^= 0 then do; tag_ = TAG.code (i + 1); tag_prt = "1"b; end; if (flt_ln ^= "") | (tag_ ^= "") then do; substr (flt_ln, j, 1) = " "; call ioa_ ("CU Status: ^a ^[^/CT Hold: ^a^]", flt_ln, tag_prt, tag_); end; iocbp = iox_$user_output; call ioa_ ("Instructions: "); /* display Instructions (words 6 & 7) */ call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd6), "i", inst6, 1, null, 0, 0); call db_print (iocbp, iocbp -> iocb.name, addr (scud.wd7), "i", inst6 + 1, 1, null, 0, 0); return; end interp_scu; %page; %include syserr_message; %page; %include syserr_binary_def; %page; %include syserr_fault_msg; %page; %include mc; %page; %include iocb; end display_cpu_error;  display_rtdt.pl1 10/27/83 1614.3rew 10/27/83 1441.6 99459 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ display_rtdt: proc; /* This procedure formats and prints the contents of a Resource Type Description Table (RTDT). */ /* Written 03/13/78 by C. D. Tavares */ %include rtdt; dcl sysdir char (168) static initial (">system_control_1"), sysent char (32) static initial ("rtdt") options (constant); dcl null builtin; dcl cu_$arg_count ext entry (fixed bin), nargs fixed bin; dcl cu_$arg_list_ptr ext entry (pointer), alp pointer; rtdtp = null (); call cu_$arg_list_ptr (alp); call cu_$arg_count (nargs); begin; dcl dirname char (168), ename char (32); dcl temp_name char (128) aligned; dcl cu_$arg_ptr_rel ext entry (fixed bin, pointer, fixed bin, fixed bin (35), pointer), ap pointer, al fixed bin, arg based (ap) char (al), code fixed bin (35); dcl com_err_ ext entry options (variable), expand_pathname_$add_suffix ext entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$initiate_count ext entry (char (*), char (*), char (*), fixed bin (24), fixed bin, pointer, fixed bin (35)), bc fixed bin (24); dcl i fixed bin, header_sw bit (1) aligned, n_names_to_match fixed bin, date_time_string char (24), attribute_string char (512) varying; dcl ioa_ ext entry options (variable), hcs_$terminate_noname ext entry (pointer, fixed bin (35)), date_time_ ext entry (fixed bin (52), char (*)), clock_ ext entry returns (fixed bin (52)); dcl (error_table_$unimplemented_version, error_table_$name_not_found, error_table_$badopt) external fixed bin (35) static; dcl (index, length, null, pointer, reverse, string, substr) builtin, cleanup condition; dcl (convert_authorization_$to_string, convert_authorization_$from_string) ext entry (bit (72) aligned, char (*), fixed bin (35)); dcl (SYSTEM_HIGH, SYSTEM_LOW) bit (72) aligned; dcl matchnames (nargs) char (32); dcl temp_atts (2) bit (72); dcl cv_rcp_attributes_$to_string_given_rtde ext entry (pointer, bit (72) dimension (2), char (*) varying, fixed bin (35)); call convert_authorization_$from_string (SYSTEM_LOW, "system_low", code); if code ^= 0 then call crump (code, "system_low"); call convert_authorization_$from_string (SYSTEM_HIGH, "system_high", code); if code ^= 0 then call crump (code, "system_high"); dirname = sysdir; ename = sysent; n_names_to_match = 0; header_sw = "1"b; do i = 1 to nargs; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "obtaining arguments"); if arg = "-pn" | arg = "-pathname" then do; i = i + 1; call cu_$arg_ptr_rel (i, ap, al, code, alp); if code ^= 0 then call crump (code, "No pathname supplied."); call expand_pathname_$add_suffix (arg, "rtdt", dirname, ename, code); if code ^= 0 then call crump (code, arg); end; else if arg = "-nhe" | arg = "-no_header" then header_sw = ""b; else if substr (arg, 1, 1) = "-" then call crump (error_table_$badopt, arg); else do; n_names_to_match = n_names_to_match + 1; matchnames (n_names_to_match) = arg; end; end; on cleanup call clean_up; /* ------------------------- */ clean_up: proc; if rtdtp ^= null then call hcs_$terminate_noname (rtdtp, 0); end clean_up; /* ------------------------- */ call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code); if rtdtp = null then if ename = "rtdt.rtdt" then do; ename = "rtdt"; call hcs_$initiate_count (dirname, ename, "", bc, 0, rtdtp, code); end; if rtdtp = null then call crump (code, "^a>^a"); if (rtdt.version ^= RTDT_version_2) & (rtdt.version ^= RTDT_version_3) then call crump (error_table_$unimplemented_version, "^a>^a"); if header_sw then do; call date_time_ (clock_ (), date_time_string); call ioa_ ("/* ^a>^a -- ^a */^/", dirname, ename, date_time_string); call ioa_ ("/* Author: ^a */^/", rtdt.author.proc_group_id); end; cttp = pointer (rtdt.charge_type_table_ptr, rtdt.rtdt_area); do rtdep = pointer (rtdt.first_resource, rtdt.rtdt_area) repeat (pointer (rtde.next_resource, rtdt.rtdt_area)) while (rtdep ^= null); if rtde.valid then do; do i = 1 to n_names_to_match while (matchnames (i) ^= rtde.name); end; if (i <= n_names_to_match | n_names_to_match = 0) then do; if i <= n_names_to_match then matchnames (i) = ""; call ioa_ ("^/^[Volume^;Device^]:^2-^a;", rtde.is_volume, rtde.name); if rtde.is_synonym then call ioa_ ("Like:^2-^a;", rtde.syn_to); else do; temp_atts (1) = rtde.attributes_valid; temp_atts (2) = rtde.attributes_to_match; call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code); if code ^= 0 then do; call com_err_ (code, "display_rtdt", "Error displaying attributes for ^a", rtde.name); attribute_string = ""; end; attribute_string = attribute_string || ";"; if attribute_string = ";" then call ioa_ ("Attribute_domain:^-;"); else do i = 1 by 1 while (attribute_string ^= ""); call ioa_ ("^[Attribute_domain:^-^;^2- ^]^a", (i = 1), knockoff_50_ch (attribute_string)); end; call ioa_ ("Limit:^2-^[open^;^d^];", (rtde.process_limit = -1), rtde.process_limit); call ioa_ ("Time:^2-^[open^;^[^d^;^d, ^d^]^];", (rtde.default_time >= 4880), (rtde.default_time = rtde.max_time), rtde.default_time, rtde.max_time); if rtde.n_mates = 0 then call ioa_ ("^[Implies^;Accepts^]:^2-;", (rtde.is_volume)); else call ioa_ ("^[Implies^;Accepts^]:^2-^v(^a, ^)^a;", (rtde.is_volume), rtde.n_mates - 1, rtde.mates (*)); call ioa_ ("Manual_clear:^-^[yes^;no^];", rtde.manual_clear); call ioa_ ("Advance_notice:^-^[none^;^d^];", (rtde.advance_notice_time = -1), rtde.advance_notice_time); call ioa_ ("Canonicalizer:^-^[^a^;^];", (rtdt.version = RTDT_version_3), rtde.precanon_proc); call ioa_ (""); call display_subtype (rtde.name, rtde.registration_defaults, 0); do i = 1 to rtde.n_subtypes; call ioa_ ("^/type:^2-^a;", rtde.subtype_name (i)); temp_name = rtrim (rtde.name) || " (" || rtrim (rtde.subtype_name (i)) || ")"; call display_subtype (rtde.name, rtde.subtype_defaults (i), 5); end; end; end; end; if n_names_to_match = 0 then call ioa_ ("^//* --------------- */"); end; call clean_up; if n_names_to_match = 0 then call ioa_ ("^/end;"); else do i = 1 to n_names_to_match; if matchnames (i) ^= "" then call com_err_ (error_table_$name_not_found, "display_rtdt", matchnames (i)); end; return; display_subtype: proc (item_name, struc, indent); dcl item_name char (*) aligned parameter; dcl 1 struc like rtde.registration_defaults aligned parameter; dcl indent fixed bin parameter; dcl (low_auth_string, high_auth_string) char (128), i fixed bin; if struc.potential_attributes_given then do; temp_atts (1) = struc.potential_attributes; temp_atts (2) = ""b; call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code); if code ^= 0 then do; call com_err_ (code, "display_rtdt", "Error displaying potential attributes for ^a", item_name); attribute_string = ""; end; attribute_string = attribute_string || ";"; if attribute_string = ";" then call ioa_ ("^vxpotential_attributes: ;", indent); else do i = 1 by 1 while (attribute_string ^= ""); call ioa_ ("^[^vxpotential_attributes:^/^2-^vx^;^s^2-^vx ^]^a", (i = 1), indent, indent, knockoff_50_ch (attribute_string)); end; end; if struc.attributes_given then do; temp_atts (1) = struc.attributes; temp_atts (2) = ""b; call cv_rcp_attributes_$to_string_given_rtde (rtdep, temp_atts, attribute_string, code); if code ^= 0 then do; call com_err_ (code, "display_rtdt", "Error displaying attributes for ^a", item_name); attribute_string = ""; end; attribute_string = attribute_string || ";"; if attribute_string = ";" then call ioa_ ("^vxattributes: ;", indent); else do i = 1 by 1 while (attribute_string ^= ""); call ioa_ ("^[^vxattributes:^-^vx^;^s^2-^vx ^]^a", (i = 1), indent, indent, knockoff_50_ch (attribute_string)); end; end; if struc.charge_type_given then call ioa_ ("^vxcharge_type:^-^vx^a;", indent, indent, charge_type_table.charge_types (struc.charge_type)); if struc.aim_range_given then do; code = 0; if struc.aim_range (1) = SYSTEM_LOW then low_auth_string = "system_low"; else if struc.aim_range (1) = SYSTEM_HIGH then low_auth_string = "system_high"; else call convert_authorization_$to_string (struc.aim_range (1), low_auth_string, code); if code ^= 0 then do; call com_err_ (code, "display_rtdt", "While converting min access class of ^a.; assuming system_low.", item_name); low_auth_string = "system_low"; end; if struc.aim_range (2) = SYSTEM_LOW then high_auth_string = "system_low"; else if struc.aim_range (2) = SYSTEM_HIGH then high_auth_string = "system_high"; else call convert_authorization_$to_string (struc.aim_range (2), high_auth_string, code); if code ^= 0 then do; call com_err_ (code, "display_rtdt", "While converting max access class of ^a; assuming system_high.", item_name); high_auth_string = "system_high"; end; call ioa_ ("^vxaccess_range:^-^vx""^a : ^a"";", indent, indent, low_auth_string, high_auth_string); end; return; end display_subtype; knockoff_50_ch: proc (string) returns (char (50) varying); dcl string char (512) varying parameter; dcl i fixed bin, temp char (50) varying; if length (string) <= 50 then do; temp = string; string = ""; return (temp); end; i = 51 - index (reverse (substr (string, 1, 50)), ","); temp = substr (string, 1, i); string = substr (string, i+1); return (temp); end knockoff_50_ch; crump: proc (code, reason); dcl code fixed bin (35) parameter, reason char (*) parameter; call com_err_ (code, "display_rtdt", reason, dirname, ename); call clean_up; goto return_hard; end crump; end; /* end begin block */ return_hard: return; end display_rtdt;  dump_abs_data.pl1 10/27/83 1614.3rew 10/27/83 1441.7 85428 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* DUMP_ABS_DATA - Program to dump >sc1>absentee_data Written 751022 by PG Modified by T. Casey, May 1978, to dump resource list information. Modified by T. Casey, November 1978 for MR7.0 absentee enhancements. Modified by T. Casey, June 1981, for MR9.0, to dump version 2 abs_data structure. */ dump_abs_data: procedure; /* automatic */ declare (adp, arg_ptr) ptr, (aix, argno, n, queuex) fixed bin, arg_len fixed bin (21), code fixed bin (35), date_time char (24), dname char (168), ename char (32), line char (136) varying, long bit (1) aligned; dcl fq fixed bin init (-1); dcl lq fixed bin init (4); /* based */ declare arg_string char (arg_len) based (arg_ptr); /* builtins */ declare (addr, length, null, substr, unspec) builtin; /* conditions */ declare cleanup condition; /* pictures */ declare five_digits picture "zzzz9"; /* internal static */ declare my_name char (13) internal static initial ("dump_abs_data"); dcl lc_reasons (0:3) char (16) int static options (constant) init ( "zero", "user_limit", "project_limit", "group_limit"); /* external static */ dcl error_table_$badopt ext fixed bin (35); /* entries */ declare clock_ entry () returns (fixed bin (71)), com_err_ entry options (variable), cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin (35)), cu_$arg_count entry returns (fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), date_time_ entry (fixed bin (71), char (*)), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ioa_ entry options (variable); dcl request_id_ entry (fixed bin (71)) returns (char (19)); /* include files */ %include abs_data; /* program */ long = "0"b; dname = ">system_control_1"; ename = "absentee_data"; adp = null; do argno = 1 to cu_$arg_count (); call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code = 0 then do; if arg_string = "-lg" | arg_string = "-long" then long = "1"b; else if arg_string = "-q" | arg_string = "-queue" then do; argno = argno + 1; call cu_$arg_ptr (argno, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, my_name, "after -queue"); return; end; if arg_string = "fg" | arg_string = "foreground" then fq, lq = -1; else fq, lq = cv_dec_check_ ((arg_string), code); if code ^= 0 then do; badq: call com_err_ (0, my_name, "Illegal queue number: ""^a""", arg_string); return; end; if fq < -1 | fq > 4 then goto badq; end; else if substr (arg_string, 1, 1) = "-" then do; call com_err_ (error_table_$badopt, my_name, "^a", arg_string); return; end; else do; call expand_pathname_ (arg_string, dname, ename, code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; end; end; else call com_err_ (code, my_name); end; /* end loop through args */ on cleanup call clean_up; call hcs_$initiate (dname, ename, "", 0, 1, adp, code); if adp = null then do; call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; if absentee_data.version ^= ABS_DATA_version_2 then do; /* check for wrong version */ call com_err_ (0, my_name, "Incorrect structure version (^d) in ^a>^a", absentee_data.version, dname, ename); return; end; call date_time_ (clock_ (), date_time); call ioa_ ("^/Dump of ^a>^a - ^a^/", dname, ename, date_time); call ioa_ ("last:^21t^d", absentee_data.last); line = " FREE LIST: "; do n = absentee_data.tail_free repeat (abs_info.prev_free) while (n ^= 0); aip = addr (absentee_data.entry (n)); five_digits = n; if length (line) > 70 then do; call ioa_ (line); line = (18)" "; end; line = line || five_digits; end; if length (line) > length (" FREE LIST: ") then call ioa_ (line); do queuex = fq to lq; call ioa_ ("^/QUEUE ^d", queuex); line = " SKIP LIST: "; do n = absentee_data.queue_data (queuex).head_skip repeat (abs_info.next_skip) while (n ^= 0); aip = addr (absentee_data.entry (n)); five_digits = n; if length (line) > 70 then do; call ioa_ (line); line = (17)" "; end; line = line || five_digits; end; if length (line) > length (" SKIP LIST: ") then call ioa_ (line); if absentee_data.queue_data (queuex).tail_run ^= 0 then call ioa_ ("^2xTAIL RUN:^21t^d", absentee_data.queue_data (queuex).tail_run); line = " READY LIST: "; do n = absentee_data.queue_data (queuex).head_ready repeat (abs_info.next_ready) while (n ^= 0); aip = addr (absentee_data.entry (n)); five_digits = n; if length (line) > 70 then do; call ioa_ (line); line = (17)" "; end; line = line || five_digits; end; if length (line) > length (" READY LIST: ") then call ioa_ (line); if absentee_data.queue_data (queuex).tail_resource ^= 0 then call ioa_ ("^2xTAIL RESOURCE:^21t^d", absentee_data.queue_data (queuex).tail_resource); line = " CPUT LIST: "; do n = absentee_data.queue_data (queuex).head_cput repeat (abs_info.next_cput) while (n ^= 0); aip = addr (absentee_data.entry (n)); five_digits = n; if length (line) > 70 then do; call ioa_ (line); line = (17)" "; end; line = line || five_digits; end; if length (line) > length (" CPUT LIST: ") then call ioa_ (line); end; line = " DEFER LIST: "; do n = absentee_data.head_defer repeat (abs_info.next_defer) while (n ^= 0); aip = addr (absentee_data.entry (n)); five_digits = n; if length (line) > 70 then do; call ioa_ (line); line = " "; end; line = line || five_digits; end; if length (line) > length (" DEFER LIST: ") then call ioa_ (line); do aix = 1 to absentee_data.last; aip = addr (absentee_data.entry (aix)); if abs_info.queue < fq | abs_info.queue > lq then /* if user specified queue, and entry is from wrong queue */ goto skip_this_entry; /* then skip it */ /* Start of future dump_entry internal procedure */ call ioa_ ("^/ENTRY ^d", aix); if abs_info.free_list then call ioa_ ("^xFREE"); else do; if long then do; call ioa_ ("next_skip:^21t^d", abs_info.next_skip); call ioa_ ("prev_skip:^21t^d", abs_info.prev_skip); if abs_info.defer_list then do; call ioa_ ("next_defer:^21t^d", abs_info.next_defer); call ioa_ ("prev_defer:^21t^d", abs_info.prev_defer); end; if abs_info.ready_list then do; /* if on ready list */ call ioa_ ("next_ready:^21t^d", abs_info.next_ready); call ioa_ ("prev_ready:^21t^d", abs_info.prev_ready); end; if abs_info.cput_list then do; call ioa_ ("next_cput:^21t^d", abs_info.next_cput); call ioa_ ("prev_cput:^21t^d", abs_info.prev_cput); end; if abs_info.prev_free ^= 0 then call ioa_ ("prev_free:^21t^d", abs_info.prev_free); end; /* end -long */ call ioa_ ("queue:^21t^d", abs_info.queue); /* CHANGE TO "switches: sA, sB, ... " */ if abs_info.waiting_for_resources then call ioa_ ("waiting_for_resources:^21tON"); if abs_info.can_run then call ioa_ ("can_run:^21tON"); if abs_info.time ^= 0 then do; call date_time_ (abs_info.time, date_time); call ioa_ ("time:^21t^a", date_time); end; call ioa_ ("message_id:^21t^24.3b", abs_info.message_id); call ioa_ ("request_id:^21t^a", request_id_ (abs_info.request_id)); if abs_info.last_message_id ^= ""b then call ioa_ ("last_message_id:^21t^24.3b", abs_info.last_message_id); call ioa_ ("user:^21t^a.^a^[^x(^a)^]", abs_info.person, abs_info.project, (abs_info.group ^= ""), abs_info.group); if abs_info.waiting_for_load_ctl then call ioa_ ("deferred:^21t^a", lc_reasons (abs_info.lc_reason)); end; /* end of future dump_entry internal procedure */ skip_this_entry: end; call ioa_ ("^/END OF ABSENTEE_DATA"); call clean_up; return; clean_up: procedure; if adp ^= null then call hcs_$terminate_noname (adp, code); return; end clean_up; /* Make a dump_entry (aix) internal procedure, from the body of text marked above. Call it in the 1 to last loop. Add alternative options to print the entries in a particular list, in list order. Implement that by calling print_entry with the indices of the elements in that list. Add options -he (= just print the header (the lists, not the entries); . -nhe (= don't print the header). */ end dump_abs_data;  dump_anstbl_.pl1 07/13/88 1112.5rew 07/13/88 0904.5 278406 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ dump_anstbl_: proc (anp, hsw, osw, verb, sct, scu, stream); /* DUMP_ANSTBL_ - subroutine to take a dump of the answer table. Called by dump_anstbl command and as_dump_. Modified 750506 by PG for new anstbl format Modified May 1976 by T. Casey and P. Green to print new anstbl variables. Modified June 1977 by Robert Coren to remove obsolete terminal type fields. Modified May 1978 by T. Casey to print new vars: pdir_lvix, logout_index, and pdir_quota. Modified March 1979 by T. Casey to print new variables added for MR7.0 and MR7.0a. Modified July 1979 by T. Casey for MR8.0 to print process preservation variables. Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA) Modified January 1981 by E. N. Kittlitz for new answer_table entries Modified June 1981 by E. N. Kittlitz for UNCA rate structures Modified June 1981 by T. Casey for MR9.0 to print absentee load control variables. Modified November 1981, E. N. Kittlitz. user_table_entry conversion. Modified 1984-09-12 BIM for login auth ranges, com channel aim. Modified 1984-12-31 Keith Loepere for pdir_dir_quota. Modified 1985-01-15 by E. Swenson to add anstbl.session_uid_counter. Modified 1985-03-04 by EJ Sharpe to convert audit flags to string representation */ /****^ HISTORY COMMENTS: 1) change(85-11-16,Swenson), approve(87-07-13,MCR7737), audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055): Added support for displaying new fields and upgraded to new date time code. Also converted inline code for time breakdowns to use of subroutine. 2) change(87-04-20,GDixon), approve(87-07-13,MCR7741), audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055): A) Reordered output to reflect reorganization of user_table_entry.incl.pl1 and changes for user_table_header.incl.pl1. B) Improved date handling to detect unset dates and report them as such. 3) change(87-05-13,GDixon), approve(87-07-13,MCR7741), audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055): A) Modified to accommodate new layout of table headers and user table entry. B) Fold longer lines in a more readable fashion. 4) change(87-05-15,GDixon), approve(87-07-13,MCR7741), audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055): A) Handle ute.line_type. B) Interpret ute.preempted. 5) change(87-05-20,GDixon), approve(87-07-13,MCR7741), audit(87-07-14,Hartogs), install(87-08-04,MR12.1-1055): A) Correct ioa_ctl string for anstbl.update_pending. B) Enlarge sch_tty to hold 32 character channel names. C) Allow sch_tty to be a starname. 6) change(88-03-18,Parisek), approve(88-03-18,MCR7849), audit(88-03-22,Lippard), install(88-07-13,MR12.2-1047): Add ute.lowest_ring to display items. END HISTORY COMMENTS */ dcl anp ptr, /* ptr to answer table */ hsw bit (1), /* TRUE if header to be dumpted */ osw bit (1), /* TRUE if dump in octal too */ verb fixed bin, /* output verbe */ sct char (*), /* select tty chan */ scu char (*), /* select user */ stream char (*); /* output stream name */ dcl S char (32) aligned, /* stream name */ out entry options(variable) variable, hdr bit (1), /* header switch */ oct bit (1), /* octal */ mode fixed bin, /* output mode */ time char (16), /* temp */ (on_flags, off_flags) char (128) varying aligned, /* temp */ rs_name char (32), code fixed bin (35), line_length fixed bin, tp ptr, vstr char (512) varying, audit_str char (512), i fixed bin, sch_tty char (32), sch_user char (32), sch_project char (32); dcl table_name char (13) aligned; dcl table_type fixed bin; dcl table_size fixed bin; dcl max_rs_number fixed bin; /* builtins */ dcl (addr, addrel, after, before, binary, char, clock, convert, fixed, hbound, index, lbound, length, ltrim, null, rel, rtrim, size, string, substr, unspec) builtin; /* entries */ dcl convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35)); dcl date_time_$format entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var); dcl display_access_class_ entry (bit (72) aligned) returns (character (32) aligned); dcl display_access_class_$range entry ((2) bit (72) aligned) returns (character (32) aligned); dcl format_attributes_ entry (ptr, char (*) var); dcl get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin); dcl ioa_$ioa_stream entry options (variable); dcl match_star_name_ entry (char(*), char(*), fixed bin(35)); dcl request_id_ entry (fixed bin (71) aligned) returns (char (19)); dcl system_info_$max_rs_number entry (fixed bin); dcl system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)); /* structures and int static */ dcl NL_SP char(2) int static options(constant) init(" "); dcl SP_COMMA char(2) int static options(constant) init(" ,"); dcl 1 last_flag aligned based, 2 name char(20) varying, 2 (lower_x, upper_x) fixed bin, 2 range char(32) varying; dcl 1 to based (tp) aligned, 2 w1 fixed bin, 2 w2 fixed bin, 2 w3 fixed bin, 2 w4 fixed bin, 2 w5 fixed bin, 2 w6 fixed bin, 2 w7 fixed bin, 2 w8 fixed bin; dcl table_names (3) char (13) aligned int static options (constant) init ( "ANSWER", "ABSENTEE USER", "DAEMON USER"); dcl two_digits picture "99"; table_type = PT_INTERACTIVE; /* answer table */ ansp = anp; table_size = anstbl.current_size; common: table_name = table_names (table_type); line_length = get_line_length_$switch (null, code); if code ^= 0 then line_length = 79; call system_info_$max_rs_number (max_rs_number); /* get number of RS */ mode = verb; S = stream; out = ioa_$ioa_stream; hdr = hsw; oct = osw; sch_user = before (scu, "."); sch_project = after (scu, "."); sch_tty = sct; call out(S, "^/DUMP OF ^a TABLE - ^a^/", table_name, cv_date (clock ())); if ^hdr then go to ents; if table_type = PT_INTERACTIVE then uthp = ansp; else if table_type = PT_ABSENTEE then uthp = autp; else if table_type = PT_DAEMON then uthp = dutp; call out(S, "header_version:^21t^d", uth.header_version); call out(S, "entry_version:^21t^d", uth.entry_version); call out(S, "user_table_type:^21t^d (^a)", uth.user_table_type, TABLE_NAMES(uth.user_table_type)); call out(S, "header_length:^21t^d words", uth.header_length); call out(S, "max_size:^21t^d entries", uth.max_size); call out(S, "current_size:^21t^d entries", uth.current_size); call out(S, "number_free:^21t^d entries", uth.number_free); call out(S, "first_free:^21t^d", uth.first_free); call out(S, "as_procid:^21t^w", uth.as_procid); if table_type = PT_INTERACTIVE then do; /* answer table */ call out(S, "nlin:^21t^d", anstbl.nlin); call out(S, "mxlin:^21t^d", anstbl.mxlin); call out(S, "n_users:^21t^d", anstbl.n_users); call out(S, "max_users:^21t^d", anstbl.max_users); call out(S, "n_units:^21t^d", anstbl.n_units); call out(S, "max_units:^21t^d", anstbl.max_units); call out(S, "n_sessions:^21t^d", anstbl.n_sessions); call out(S, "sysdir:^21t^a", anstbl.sysdir); call out(S, "as_tty:^21t^a", anstbl.as_tty); call out(S, "login_word:^21t^a", anstbl.login_word); call out(S, "session:^21t^a", anstbl.session); call out(S, "special_message:^21t^a", rtrim(anstbl.special_message, NL_SP)); call out(S, "message_update_time:^21t^a", cv_date (anstbl.message_update_time)); call out(S, "message_lng:^21t^d", anstbl.message_lng); call out(S, "lock_count:^21t^d", anstbl.lock_count); call out(S, "update_pending:^21t^[ON^;OFF^]", anstbl.update_pending); call out(S, "update_channel:^21t^24.3b", unspec (anstbl.update_channel)); call out(S, "acct_update_chn:^21t^24.3b", unspec (anstbl.acct_update_chn)); call out(S, "acct_last_update_time:^21t^a", cv_date (anstbl.acct_last_update_time)); call out(S, "acct_alarm_fail:^21t^d", anstbl.acct_alarm_fail); call out(S, "current_time:^21t^a", cv_date (anstbl.current_time)); call out(S, "processid_index:^21t^d", anstbl.processid_index); call out(S, "session_uid_counter:^21t^d", anstbl.session_uid_counter); call out(S, "shift:^21t^d", anstbl.shift); call out(S, "auto_maxu:^21t^d", anstbl.auto_maxu); call out(S, "extra_units:^21t^d", anstbl.extra_units); call out(S, "response_high:^21t^d", anstbl.response_high); call out(S, "response_low:^21t^d", anstbl.response_low); call out(S, "ls_request_server_event_channel:^21t^24.3b", unspec (anstbl.ls_request_server_event_channel)); call out(S, "ls_request_server_process_id:^21t^w", anstbl.ls_request_server_process_id); call out(S, "login_server_present:^21t^[ON^;OFF^]", anstbl.login_server_present); if oct then call odump (ansp, fixed (rel (addr (anstbl.entry (1))))); end; else if table_type = PT_ABSENTEE then do; /* absentee user table */ call out(S, "n_abs_run:^21t^d", autbl.n_abs_run); call out(S, "max_abs_users:^21t^d", autbl.max_abs_users); call out(S, "n_background_abs:^21t^d", autbl.n_background_abs); call out(S, "n_sec_fg:^21t^d", autbl.n_sec_fg); call out(S, "idle_units:^21t^d", autbl.idle_units); call out(S, "abs_units:^21t^d", autbl.abs_units); call out(S, "n_abs(1:4):^21t^(^d^x^)", autbl.n_abs); call out(S, "qres(1:4):^21t^(^d^x^)", autbl.qres); call out(S, "rsc_waiting(-1:4):^21t^(^d^x^)", autbl.rsc_waiting); call out(S, "qerr(-1:4):^21t^(^d^x^)", autbl.qerr); call out(S, "cpu_limit(1:4):^21t^(^d^x^)", autbl.cpu_limit); call out(S, "defer_channel:^21t^24.3b", unspec (autbl.defer_channel)); call out(S, "absentee_rq_chn:^21t^24.3b", unspec (autbl.absentee_rq_chn)); call out(S, "last_queue_searched:^x^d", autbl.last_queue_searched); on_flags, off_flags = ""; if autbl.debugging = 1 then on_flags = "debugging, "; else if autbl.debugging = 0 then off_flags = "debugging, "; else call out(S, "debugging:^21t^d",autbl.debugging); call display_flags (on_flags, off_flags, string(autbl.control), AUTBL_CONTROL_NAMES, "control"); if oct then call odump (ansp, fixed (rel (addr (autbl.entry (1))))); end; else if table_type = PT_DAEMON then do; /* daemon user table */ call out(S, "active_count:^21t^d", dutbl.active_count); if oct then call odump (ansp, fixed (rel (addr (dutbl.entry (1))))); end; ents: do i = 1 to table_size; if table_type = PT_INTERACTIVE then utep = addr (anstbl.entry (i)); else if table_type = PT_ABSENTEE then utep = addr (autbl.entry (i)); else utep = addr (dutbl.entry (i)); if ute.active = NOW_FREE then goto skip_entry; if mode > 0 then /* be selective */ if mode = 9 then do; if sch_tty ^= "" then do; call match_star_name_ (ute.tty_name, sch_tty, code); if code ^= 0 then go to skip_entry; end; else if sch_user ^= "" then do; if ute.person ^= sch_user then go to skip_entry; else if sch_project ^= "" then if ute.project ^= sch_project then go to skip_entry; end; else if sch_project ^= "" then if ute.project ^= sch_project then go to skip_entry; if ute.active <= 0 then go to skip_entry; end; /* mode 9 */ else if mode = 1 then if ute.active < 0 then go to skip_entry; else if mode = 2 then if ute.lock_value <= 0 then go to skip_entry; else if mode = 3 then if ute.active <= 3 then go to skip_entry; else if mode = 4 then if ute.active <= 2 then go to skip_entry; else go to skip_entry; /* Variables which give state of this entry */ call out(S, "^/ENTRY ^d at ^p ^[(^a.^a)^]", i, utep, (ute.person || ute.project ^= ""), ute.person, ute.project); call out(S, "active:^21t^d (^a)", ute.active, ACTIVE_VALUES (ute.active)); if ute.process_type ^= table_type then call out(S, "process_type:^21t^d (SHOULD BE ^d)", ute.process_type, table_type); call out(S, "ute_index:^21t^d ^[(SHOULD BE ^d)^]", ute.ute_index, i^=ute.ute_index, i); if ute.active = NOW_FREE then call out(S, "next_free:^21t^d", ute.next_free); else if ute.next_free ^= 0 then call out(S, "next_free:^21t^d (SHOULD BE 0)", ute.next_free); /* Information user gave about person_id associated with this entry. */ call out(S, "person:^21t^a", ute.person); call out(S, "project:^21t^a", ute.project); call out(S, "tag:^21t^a", ute.tag); on_flags = ""; off_flags = ""; if ute.anonymous = 0 then off_flags = "anonymous, "; else if ute.anonymous = 1 then on_flags = "anonymous, "; else call out(S, "anonymous:^21t^d", ute.anonymous); if MASK_CTL_NAMES (binary (ute.mask_ctl,2)) ^= "" then do; on_flags = on_flags || MASK_CTL_NAMES (binary(ute.mask_ctl,2)); on_flags = on_flags || ", "; end; call display_flags (on_flags, off_flags, substr(string(ute.login_flags),1,34), PW_FLAG_NAMES, "login_flags"); if ute.generated_pw ^= "" then call out(S, "generated_pw:^21t^a", ute.generated_pw); if ute.old_password ^= "" then time = "(scramble)"; else time = ""; call out(S, "old_password:^21t^a", time); call out_line("process_authorization:^21t^a", 21, display_access_class_ (ute.process_authorization)); /* Information user gave about process associated with this entry. */ call out(S, "outer_module:^21t^a", ute.outer_module); call out(S, "home_dir:^21t^a", ute.home_dir); call out(S, "init_proc:^21t^a", substr (ute.init_proc, 1, ute.ip_len)); call out(S, "subsystem:^21t^a", substr (ute.init_proc, ute.ip_len + 1)); call format_attributes_ (addr (ute.ur_at), vstr); call out_line("ur_at:^21t^a", 21, vstr); call format_attributes_ (addr (ute.at), vstr); call out_line("attributes:^21t^a", 21, vstr); call out(S, "initial_ring:^21t^d", ute.initial_ring); call out(S, "arg_count:^21t^d", ute.arg_count); call out(S, "ln_args:^21t^d", ute.ln_args); call out(S, "arg_lengths_ptr:^21t^p", ute.arg_lengths_ptr); call out(S, "args_ptr:^21t^p", ute.args_ptr); /* Most of the following information is relevant only to absentee processes */ if table_type = PT_ABSENTEE then do; /* absentee user table is longer than the other 2 */ call out(S, "input_seg:^21t^a", ute.input_seg); call out(S, "output_seg:^21t^a", ute.output_seg); call out(S, "request_id:^21t^a", request_id_ (ute.request_id)); if ute.reservation_id ^= 0 then call out(S, "reservation_id:^21t^24.3b", unspec (ute.reservation_id)); call out(S, "message_id:^21t^24.3b", ute.message_id); call out(S, "deferred_time:^21t^a", cv_date (ute.deferred_time)); call out(S, "max_cpu_time:^21t^a", cv_usecs (ute.max_cpu_time * 1000000)); call out(S, "queue:^21t^d", ute.queue); call out(S, "real_queue:^21t^d", ute.real_queue); call display_flags ("", "", string(ute.abs_attributes), ABS_ATTRIBUTE_NAMES, "abs_attributes"); call display_flags ("", "", string(ute.abs_flags), ABS_FLAG_NAMES, "abs_flags"); call out(S, "abs_group:^21t^a", ute.abs_group); if ute.sender ^= "" then call out(S, "sender:^21t^a", ute.sender); if ute.proxy_person || ute.proxy_project ^= "" then call out(S, "proxy:^21t^a.^a", ute.proxy_person, ute.proxy_project); end; /* end of absentee specific items */ /* Information about process actually created */ call out(S, "proc_id:^21t^12.3b", ute.proc_id); call out(S, "session_uid:^21t^d", ute.session_uid); call out_line("process_authorization_range:^21t^a", 21, display_access_class_$range ( ute.process_authorization_range)); call convert_access_audit_flags_$to_string (ute.audit, audit_str, code); if code ^= 0 then call out(S, "audit:^21t^12.3b (illegal format)", ute.audit); else call out_line("audit:^21t^a", 21, rtrim(audit_str)); if ute.lot_size ^= 0 then call out(S, "lot_size:^21t^d", ute.lot_size); if ute.kst_size ^= 0 then call out(S, "kst_size:^21t^d", ute.kst_size); if ute.cls_size ^= 0 then call out(S, "cls_size:^21t^d", ute.cls_size); call out(S, "sus_channel:^21t^24.3b", unspec (ute.sus_channel)); call out(S, "lowest_ring:^21t^d", ute.lowest_ring); call out(S, "highest_ring:^21t^d", ute.highest_ring); call out(S, "pdir_lvix:^21t^d", ute.pdir_lvix); call out(S, "pdir_quota:^21t^d", ute.pdir_quota); call out(S, "pdir_dir_quota:^21t^d", ute.pdir_dir_quota); /* Information about primary terminal associated with this entry */ call out(S, "tty_name:^21t^a", ute.tty_name); call out(S, "terminal_type:^21t^a", ute.terminal_type); call out(S, "line_type:^21t^a (^d)", line_types(ute.line_type), ute.line_type); call out(S, "tty_id_code:^21t^a", ute.tty_id_code); call out(S, "network_connection_type:^21t^a", NETWORK_TYPE_VALUES(ute.network_connection_type)); call out(S, "channel:^21t^p", ute.channel); /* Variables useful for dialed terminals */ call out(S, "ndialed_consoles:^21t^d", ute.ndialed_consoles); if ute.dial_qualifier ^= "" then do; call out(S, "dial_qualifier:^21t^a in ring ^d", ute.dial_qualifier, ute.dial_server_ring); call display_flags ("", "", string(ute.dial_server_flags), DIAL_SERVER_FLAG_NAMES, "dial_server_flags"); end; call out(S, "dial_ev_chn:^21t^24.3b", unspec (ute.dial_ev_chn)); /* Information about usage/accounting. */ call out(S, "pdtep:^21t^p", ute.pdtep); call out(S, "cpu_this_process:^21t^a", cv_usecs (ute.cpu_this_process)); call out(S, "cpu_usage:^21t^a", cv_usecs (ute.cpu_usage)); call out(S, "mem_usage:^21t^f", ute.mem_usage / 1e3); call out(S, "mem_this_process:^21t^f", ute.mem_this_process / 1e3); call out(S, "last_update_time:^21t^a", cv_date (ute.last_update_time)); call out(S, "session_cost:^21t$^.2f", ute.session_cost); call out(S, "ndevices:^21t^d", ute.ndevices); call out(S, "device_head:^21t^d", ute.device_head); call out(S, "device_tail:^21t^d", ute.device_tail); if max_rs_number > 0 then do; call system_info_$rs_name ((ute.rs_number), rs_name, code); call out(S, "rate structure: ^21t^d (^a)", ute.rs_number, rs_name); end; /* Information for dialup_ (control variables). */ call out(S, "event:^21t^24.3b", unspec (ute.event)); call out(S, "uprojp:^21t^p", ute.uprojp); call out(S, "login_time:^21t^a", cv_date (ute.login_time)); call out(S, "cant_bump_until:^21t^a", cv_date (ute.cant_bump_until)); call out(S, "recent_fatal_error_time: ^a", cv_date (ute.recent_fatal_error_time)); call out(S, "recent_fatal_error_count: ^d", ute.recent_fatal_error_count); if ute.failure_reason ^= 0 then call out(S, "failure_reason:^21t^d", ute.failure_reason); call out(S, "count:^21t^d", ute.count); call out(S, "n_processes:^21t^d", ute.n_processes); call out(S, "lock_value:^21t^d", ute.lock_value); call out(S, "login_result:^21t^d (^a)", ute.login_result, LOGIN_RESULT_VALUES (ute.login_result)); call out(S, "login_code:^21t^a", ute.login_code); call out(S, "preempted:^21t^d (^a)", ute.preempted, PREEMPT_VALUES(ute.preempted)); call out(S, "destroy_flag:^21t^d (^a)", ute.destroy_flag, TRA_VEC_VALUES (ute.destroy_flag)); call out(S, "logout_type:^21t^a", ute.logout_type); call out(S, "logout_index:^21t^d", ute.logout_index); call out(S, "disconnect rel min:^21t^d", ute.disconnection_rel_minutes); call out(S, "next_disconnected_ate_index:^21t^d", ute.next_disconnected_ate_index); call out(S, "work_class:^21t^d", ute.work_class); call out(S, "group:^21t^a", ute.group); call out(S, "whotabx:^21t^d", ute.whotabx); call display_flags ("", "", string(ute.uflags), UFLAG_NAMES, "uflags"); /* Information used by load_ctl_ for the process */ call out(S, "user_weight:^21t^d", ute.user_weight); call out(S, "standby_line:^21t^d", ute.standby_line); call out(S, "bump_grace:^21t^a", cv_usecs (ute.bump_grace)); /* Information for login server */ call out(S, "ls our_handle:^21t^24.3b", ute.login_server_info.our_handle); call out(S, "ls his_handle:^21t^24.3b", ute.login_server_info.his_handle); call out(S, "ls termination_event_channel:^21t^24.3b", unspec (ute.login_server_info.termination_event_channel)); call out(S, "ls response_event_channel:^21t^24.3b", unspec (ute.login_server_info.response_event_channel)); call out(S, "ls process_id:^21t^w", ute.login_server_info.process_id); if oct then call odump (utep, size (ute)); skip_entry: end; call out(S, "^/END ^a TABLE^/", table_name); return; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ dump_autbl_: entry (anp, hsw, osw, verb, sct, scu, stream); table_type = PT_ABSENTEE; /* 2 = absentee */ autp = anp; /* autbl is based on p */ table_size = autbl.current_size; goto common; /* * * * * * * * * * * * * * * * * * * * * * * * * */ dump_dutbl_: entry (anp, hsw, osw, verb, sct, scu, stream); table_type = PT_DAEMON; /* 3 = daemon */ dutp = anp; /* dut is based on dutp */ table_size = dutbl.current_size; goto common; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_date: procedure (clock_value) returns (char(250) varying); dcl clock_value fixed bin(71); if clock_value = 0 then return ("(unset)"); else return (date_time_$format ("date_time", clock_value, "", "")); end cv_date; /* * * * * * * * * * * * * * * * * * * * * * * * * */ cv_usecs: procedure (P_usecs) returns (char (32)); dcl P_usecs fixed bin (71) parameter; /* number of micro seconds */ dcl code fixed bin (35) automatic; dcl time char (32) automatic; dcl 1 time_offset_auto aligned like time_offset automatic; dcl date_time_$from_clock_interval entry (fixed bin (71), fixed bin (71), ptr, fixed bin (35)); dcl ioa_$rsnnl entry () options (variable); Ptime_offset = addr (time_offset_auto); unspec (time_offset) = ""b; time_offset.version = Vtime_offset_2; time_offset.flag.hr = 1; time_offset.flag.min = 1; time_offset.flag.sec = 1; call date_time_$from_clock_interval (0, P_usecs, Ptime_offset, code); if code ^= 0 then return ("-Invalid Time-"); else do; call ioa_$rsnnl ("^d hours, ^d mins, ^d secs", time, (0), time_offset.val.hr, time_offset.val.min, time_offset.val.sec); return (time); end; /* format: off */ %include time_offset; /* format: on */ end cv_usecs; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ display_flags: procedure (init_on_flags, init_off_flags, flag_bits, flag_names, heading); dcl (init_on_flags, init_off_flags) char(*) varying; dcl flag_bits bit(36) aligned; dcl flag_names (*) char (*) varying; dcl heading char(*); dcl j fixed bin; dcl (on_flags, off_flags) char(512) varying; dcl 1 (on_lflags, off_lflags) aligned like last_flag; call FLAG_init (init_on_flags, on_flags, on_lflags); call FLAG_init (init_off_flags, off_flags, off_lflags); do j = lbound (flag_names, 1) to hbound (flag_names, 1); if substr (flag_bits, j, 1) then call FLAG_set (on_flags, on_lflags, flag_names(j)); else call FLAG_set (off_flags, off_lflags, flag_names(j)); end; do j = j to length(flag_bits); /* print any new flags whose names we don't know yet */ if substr (flag_bits, j, 1) then do; two_digits = j; call FLAG_set (on_flags, on_lflags, heading || "(" || two_digits || ")"); end; end; call FLAG_emit (on_flags, on_lflags); call FLAG_emit (off_flags, off_lflags); if on_flags ^= "" then on_flags = rtrim(on_flags, SP_COMMA); if off_flags ^= "" then off_flags = rtrim(off_flags, SP_COMMA); if on_flags ^= "" then do; call out_line(heading || ":^21tON: ^a", 26, on_flags); if off_flags ^= "" then call out_line("^21tOFF: ^a", 26, off_flags); end; else if off_flags ^= "" then call out_line(heading || ":^21tOFF: ^a", 26, off_flags); end display_flags; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ FLAG_emit: procedure (flag_string, lflag); dcl flag_string_init char(*) varying; dcl flag_string char(512) varying; dcl flag_name char(*) varying; dcl 1 lflag aligned like last_flag; if lflag.name ^= "" then call FLAG_ARRAY_emit (flag_string, lflag); return; FLAG_init: entry (flag_string_init, flag_string, lflag); flag_string = flag_string_init; call FLAG_ARRAY_init (lflag); return; FLAG_set: entry (flag_string, lflag, flag_name); if index(flag_name, "(") > 0 then do; /* new flag array*/ if lflag.name ^= "" then do; /* old flag array*/ if before(flag_name, "(") = lflag.name then /* same flag */ call FLAG_ARRAY_set_upper (flag_name, lflag); else do; /* different flag*/ call FLAG_ARRAY_emit (flag_string, lflag); call FLAG_ARRAY_set_lower (flag_name, lflag); end; end; else /* no old flag */ call FLAG_ARRAY_set_lower (flag_name, lflag); end; else do; if lflag.name ^= "" then /* old flag array*/ call FLAG_ARRAY_emit (flag_string, lflag); flag_string = flag_string || flag_name; flag_string = flag_string || ", "; end; end FLAG_emit; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ FLAG_ARRAY_emit: procedure (flag_string, lflag); dcl flag_name char(*) varying; dcl flag_string char(512) varying; dcl 1 lflag aligned like last_flag; dcl flag_x fixed bin; flag_string = flag_string || lflag.name; flag_string = flag_string || "("; if lflag.range ^= "" then do; flag_string = flag_string || lflag.range; flag_string = flag_string || ";"; end; flag_string = flag_string || ltrim(char(lflag.lower_x)); if lflag.lower_x ^= lflag.upper_x then do; flag_string = flag_string || ":"; flag_string = flag_string || ltrim(char(lflag.upper_x)); end; flag_string = flag_string || ")"; flag_string = flag_string || ", "; FLAG_ARRAY_init: entry (lflag); lflag.name = ""; lflag.lower_x, lflag.upper_x = 0; lflag.range = ""; return; FLAG_ARRAY_set_lower: entry (flag_name, lflag); flag_x = convert (flag_x, before (after (flag_name, "("), ")")); lflag.name = before (flag_name, "("); lflag.lower_x, lflag.upper_x = flag_x; lflag.range = ""; return; FLAG_ARRAY_set_upper: entry (flag_name, lflag); flag_x = convert (flag_x, before (after (flag_name, "("), ")")); if flag_x = lflag.upper_x + 1 then lflag.upper_x = flag_x; else do; if lflag.range ^= "" then lflag.range = ";"; lflag.range = lflag.range || ltrim(char(lflag.lower_x)); if lflag.lower_x ^= lflag.upper_x then do; lflag.range = lflag.range || ":"; lflag.range = lflag.range || ltrim(char(lflag.upper_x)); end; lflag.lower_x, lflag.upper_x = flag_x; end; end FLAG_ARRAY_emit; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ odump: proc (loc, nw); dcl loc ptr, nw fixed bin; dcl kk fixed bin; do kk = 0 to nw - 1 by 8; tp = addrel (loc, kk); call out(S, "^4o ^w ^w ^w ^w ^w ^w ^w ^w", kk, to.w1, to.w2, to.w3, to.w4, to.w5, to.w6, to.w7, to.w8); end; end odump; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ out_line: procedure (ioa_ctl, continue_col, value); dcl ioa_ctl char(*); dcl continue_col fixed bin; dcl value char(*) varying; dcl cur_ioa char(60) varying; dcl cur_line char(512) varying; dcl data_region fixed bin; dcl remainder char(512) varying; dcl NON_COMMA_CHARS char(97) int static options(constant) init( "!""#$%&'()=~|1234567890-^\`@{}[]+*/.<>;:_ abcdefghijklmnopqrstuvwxyz ABCDEFGHIJKLMNOPQRSTUVWXYZ"); cur_ioa = ioa_ctl; data_region = line_length - (continue_col-1); remainder = value; do while (length(remainder) > data_region); cur_line = substr(remainder,1,data_region); cur_line = rtrim(cur_line, NON_COMMA_CHARS); if cur_line = "" then do; cur_line = before (remainder, ","); if cur_line ^= remainder then cur_line = cur_line || ","; end; remainder = after (remainder, cur_line); cur_line = ltrim(cur_line); call out(S, cur_ioa, cur_line); cur_ioa = "^" || ltrim(char(continue_col)) || "t^a"; end; if remainder ^= "" then do; remainder = ltrim(remainder); call out(S, cur_ioa, remainder); end; end out_line; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* format: off */ %include absentee_user_table; %include answer_table; %include daemon_user_table; %include dialup_values; %include line_types; %include net_event_message; %include ttyp; %include user_attributes; %include user_table_entry; %include user_table_header; dcl 1 uth aligned like ut_header based(uthp), uthp ptr; end dump_anstbl_;  dump_cdt_.pl1 10/25/89 1201.0r w 10/25/89 1004.1 236574 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Subroutine to dump the CDT, all fields. THVV Modified by Mike Grady 5/11/76 to convert to version 2 CDT Modified by T. Casey, November 1976 to dump some variables omitted from previous version. Modified by Robert Coren, June 1977, for new terminal type fields and dont_read_answerback attribute. Modified by T. Casey, September 1977, to get device charge name from installation_parms. Modified January 1979 by Larry Johnson for multiplexer data. Modified April 1979 by Larry Johnson for new things in fnpe's. Modified 1979 May 25 by Art Beattie to accomodate change in cdt.incl.pl1. Modified November 1979 by T. Casey for MR8.0 to dump process preservation variables. Modified January 1981 by E. N. Kittlitz to eliminate cdte.phone_no. Modified July 1981 by T. Casey for MR9.0 to dump some new cdte variables. Modified December 1981 (but barely) for trees in the cdt by Benson I. Margulies. Modified August 1982 (even less) by E. N. Kittlitz for masked channel state. Modified August 1982 by E. N. Kittlitz for check_acs. Modified January 1983 by Keith Loepere for generic_destination. Modified 831216 by E. N. Kittlitz for required_access_class. Modified 84-03-22 BIM for full AIM support, removed obsolete fields. */ /****^ HISTORY COMMENTS: 1) change(87-03-31,Beattie), approve(87-04-06,MCR7656), audit(87-07-14,Parisek), install(87-08-04,MR12.1-1055): Display new variables that support use of IOCBs in answering service. END HISTORY COMMENTS */ /* format: style4 */ dump_cdt_: procedure (Info_ptr, Code); /* parameters */ dcl Info_ptr pointer; dcl Code fixed bin (35); /* automatic */ dcl (i, n) fixed bin; declare found_a_match bit (1) aligned; dcl (time, avg) float bin; dcl indent fixed bin; dcl (fnpx, cdtx) fixed bin; dcl fnp_find_sw bit (1) aligned; dcl temp_dev_name char (8); dcl code fixed bin (35); dcl error character (100) aligned; dcl 1 devtab_copy (16) aligned, 2 device_id char (8) unal, 2 device_price (0:7) float bin; dcl two_digits picture "99"; dcl visited (2711) bit (1) unaligned; dcl tcount fixed bin; dcl 1 CI aligned like condition_info; /* internal static */ dcl fnp_tags (8) char (1) int static options (constant) init ("a", "b", "c", "d", "e", "f", "g", "h"); dcl attribute_flag_names (5) char (32) varying int static options (constant) init ("ck_answerback", "audit_access_error", "hardwired", "set_modes", "dont_read_answerback"); dcl option_flag_names (9) char (32) varying int static options (constant) init ("execute_initial_command", "attached_by_operator", "private_line", "bsc_ebcdic", "bsc_transparent", "vip_poll_select", "autobaud", "generic_destination_present", "use_iocb"); dcl access_check_flag_names (5) char (32) varying init ( "dial_out", "priv_attach", "dial_server", "login", "dial_slave") int static options (constant); dcl dialup_flag_names (11) char (32) varying int static options (constant) init ("ppm", "cpo", "wakeup_handler", "save_arg", "nosave_arg", "detach_after_hangup", "leave_edited", "hold_arg", "no_hold_arg", "immediate_arg", "current_access_class_valid"); /* entries */ dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl find_condition_info_ entry (ptr, ptr, fixed bin (35)); dcl ioa_$ioa_switch entry options (variable); dcl date_time_ entry (fixed bin (71), char (*)); dcl convert_authorization_$to_string_range_short entry ((2) bit (72) aligned, character (*), fixed binary (35)); dcl convert_authorization_$to_string_short entry (bit (72) aligned, character (*), fixed binary (35)); dcl system_info_$device_prices entry (fixed bin, ptr); dcl cdt_mgr_$find_cdt_channel entry (ptr, char (32), fixed bin, bit (1) aligned, fixed bin (35)); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl error_table_$nomatch fixed bin (35) ext static; /* builtins */ dcl (addr, divide, fixed, float, hbound, lbound, length, low, ltrim, null, rtrim, string, substr) builtin; dcl sub_error_ condition; /* include files */ %include dump_cdt_args_; %page; %include cdt; %page; %include author_dcl; %page; %include dialup_values; %page; %include multiplexer_types; %page; %include condition_info_header; %include sub_error_info; %include condition_info; /* ====================================================== */ Code = 0; dca_ptr = Info_ptr; cdtp = dump_cdt_args.cdt_ptr; indent = 0; call system_info_$device_prices ((0), addr (devtab_copy)); if dump_cdt_args.hdr then do; call ioa_$ioa_switch (switch, "^/Channel Definition Table^/"); call ioa_$ioa_switch (switch, "author.proc_group_id:^32t^a", cdt.author.proc_group_id); call ioa_$ioa_switch (switch, "author.lock:^32t^w", cdt.author.lock); call ioa_$ioa_switch (switch, "author.last_install_time:^32t^a", edit_time (cdt.author.last_install_time)); call ioa_$ioa_switch (switch, "^31a^a", "author.table:", cdt.author.table); call ioa_$ioa_switch (switch, "author.w_dir:^32t^a", cdt.author.w_dir); call ioa_$ioa_switch (switch, "max_size:^32t^d", cdt.max_size); call ioa_$ioa_switch (switch, "current_size:^32t^d", cdt.current_size); call ioa_$ioa_switch (switch, "version:^32t^d", cdt.version); call ioa_$ioa_switch (switch, "freep:^32t^d", cdt.freep); call ioa_$ioa_switch (switch, "n_cdtes:^32t^d", cdt.n_cdtes); call ioa_$ioa_switch (switch, "meters_last_reset:^32t^a", edit_time (cdt.meters_last_reset)); if cdt.realtime_in_dialup ^= 0 then do; n = cdt.entries_to_dialup; time = cdt.realtime_in_dialup / 1e6; avg = time / n; call ioa_$ioa_switch (switch, "realtime_in_dialup:^32t^.1f sec^51t^.1f sec avg", time, avg); time = cdt.cpu_in_dialup / 1e6; avg = time / n; call ioa_$ioa_switch (switch, "cpu_in_dialup:^32t^.1f sec^51t^.1f sec avg", time, avg); call ioa_$ioa_switch (switch, "pf_in_dialup:^32t^d^51t^d avg", cdt.pf_in_dialup, divide (cdt.pf_in_dialup, n, 17, 0)); call ioa_$ioa_switch (switch, "pp_in_dialup:^32t^d^51t^d avg", cdt.pp_in_dialup, divide (cdt.pp_in_dialup, n, 17, 0)); call ioa_$ioa_switch (switch, "entries_to_dialup:^32t^d", cdt.entries_to_dialup); end; call ioa_$ioa_switch (switch, "FNP_required_up_time:^32t^d minutes", cdt.acceptable_fnp_tbf); call ioa_$ioa_switch (switch, "Spare_channel_count:^32t^d", cdt.spare_channel_count); call ioa_$ioa_switch (switch, ""); end; if ^dump_cdt_args.all & ^dump_cdt_args.starname /* one chan */ then do; if dump_cdt_args.channel_name = "" then return; /* just the header */ call cdt_mgr_$find_cdt_channel (cdtp, (dump_cdt_args.channel_name), cdtx, fnp_find_sw, code); if code ^= 0 then do; Code = code; return; end; if fnp_find_sw then do; if ^dump_cdt_args.subtree then call print_fnpe (-cdtx); else do; if ^dump_cdt_args.brief then call print_fnpe (-cdtx); call show_children (addr (cdt.fnp_entry (-cdtx).threads), cdtx, "1"b); end; end; else do; if ^dump_cdt_args.subtree then call print_cdte (addr (cdt.cdt_entry (cdtx))); else do; if ^dump_cdt_args.brief then call print_cdte (addr (cdt.cdt_entry (cdtx))); call show_children (addr (cdt.cdt_entry (cdtx).threads), cdtx, "0"b); end; end; return; end; if dump_cdt_args.all then do; call dump_tree; return; end; /* Starname, may be fnp */ found_a_match = "0"b; do fnpx = 1 to hbound (cdt.fnp_entry, 1); fnpep = addr (cdt.fnp_entry (fnpx)); if fnpe.state ^= FNP_FREE then do; call match_star_name_ (substr (collate (), rank ("a") + fnpx, 1), (dump_cdt_args.channel_name), code); if code = 0 then do; found_a_match = "1"b; if ^dump_cdt_args.subtree then if ^dump_cdt_args.brief then call print_fnpe (fnpx); else call ioa_$ioa_switch (switch, "^2xFNP ^a (^d,^p)", substr (collate (), rank ("a") + fnpx, 1), fnpx, fnpep); else do; if ^dump_cdt_args.brief then call print_fnpe (fnpx); if fnpe.threads.daughter_count = 0 & fnpe.threads.daughter = 0 then ; else call show_children (addr (fnpe.threads), -fnpx, "1"b); end; end; end; end; /* Or it may be a non-FNP */ do i = 1 to cdt.current_size; cdtep = addr (cdt.cdt_entry (i)); if cdte.in_use ^= NOW_FREE then do; call match_star_name_ ((cdte.name), (dump_cdt_args.channel_name), code); if code = 0 then do; found_a_match = "1"b; if ^dump_cdt_args.subtree then if ^dump_cdt_args.brief then call print_cdte (cdtep); else call ioa_$ioa_switch (switch, "Channel ^a (^d,^p)", cdte.name, i, cdtep); else do; if ^dump_cdt_args.brief then call print_cdte (cdtep); call show_children (addr (cdt.cdt_entry (i).threads), cdtx, "0"b); end; end; end; end; if ^found_a_match then Code = error_table_$nomatch; return; print_fnpe: proc (n); dcl n fixed bin; dcl mpx_type fixed bin; dcl bb72 bit (72) aligned based; fnpep = addr (cdt.fnp_entry (n)); mpx_type = fnpe.mpx_type; if mpx_type = 0 then mpx_type = MCS_MPX; call ioa_$ioa_switch (switch, "^/FNPE at ^p (FNP ^a)^/", fnpep, edit_desc (n, fnp_tags)); if fnpe.type ^= 0 | mpx_type = MCS_MPX then call ioa_$ioa_switch (switch, "^5xtype:^26x^d (^a)", fnpe.type, edit_desc (fnpe.type, fnp_types)); if fnpe.memory ^= 0 | mpx_type = MCS_MPX then call ioa_$ioa_switch (switch, "^5xmemory:^24x^dK", fnpe.memory); if fnpe.nlslas ^= 0 | (mpx_type = MCS_MPX & fnpe.type ^= DN6670) then call ioa_$ioa_switch (switch, "^5xlslas:^25x^d", fnpe.nlslas); if fnpe.nhslas ^= 0 | mpx_type = MCS_MPX then call ioa_$ioa_switch (switch, "^5xhslas:^25x^d", fnpe.nhslas); call ioa_$ioa_switch (switch, "^5xboot event chan:^15x^24.3b", addr (fnpe.boot_ev_chan) -> bb72); if mpx_type = MCS_MPX then call ioa_$ioa_switch (switch, "^5xcoreimage:^21x^a", fnpe.coreimage); else if fnpe.coreimage ^= "" then call ioa_$ioa_switch (switch, "^5xadditional_info:^15x^a", fnpe.coreimage); mpxep = addr (fnpe.mpxe); call print_mpxe (fnpe.service_type, mpx_type); call ioa_$ioa_switch (switch, "^/"); return; end print_fnpe; print_mpxe: proc (a_service, a_type); dcl a_service fixed bin; dcl a_type fixed bin; dcl fnp_states (0:4) char (15) int static options (constant) init ( "not configured", "unknown", "down", "boot started", "up"); dcl mpx_service_types (0:7) char (12) int static options (constant) init ( "", "active", "", "", "", "", "", "inactive"); call ioa_$ioa_switch (switch, "^vx^5xMultiplexer data:", indent ); call ioa_$ioa_switch (switch, "^vx^6xservice_type:^37t^d (^a)", indent, a_service, edit_desc (a_service, mpx_service_types)); call ioa_$ioa_switch (switch, "^vx^6xmpx_type:^37t^d (^a)", indent, a_type, edit_desc (a_type, mpx_types)); call ioa_$ioa_switch (switch, "^vx^6xstate:^37t^d (^a)", indent, mpxe.state, edit_desc (mpxe.state, fnp_states)); call print_time ("initial load:", mpxe.time_initial_load); call print_time ("last load:", mpxe.time_last_load); call print_time ("last crash:", mpxe.time_last_crash); call print_time ("load started:", mpxe.time_load_start); call ioa_$ioa_switch (switch, "^vx^6xflags.go:^37t^d", indent, fixed (mpxe.flags.go)); call ioa_$ioa_switch (switch, "^vx^6xflags.listening:^37t^d", indent, fixed (mpxe.flags.listening)); call ioa_$ioa_switch (switch, "^vx^6xcurrent_service_type:^37t^d (^a)", indent, mpxe.current_service_type, edit_desc (mpxe.current_service_type, mpx_service_types)); if mpxe.current_mpx_type ^= 0 then call ioa_$ioa_switch (switch, "^vx^6xcurrent_mpx_type:^37t^d (^a)", indent, mpxe.current_mpx_type, edit_desc (mpxe.current_mpx_type, mpx_types)); call ioa_$ioa_switch (switch, "^vx^6xn_bootloads:^37t^d", indent, mpxe.n_bootloads); call ioa_$ioa_switch (switch, "^6xlast_tbf:^37t^d", mpxe.last_tbf); return; print_time: proc (name, time); dcl name char (*), time fixed bin (71); call ioa_$ioa_switch (switch, "^vx^6x^a^37t^a", indent, name, edit_time (time)); return; end print_time; end print_mpxe; print_cdte: proc (CDTEp); dcl (hrs, mins, secs) fixed bin; dcl auth_string char (200); dcl bb72 bit (72) based; dcl code fixed bin (35); dcl CDTEp pointer; dcl 1 CDTE aligned like cdte based (CDTEp); /* ----------------------------------------------- */ call ioa_$ioa_switch (switch, "^vx^/CDTE at ^p^/", indent, CDTEp); call ioa_$ioa_switch (switch, "^vx^5xin_use:^24x^d (^a)", indent, CDTE.in_use, edit_desc (CDTE.in_use, uses)); call ioa_$ioa_switch (switch, "^vx^5xname:^26x^a", indent, CDTE.name); if CDTE.current_service_type = MPX_SERVICE | (CDTE.service_type = MPX_SERVICE & CDTE.current_service_type = 0) then do; /* running mpx, or mpx in new cdt */ mpxep = addr (CDTE.initial_command); call print_mpxe ((CDTE.mpx_service), (CDTE.mpx_type)); end; call convert_authorization_$to_string_range_short (CDTE.access_class, auth_string, code); if auth_string = "" then auth_string = "system_low"; call ioa_$ioa_switch (switch, "^vx^5xaccess_class:^18x^a", indent, auth_string); call ioa_$ioa_switch (switch, "^vx^5xcomment:^23x^a", indent, CDTE.comment); if CDTE.charge_type < lbound (devtab_copy.device_id, 1) then temp_dev_name = "none"; else if CDTE.charge_type > hbound (devtab_copy.device_id, 1) then temp_dev_name = "?"; else temp_dev_name = devtab_copy.device_id (CDTE.charge_type); call ioa_$ioa_switch (switch, "^vx^5xcharge_type:^19x^d (^a)", indent, CDTE.charge_type, temp_dev_name); call ioa_$ioa_switch (switch, "^vx^5xservice_type:^18x^d (^a)", indent, CDTE.service_type, edit_desc ((CDTE.service_type), service_types)); call ioa_$ioa_switch (switch, "^vx^5xcurrent_service_type:^10x^d (^a)", indent, CDTE.current_service_type, edit_desc ((CDTE.current_service_type), service_types)); call ioa_$ioa_switch (switch, "^vx^5xline_type:^21x^d (^a)", indent, CDTE.line_type, edit_desc ((CDTE.line_type), line_types)); if CDTE.flags.ck_answerback then call ioa_$ioa_switch (switch, "^vx^5xanswerback:^20x^a", indent, CDTE.answerback); call ioa_$ioa_switch (switch, "^vx^5xterminal_type:^17x^a", indent, string_edit ((CDTE.initial_terminal_type))); call ioa_$ioa_switch (switch, "^vx^5xbaud_rate:^21x^d", indent, CDTE.baud_rate); if CDTE.modem_type > 0 then call ioa_$ioa_switch (switch, "^vx^5xmodem_type:^20x^d (^a)", indent, CDTE.modem_type, edit_desc ((CDTE.modem_type), dataset_names)); if string (CDTE.flags.attributes) then call ioa_$ioa_switch (switch, "^vx^5xflags.attributes:^37t^a", indent, flag_names (string (CDTE.flags.attributes), attribute_flag_names)); if string (CDTE.flags.options) then call ioa_$ioa_switch (switch, "^vx^5xflags.options:^37t^a", indent, flag_names (string (CDTE.flags.options), option_flag_names)); if string (CDTE.flags.access_control) then call ioa_$ioa_switch (switch, "^vx^5xflags.access_control:^37t^a", indent, flag_names (string (CDTE.flags.access_control), access_check_flag_names)); if CDTE.flags.execute_initial_command then call ioa_$ioa_switch (switch, "^vx^5xinitial_command:^15x^a", indent, CDTE.initial_command); if CDTE.flags.generic_destination_present then call ioa_$ioa_switch (switch, "^vx^5xgeneric_destination:^11x^a", indent, addr (CDTE.initial_command) -> generic_destination); call ioa_$ioa_switch (switch, "^vx^5xevent:^25x^24.3b", indent, addr (CDTE.event) -> bb72); call ioa_$ioa_switch (switch, "^vx^5xtra_vec:^23x^d (^a)", indent, CDTE.tra_vec, edit_desc ((CDTE.tra_vec), tra_vec_names)); call ioa_$ioa_switch (switch, "^vx^5xcount:^25x^d", indent, CDTE.count); if string (CDTE.dialup_flags) then call ioa_$ioa_switch (switch, "^vx^5xdialup_flags:^37t^a", indent, flag_names (string (CDTE.dialup_flags), dialup_flag_names)); call ioa_$ioa_switch (switch, "^vx^5xtwx:^27x^d", indent, CDTE.twx); call ioa_$ioa_switch (switch, "^vx^5xstate:^20x^5x^d (^a)", indent, CDTE.state, edit_desc (CDTE.state, states)); call ioa_$ioa_switch (switch, "^vx^5xcurrent_terminal_type:^9x^a", indent, string_edit ((CDTE.current_terminal_type))); call ioa_$ioa_switch (switch, "^vx^5xcur_line_type:^17x^d (^a)", indent, CDTE.cur_line_type, edit_desc ((CDTE.cur_line_type), line_types)); call convert_authorization_$to_string_short (CDTE.current_access_class (1), auth_string, code); if auth_string = "" then auth_string = "system_low"; call ioa_$ioa_switch (switch, "^vx^5xcurrent_access_class:^10x^a", indent, auth_string); call ioa_$ioa_switch (switch, "^vx^5xtty_id_code:^19x^a", indent, string_edit (CDTE.tty_id_code)); call ioa_$ioa_switch (switch, "^vx^5xprocess:^23x^p", indent, CDTE.process); if CDTE.dialed_to_procid ^= ""b then call ioa_$ioa_switch (switch, "^vx^5xdialed_to_procid:^14x^w", indent, CDTE.dialed_to_procid); call ioa_$ioa_switch (switch, "^vx^5xnext_channel:^15x^3x^d", indent, CDTE.next_channel); call ioa_$ioa_switch (switch, "^vx^5xdial_ctl_ring:^14x^3x^d", indent, CDTE.dial_ctl_ring); call ioa_$ioa_switch (switch, "^vx^5xuser_name:^21x^a", indent, string (CDTE.user_name)); if CDTE.disconnected_ate_index ^= 0 then call ioa_$ioa_switch (switch, "^vx^5xdisconnected_ate_index:^37t^d", indent, CDTE.disconnected_ate_index); call ioa_$ioa_switch (switch, "^vx^5xn_dialups:^21x^d", indent, CDTE.n_dialups); call ioa_$ioa_switch (switch, "^vx^5xn_logins:^22x^d", indent, CDTE.n_logins); secs = float (CDTE.dialed_up_time, 63); mins = divide (secs, 60, 35, 0); secs = secs - mins * 60; hrs = divide (mins, 60, 35, 0); mins = mins - hrs * 60; call ioa_$ioa_switch (switch, "^vx^5xdialed_up_time:^16x^d hrs ^d mins ^d secs.", indent, hrs, mins, secs); call ioa_$ioa_switch (switch, "^vx^5xdialup_time:^19x^a", indent, edit_time (CDTE.dialup_time)); if CDTE.disconnected_proc_command ^= 0 then call ioa_$ioa_switch (switch, "^vx^5xdisconnected_proc_command:^37t^d", indent, CDTE.disconnected_proc_command); if CDTE.disconnected_proc_number ^= 0 then call ioa_$ioa_switch (switch, "^vx^5xdisconnected_proc_number:^37t^d", indent, CDTE.disconnected_proc_number); if CDTE.n_disconnected_procs ^= 0 then call ioa_$ioa_switch (switch, "^vx^5xn_disconnected_procs:^37t^d", indent, CDTE.n_disconnected_procs); call ioa_$ioa_switch (switch, "^vx^5xrecent_wakeup_count:^37t^d", indent, CDTE.recent_wakeup_count); call ioa_$ioa_switch (switch, "^vx^5xrecent_wakeup_time:^37t^a", indent, edit_time (CDTE.recent_wakeup_time)); if CDTE.dial_ev_chn ^= 0 then call ioa_$ioa_switch (switch, "^vx^5xdial_ev_chn:^37t^24.3b", indent, addr (CDTE.dial_ev_chn) -> bb72); if CDTE.use_iocb then call ioa_$ioa_switch (switch, "^vx^5xiocbp:^37t^p", indent, CDTE.iocbp); return; %include line_types; %include dataset_names; dcl service_types (9) char (12) static options (constant) init ( "login", "ftp", "mc", "slave", "dial", "dial out", "inactive", "multiplexer", "tandd"); dcl states (-1:5) char (15) int static options (constant) init ("masked", "", "hung up", "listening", "", "", "dialed up"); dcl uses (-2:7) char (18) int static options (constant) init ("deleted", "not configured", "unused, free", "hung up", "listening", "dialed", "logged in, no proc", "logged in & proc", "dialing", "dialed out"); dcl tra_vec_names (0:25) char (32) int static options (constant) init ( "", "wait_dialup", "wait_answerback", "wait_login_line", "wait_login_args", "wait_old_password", "wait_password", "wait_new_password", "wait_logout_sig", "wait_logout", "wait_logout_hold", "wait_detach", "wait_new_proc", "wait_remove", "wait_fin_priv_attach", "wait_dial_release", "wait_dial_out", "wait_hangup", "wait_slave_request", "wait_greeting_msg", "wait_delete_channel", "wait_connect_request", "wait_tandd_hangup", "wait_fin_tandd_attach", "wait_discard_wakeups", "wait_before_hangup"); end print_cdte; string_edit: proc (s) returns (char (128) var); dcl s char (*) aligned; if s = low (length (s)) then return (""); else return (rtrim (s)); end string_edit; edit_time: proc (time) returns (char (32) var); dcl time fixed bin (71); dcl time_string char (24); if time = 0 then return ("never"); call date_time_ (time, time_string); return (rtrim (time_string)); end edit_time; edit_desc: proc (n, desc) returns (char (32) var); dcl n fixed bin; dcl desc (*) char (*); if n < lbound (desc, 1) | n > hbound (desc, 1) then if n = 0 then return (""); /* probably just unmitialized */ else return ("?"); else return (rtrim (desc (n))); end edit_desc; flag_names: proc (flags, flag_name_array) returns (char (256) varying); dcl flags bit (*) unaligned; dcl flag_name_array (*) char (32) varying; dcl return_string char (256) varying; dcl j fixed bin; return_string = ""; do j = 1 to hbound (flag_name_array, 1); /* go thru the ones we know the names of */ if substr (flags, j, 1) then do; /* if flag is on, add its name to the return string */ return_string = return_string || flag_name_array (j); return_string = return_string || ","; /* separate concatenations get better code */ end; end; do j = j to length (flags) /* go thru the ones we don't know the names of */ while (substr (flags, j)); /* as long as there are any more nonzero ones */ if substr (flags, j, 1) then do; /* if unknown flag is on */ two_digits = j; /* convert its position to a printable number */ return_string = return_string || "flag"; return_string = return_string || ltrim (two_digits); return_string = return_string || ","; end; end; substr (return_string, length (return_string), 1) = ";"; return (return_string); end flag_names; dump_tree: procedure; /* This does mode=0, whole cdt, treewise */ tcount = 0; indent = 0; call ioa_$ioa_switch (switch, "FNP Entries:"); indent = 2; do fnpx = 1 to hbound (cdt.fnp_entry, 1); fnpep = addr (cdt.fnp_entry (fnpx)); if fnpe.state ^= FNP_FREE then do; call ioa_$ioa_switch (switch, "^2xFNP ^a", substr (collate (), rank ("a") + fnpx, 1)); if ^dump_cdt_args.brief then call print_fnpe (fnpx); if fnpe.threads.daughter_count = 0 & fnpe.threads.daughter = 0 then ; else call show_children (addr (fnpe.threads), -fnpx, "1"b); end; end; /* Other tops */ indent = 2; call ioa_$ioa_switch (switch, "^/Other top level channels:"); call show_children (addr (cdt.threads), 0, "0"b); call ioa_$ioa_switch (switch); do cdtx = 1 to cdt.current_size; if cdt.cdt_entry (cdtx).in_use ^= NOW_FREE & ^visited (cdtx) then call ioa_$ioa_switch (switch, "Unthreaded channel: ^a at index ^d.", cdt.cdt_entry (cdtx).name, cdtx); end; if tcount ^= cdt.n_cdtes then call ioa_$ioa_switch (switch, "Total seen is ^d, but cdt.n_cdtes is ^d.", tcount, cdt.n_cdtes); return; end dump_tree; show_children: procedure (tp, tx, fnp); declare cp pointer; declare tp pointer; declare tx fixed bin; declare fx fixed bin; declare ffnp_sw bit (1) aligned; declare fnp bit (1) aligned; declare x fixed bin; declare last_sister fixed bin; declare dcount fixed bin; /* daughter count */ declare 1 t aligned like channel_threads based (tp); call ioa_$ioa_switch (switch, "^vx^d daughters.", indent, t.daughter_count); dcount = 0; if t.daughter_count = 0 then do; if t.daughter ^= 0 then do; call ioa_$ioa_switch (switch, "^vxdaughter count zero but there are daughters.", indent); goto CHASE; end; return; end; CHASE: last_sister = 0; do x = t.daughter repeat (cdt.cdt_entry (x).threads.next_sister) while (x ^= 0); cp = addr (cdt.cdt_entry (x)); call ioa_$ioa_switch (switch, "^vx(^d)^a", indent, x, cp -> cdte.name); if ^dump_cdt_args.brief then call print_cdte (cp); dcount = dcount + 1; tcount = tcount + 1; visited (x) = "1"b; if cp -> cdte.threads.mother ^= tx then call ioa_$ioa_switch (switch, "^vxthreads.mother = ^d, but mother = ^d.", indent, cp -> cdte.mother, tx); if cp -> cdte.threads.prev_sister ^= last_sister then call ioa_$ioa_switch (switch, "^vxthreads.prev_sister = ^d, but prev_sister = ^d.", indent, cp -> cdte.threads.prev_sister, last_sister); last_sister = x; if cp -> cdte.threads.daughter ^= 0 then do; indent = indent + 2; call show_children (addr (cp -> cdte.threads), x, "0"b); indent = indent - 2; end; on sub_error_ begin; call find_condition_info_ (null, addr (CI), (0)); sub_error_info_ptr = CI.info_ptr; call convert_status_code_ (sub_error_info.status_code, "", error); call ioa_$ioa_switch (switch, "^vxError: ^a ^a", indent, error, sub_error_info.info_string); go to ERROR; end; call cdt_mgr_$find_cdt_channel (cdtp, (cp -> cdte.name), fx, ffnp_sw, code); if code = 0 then do; if fx ^= x /* wrong place */ then call ioa_$ioa_switch (switch, "^vxcdt_mgr_ thinks this is cdtx = ^d.", indent, fx); if ffnp_sw then call ioa_$ioa_switch (switch, "^vxcdt_mgr_ thinks this is a FNP.", indent); end; ERROR: end; /* the loop */ if dcount ^= t.daughter_count then call ioa_$ioa_switch (switch, "^vxthreads.daughter_count = ^d, but daughter_count = ^d.", indent, t.daughter_count, dcount); return; end show_children; end dump_cdt_;  dump_cmf_.pl1 10/25/89 1201.0r w 10/25/89 1005.0 108144 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* dump_cmf_, a subroutine to dump the CDT in the form of a CMF, such that cv_cmf could regenerate the CDT. Coded 5/11/76 by Mike Grady Modified November 1976 by T. Casey to generate Baud statements. Modified June 1977 by Robert Coren to use new terminal type field and new attributes. Modified April 1979 by Larry Johnson for new fnpe stuff. Modified 1979 May 25 by Art Beattie to accomodate change in cdt.incl.pl1. Modified 1/82 BIM for cdt threads. Modified January 1983 by Keith Loepere for generic_destination. Modified 84-03-22 BIM for removal of obsolete fields, full AIM. */ /* format: style2 */ dump_cmf_: proc (acdtp, switch); dcl (acdtp, switch) ptr parameter; dcl com_err_ entry () options (variable), date_time_ entry (fixed bin (71), char (*)), ioa_$ioa_switch entry options (variable), ioa_$rsnnl entry options (variable), system_info_$device_prices entry (fixed bin, ptr), system_info_$access_ceiling entry (bit (72) aligned), aim_check_$equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned), convert_authorization_$from_string entry (bit (72) aligned, character (*), fixed binary (35)), convert_authorization_$to_string_range_short entry ((2) bit (72) aligned, character (*), fixed binary (35)); dcl cdt_et_$salvage_cdt fixed bin (35) ext static; dcl line char (160), vline char (160) varying; dcl (i, j, len, ndev) fixed bin, code fixed bin (35); dcl (dft_baud, next_baud, this_baud) fixed bin; dcl system_high bit (72) aligned, system_low bit (72) aligned, auth_bits bit (72) aligned; dcl auth_done bit (1); dcl lidx fixed bin, count fixed bin; dcl 1 ac_table (10) aligned, 2 auth_bits bit (72) aligned, 2 count fixed bin; dcl date_string char (24), auth char (100); dcl 1 dvt (16) aligned, 2 devid char (8), 2 dev_prices (0:7) float; dcl bb72 bit (72) aligned based; dcl service_types (8) char (12) static options (constant) init ("login", "ftp", "mc", "slave", "", "autocall", "inactive", "multiplexer"); %page; %include cdt; %page; %include author_dcl; %page; %include ttyp; %page; %include dataset_names; %page; %include line_types; %page; %include dialup_values; %page; %include multiplexer_types; cdtp = acdtp; line = "/* Automatically generated Channel Master File"; call append_line; call date_time_ (clock (), date_string); line = " Generated by display_cdt on " || date_string || " */"; call append_line; line = ""; call append_line; call system_info_$device_prices (ndev, addr (dvt)); line = "Service: login;"; call append_line; line = "Charge: none;"; call append_line; line = "Terminal_type: none;"; call append_line; line = "Line_type: none;"; call append_line; line = "Attributes: none;"; call append_line; line = "Check_acs: none;"; call append_line; line = "Baud: 300;"; call append_line; dft_baud = 300; /* try and compute the correct access class */ call system_info_$access_ceiling (system_high); /* get sys high */ call convert_authorization_$from_string (system_low, "system_low", code); line = "Access_class: ""system_low"";"; /* secure default is no access. Individuals will all be stated. Verbose, but effective. */ call append_line; call ioa_$rsnnl ("FNP_required_up_time: ^d;", line, len, cdt.acceptable_fnp_tbf); call append_line; call ioa_$rsnnl ("Spare_channel_count: ^d;", line, len, cdt.spare_channel_count); call append_line; line = ""; call append_line; do i = 1 to 8; /* dump FNPs */ fnpep = addr (cdt.fnp_entry (i)); if fnpe.state ^= FNP_FREE then call dump_fnpe; /* recurses */ end; line = "/* Other top level multiplexers: */"; call append_line; line = ""; call append_line; call dump_subtree (addr (cdt.threads), "Top level chain"); line = "end;"; call append_line; return; dump_fnpe: proc; dcl mpx_type fixed bin; mpx_type = fnpe.mpx_type; if mpx_type = 0 then mpx_type = MCS_MPX; line = "FNP: " || substr (collate (), rank ("A") + i, 1) || ";"; call append_line; if fnpe.type ^= 0 | mpx_type = MCS_MPX then do; call ioa_$rsnnl (" type: ^a;", line, len, fnp_types (fnpe.type)); call append_line; end; if fnpe.memory ^= 0 | mpx_type = MCS_MPX then do; call ioa_$rsnnl (" memory: ^d;", line, len, fnpe.memory); call append_line; end; if fnpe.nlslas ^= 0 | (fnpe.mpx_type = MCS_MPX & fnpe.type ^= DN6670) then do; call ioa_$rsnnl (" lsla: ^d;", line, len, fnpe.nlslas); call append_line; end; if fnpe.nhslas ^= 0 | mpx_type = MCS_MPX then do; call ioa_$rsnnl (" hsla: ^d;", line, len, fnpe.nhslas); call append_line; end; if mpx_type = MCS_MPX then do; call ioa_$rsnnl (" image: ^a;", line, len, fnpe.coreimage); call append_line; end; else if fnpe.coreimage ^= "" then do; call ioa_$rsnnl (" additional_info: ""^a"";", line, len, fnpe.coreimage); call append_line; end; if fnpe.service_type = INACTIVE then do; line = " service: inactive;"; call append_line; end; if fnpe.mpx_type ^= 0 then do; call ioa_$rsnnl (" multiplexer_type: ^a;", line, len, mpx_types (fnpe.mpx_type)); call append_line; end; line = ""; call append_line; if fnpe.daughter ^= 0 then call dump_subtree (addr (fnpe.threads), "FNP " || substr (collate (), rank ("A") + i, 1)); return; end dump_fnpe; dump_subtree: procedure (tp, cname); declare tp pointer; declare 1 threads aligned like channel_threads based (tp); declare cname character (32) aligned; declare x fixed bin; declare ccount fixed bin; if threads.daughter_count = 0 | threads.daughter = 0 then return; /* for lazy callers */ ccount = 0; do x = threads.daughter repeat (cdt.cdt_entry (x).next_sister) while (x ^= 0); ccount = ccount + 1; if ccount > threads.daughter_count | ccount > cdt.n_cdtes then do; call com_err_ (cdt_et_$salvage_cdt, "dump_cmf_", "Too many daughters(^d) for ^a", ccount, cname); go to RETURN; end; call dump_cdte (addr (cdt.cdt_entry (x))); if cdt.cdt_entry (x).daughter ^= 0 then call dump_subtree (addr (cdt.cdt_entry (x).threads), cdt.cdt_entry (x).name); end; end dump_subtree; dump_cdte: proc (CDTEp); declare CDTEp pointer; declare 1 CDTE aligned like cdte based (CDTEp); this_baud = CDTE.baud_rate; if CDTE.flags.autobaud then this_baud = -1; if this_baud ^= dft_baud then do; next_baud = addr (cdt.cdt_entry (i + 1)) -> CDTE.baud_rate; if addr (cdt.cdt_entry (i + 1)) -> CDTE.flags.autobaud then next_baud = -1; if next_baud = this_baud then do; dft_baud = this_baud; if dft_baud = -1 then line = "Baud: auto;"; else if dft_baud = 0 then line = "Baud: none;"; else call ioa_$rsnnl ("Baud: ^d;", line, len, dft_baud); call append_line; end; end; call ioa_$rsnnl ("name: ^a;", line, len, CDTE.name); call append_line; if this_baud ^= dft_baud then do; if this_baud = -1 then line = " baud: auto;"; else if this_baud = 0 then line = " baud: none;"; else call ioa_$rsnnl ("^3xbaud: ^d;", line, len, CDTE.baud_rate); call append_line; end; if CDTE.service_type ^= ANS_SERVICE then do; call ioa_$rsnnl ("^3xservice: ^a;", line, len, service_types (CDTE.service_type)); call append_line; end; if CDTE.service_type = MPX_SERVICE then do; call ioa_$rsnnl ("^3xmultiplexer_type: ^a", line, len, mpx_types (CDTE.mpx_type)); if CDTE.mpx_service = INACTIVE then call addto_line (", inactive"); call addto_line (";"); call append_line; end; if CDTE.charge_type > 0 then do; call ioa_$rsnnl ("^3xcharge: ^a;", line, len, dvt (CDTE.charge_type).devid); call append_line; end; if CDTE.initial_terminal_type ^= "" then do; call ioa_$rsnnl ("^3xterminal_type: ^a;", line, len, CDTE.initial_terminal_type); call append_line; end; if CDTE.line_type > 0 | CDTE.line_type = -1 then do; call ioa_$rsnnl ("^3xline_type: ^a", line, len, line_types (CDTE.line_type)); if CDTE.line_type = LINE_BSC then do; if CDTE.flags.bsc_ebcdic then call addto_line (", ebcdic"); else call addto_line (", ascii"); if CDTE.flags.bsc_transparent then call addto_line (", transparent"); else call addto_line (", nontransparent"); end; call addto_line (";"); call append_line; end; if CDTE.modem_type > 0 then do; call ioa_$rsnnl ("^3xdataset: ^a", line, len, dataset_names (CDTE.modem_type)); if CDTE.flags.private_line then call addto_line (", private_line;"); else call addto_line (";"); call append_line; end; if ^(aim_check_$equal (system_low, CDTE.access_class (1)) & aim_check_$equal (system_low, CDTE.access_class (2))) then do; call convert_authorization_$to_string_range_short (CDTE.access_class, auth, code); call ioa_$rsnnl ("^3xaccess_class: ""^a"";", line, len, auth); call append_line; end; if CDTE.flags.ck_answerback & (addr (CDTE.answerback) -> bb72 ^= "0"b & CDTE.answerback ^= "") then do; call ioa_$rsnnl ("^3xanswerback: ""^a"";", line, len, CDTE.answerback); call append_line; end; if string (CDTE.flags.attributes) then do; vline = " attributes: "; if CDTE.flags.audit_access_error then vline = vline || "audit,"; if CDTE.flags.hardwired then vline = vline || "hardwired,"; if CDTE.flags.set_modes then vline = vline || "set_modes,"; if CDTE.flags.ck_answerback then vline = vline || "check_answerback,"; if CDTE.flags.dont_read_answerback then vline = vline || "dont_read_answerback,"; substr (vline, length (vline), 1) = ";"; line = vline; call append_line; end; if string (CDTE.flags.access_control) then do; vline = " check_acs: "; if CDTE.flags.dial_out then vline = vline || "dial_out,"; if CDTE.flags.priv_attach then vline = vline || "priv_attach,"; if CDTE.flags.dial_server then vline = vline || "dial_server,"; if CDTE.flags.slave_dial then vline = vline || "slave_dial,"; if CDTE.flags.login then vline = vline || "login,"; substr (vline, length (vline), 1) = ";"; line = vline; call append_line; end; if CDTE.flags.execute_initial_command & (addr (CDTE.initial_command) -> bb72 ^= "0"b & CDTE.initial_command ^= "") then do; call ioa_$rsnnl ("^3xinitial_command: ""^a"";", line, len, CDTE.initial_command); call append_line; end; if CDTE.flags.generic_destination_present & (addr (CDTE.initial_command) -> bb72 ^= "0"b & addr (CDTE.initial_command) -> generic_destination ^= "") then do; call ioa_$rsnnl ("^3xgeneric_destination: ""^a"";", line, len, addr (CDTE.initial_command) -> generic_destination); call append_line; end; if CDTE.comment ^= "" then do; /* put comment last in case user wants to edit CMF to have entire */ call ioa_$rsnnl ("^3xcomment: ""^a"";", line, len, CDTE.comment); /* channel entry on one line */ call append_line; end; line = ""; call append_line; return; end; append_line: proc; call ioa_$ioa_switch (switch, "^a", line); return; end; addto_line: proc (thing); dcl thing char (*); line = substr (line, 1, len) || thing; len = len + length (thing); return; end; RETURN: return; end dump_cmf_;  ed_installation_parms.pl1 10/07/88 1218.8rew 10/07/88 1214.7 1151910 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(87-03-30,Parisek), approve(87-05-01,MCR7690), audit(87-07-15,Beattie), install(87-08-04,MR12.1-1055): Add parameter 64 - vchn_requires_accept. 2) change(87-08-17,Hartogs), approve(88-08-15,MCR7969), audit(87-08-24,GDixon), install(88-08-29,MR12.2-1093): Error handling for -dr fixed for rate_structure_0. (phx14904) 3) change(88-09-19,GDixon), approve(88-09-20,MCR8012), audit(88-10-06,Farley), install(88-10-07,MR12.2-1142): Fix error in initiating the installation_parms (rate_structure_0) segment introduced by an earlier change (error_table_$segknown is being reported as an error, rather than being ignored). END HISTORY COMMENTS */ /* format: style4 */ ed_installation_parms: procedure; /* ED_INSTALLATION_PARMS - program to edit the "installation_parms" segment which gives the prices for all system resources, and various other system_wide accounting-type constants. Modified 740805 by PG for level & category names. Modified 741120 by LJS for syserr log copying threshold. Modified Aug 1977 by T. Casey for disk and tape device price setting Modified May 1978 by T. Casey to add parameters 21, ..., 32: resource prices, rcp_init_flags, and . various times and counters used in answering service operation. Modified August 1978 by M. R. Jordan to fix bug in set_rcp_init_flag. Modified November 1978 by T. Casey to add parameters 33,...47 for MR7.0 absentee changes. Modified March 1979 by C. D. Tavares to change rcp_init_flags and handling Modified July 1979 by J. N. R. Barnecut for MR8.0 to support multiple rate structures. (UNCA) Modified May 1980 by J. N. R. Barnecut to ensure devices and resources are kept in same positions. (UNCA) Modified 22 September 1980 by G. Palter to add parameter 48 -- abs_default_queue Modified 6 April 1981 by E. N. Kittlitz to add parameters 49,50 -- cwe_count, cwe_time Modified 3 June 1981 by E. N. Kittlitz for UNCA rate structures, re-organization. . Added parameters 51-55: rates, devices, resources, rate_structure_name, all_structures. . mr9_default establishes version, converts abs cpu limits from fixed bin (17) to fixed bin (35). . Program extensively re-structured, although many sub-tasks stayed the same. Modified 22 February 1982 by E. N. Kittlitz for bug fixes. Modified May 1982 by E. N. Kittlitz for retype prices change. Modified 1984-06-19 BIM for strict_trusted_path, remove ARPA Modified 1984-12, BIM: pdir quota values, operator login values. Modified 1985-01-09, BIM: message coordinator access control. Modified 1985-03-01 by E. Swenson for password flags. */ /* automatic */ dcl all_sw bit (1) aligned; dcl all_abs_queue_sw bit (1) aligned; dcl all_rates_sw bit (1) aligned; dcl all_structures_sw bit (1) aligned; dcl argp ptr; dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argno fixed bin; dcl change_request bit (1) aligned; dcl char32 char (32); dcl char48 char (48); dcl char8 char (8); dcl comm char (32); dcl copy_ip (ipl) fixed bin based; dcl critical_op bit (1) aligned; dcl cur_rs_ptr ptr; dcl did_something bit (1) aligned; dcl dn char (168); dcl dnvar char (168) varying; dcl ec fixed bin (35); dcl edit_rs bit (1) aligned; dcl en char (32); dcl i fixed bin; dcl ip ptr defined (rs_ptrs (0)); /* working copy of installation_parms */ dcl ip1 ptr defined (rs_ptrs1 (0)); dcl ipl fixed bin; dcl j fixed bin; dcl k fixed bin; dcl keywx fixed bin; dcl nargs fixed bin; dcl path char (168) init (""); dcl print_comm char (32); dcl rs_ptrs (0:9) ptr; /* rate structure pointers */ dcl rs_ptrs1 (0:9) ptr; dcl rsp ptr; dcl rsp1 ptr; dcl selected_rs_ptr ptr; dcl suppress_nl bit (1) aligned; dcl (cleanup, program_interrupt) condition; /* internal static constants */ dcl NOLIMIT fixed bin (35) int static options (constant) init (-999999); dcl MILLION fixed bin (35) int static init (1000000); dcl SECONDS_PER_MONTH float bin (27) init (30 * 24 * 3600) int static options (constant); dcl ADD fixed bin init (1) static options (constant); dcl CHANGE fixed bin init (2) static options (constant); dcl PRINT fixed bin init (3) static options (constant); dcl RETYPE fixed bin init (4) static options (constant); dcl NO_SPECIAL_DEVICES bit (1) aligned init ("0"b) static options (constant); dcl SPECIAL_DEVICES_OK bit (1) aligned init ("1"b) static options (constant); dcl NOT_RS_ID fixed bin init (-2) static options (constant); dcl ID_NOT_FOUND fixed bin init (-1) static options (constant); dcl ALL_RS bit (1) aligned init ("1"b) static options (constant); dcl THIS_RS bit (1) aligned init ("0"b) static options (constant); dcl SET_HI bit (1) aligned init ("1"b) static options (constant); dcl NO_SET_HI bit (1) aligned init ("0"b) static options (constant); dcl COMPLAIN bit (1) aligned init ("1"b) static options (constant); dcl daynam char (21) int static options (constant) init ("MonTueWedThuFriSatSun"); dcl me char (24) int static options (constant) init ("ed_installation_parms"); dcl ip_rings (3) fixed bin (3) init (4, 5, 5) int static options (constant); /* internal static */ dcl told_user bit (1) aligned internal static init ("0"b); /* based structures */ dcl based_integer fixed bin based; /* builtins */ declare (addr, before, bit, char, currentsize, dim, dimension, divide, fixed, hbound, index, lbound, length, ltrim, bin, null, ptr, rel, reverse, rtrim, string, substr, verify, unspec) builtin; /* external variables */ dcl error_table_$badopt fixed bin (35) ext static; dcl error_table_$inconsistent ext fixed bin (35); dcl error_table_$incorrect_access fixed bin (35) ext static; dcl error_table_$segknown fixed bin (35) ext static; dcl error_table_$segnamedup fixed bin (35) ext static; /* entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl ask_ entry options (variable); dcl ask_$ask_clr entry (); dcl ask_$ask_flo entry options (variable); dcl ask_$ask_int entry options (variable); dcl ask_$ask_line entry options (variable); dcl ask_$ask_n entry options (variable); dcl ask_$ask_yn entry options (variable); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cv_$mwvf entry (float bin) returns (char (15)); dcl cv_dec_ entry (char (*)) returns (fixed bin (35)); dcl cv_float_ entry (char (*), fixed bin (35), float bin (27)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl hcs_$set_safety_sw_seg entry (ptr, bit (1), fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35)); dcl ioa_ entry options (variable); dcl nd_handler_ entry (char (*), char (*), char (*), fixed bin (35)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); %page; /* The following two static arrays, keyw and keyn, map the keywords and their (zero or more) abbreviations into key numbers that map into the label arrays. These two arrays must be kept in sync if keywords or abbreviations are added, and the values in the keyn array must always be in increasing order. Notice that each array is the other one with its value and comment columns interchanged. Another array valid_rs_id must also be updated when adding an identifier which may be used when editing a rate structure. There are also arrays sequence_ALL and sequence_RATES which may require updating when adding a new identifier. */ dcl keyw (119) char (32) int static options (constant) init ("all", /* 1 */ "installation_id", /* 2 */ "inst", /* 2 */ "shift_table", /* 3 */ "shif", /* 3 */ "prices", /* 4 */ "titles", /* 5 */ "level_names", /* 6 */ "leve", /* 6 */ "inactive_time", /* 7 */ "inac", /* 7 */ "warning_time", /* 8 */ "warn", /* 8 */ "login_time", /* 9 */ "logi", /* 9 */ "tries", /* 10 */ "update_time", /* 11 */ "upda", /* 11 */ "device_prices", /* 12 */ "devprice", /* 12 */ "devp", /* 12 */ "config_table", /* 13 */ "conf", /* 13 */ "queue_prices", /* 14 */ "abs_queue_parameters", /* 15 */ "abs_", /* 15 */ "category_names", /* 16 */ "cate", /* 16 */ "access_ceiling", /* 17 */ "acce", /* 17 */ "log_parameters", /* 18 */ "log_", /* 18 */ "trusted_path_login", /* 19 */ "device_names", /* 20 */ "devname", /* 20 */ "devn", /* 20 */ "resource_prices", /* 21 */ "rscprice", /* 21 */ "rscp", /* 21 */ "resource_names", /* 22 */ "rscname", /* 22 */ "rscn", /* 22 */ "resource_wait_time", /* 23 */ "rsctime", /* 23 */ "rsct", /* 23 */ "fpe_time", /* 24 */ "fpetime", /* 24 */ "fpet", /* 24 */ "fpe_count", /* 25 */ "fpecount", /* 25 */ "fpec", /* 25 */ "trm_real_time", /* 26 */ "trmrealtime", /* 26 */ "trmr", /* 26 */ "trm_cpu_time", /* 27 */ "trmcputime", /* 27 */ "trmc", /* 27 */ "unload_on_detach", /* 28 */ "unlo", /* 28 */ "authentication_level", /* 29 */ "auth", /* 29 */ "default_pdir_seg_quota", /* 30 */ "df_pdsq", /* 30 */ "rsc_mgmt_enabled", /* 31 */ "rsc_", /* 31 */ "auto_registration", /* 32 */ "auto", /* 32 */ "enable_ss_volume_mount", /* 33 */ "foreground_queue_position", /* 34 */ "fore", /* 34 */ "idle_time_constant", /* 35 */ "idle", /* 35 */ "sus_cpu_time", /* 36 */ "susc", /* 36 */ "sus_real_time", /* 37 */ "susr", /* 37 */ "max_abs", /* 38 */ "min_abs", /* 39 */ "pct_abs", /* 40 */ "max_qres", /* 41 */ "min_qres", /* 42 */ "pct_qres", /* 43 */ "abs_cpu_max_limit", /* 44 */ "abscpumx", /* 44 */ "abs_timax", /* 45 */ "abs_cpu_default_limit", /* 46 */ "abscpudf", /* 46 */ "foreground_cpu_default_limit", /* 47 */ "fgcpudf", /* 47 */ "abs_default_queue", /* 48 */ "absdfq", /* 48 */ "cwe_time", /* 49 */ "cwet", /* 49 */ "cwe_count", /* 50 */ "cwec", /* 50 */ "rates", /* 51 */ "devices", /* 52 */ "device", /* 52 */ "resources", /* 53 */ "resource", /* 53 */ "rate_structure_names", /* 54 */ "rate_structure_name", /* 54 */ "rsn", /* 54 */ "all_structures", /* 55 */ "default_pdir_dir_quota", /* 56 */ "df_pddq", /* 56 */ "require_operator_login", /* 57 */ "operator_inactive_time", /* 58 */ "op_inac", /* 58 */ "validate_daemon_commands", /* 59 */ "password_min_length", /* 60 */ "pwml", /* 60 */ "password_gpw_length", /* 61 */ "pwgl", /* 61 */ "password_change_interval", /* 62 */ "pwci", /* 62 */ "password_expiration_interval", /* 63 */ "pwei", /* 63 */ "vchn_requires_accept" /* 64 */ ); %page; dcl keyn (119) fixed bin int static options (constant) init (1, /* all */ 2, /* installation_id */ 2, /* inst */ 3, /* shift_table */ 3, /* shif */ 4, /* prices */ 5, /* titles */ 6, /* level_names */ 6, /* leve */ 7, /* inactive_time */ 7, /* inac */ 8, /* warning_time */ 8, /* warn */ 9, /* login_time */ 9, /* logi */ 10, /* tries */ 11, /* update_time */ 11, /* upda */ 12, /* device_prices */ 12, /* devprice */ 12, /* devp */ 13, /* config_table */ 13, /* conf */ 14, /* queue_prices */ 15, /* abs_queue_parameters */ 15, /* abs_ */ 16, /* category_names */ 16, /* cate */ 17, /* access_ceiling */ 17, /* acce */ 18, /* log_parameters */ 18, /* log_ */ 19, /* trusted_path_login */ 20, /* device_names */ 20, /* devname */ 20, /* devn */ 21, /* resource_prices */ 21, /* rscprice */ 21, /* rscp */ 22, /* resource_names */ 22, /* rscname */ 22, /* rscn */ 23, /* resource_wait_time */ 23, /* rsctime */ 23, /* rsct */ 24, /* fpe_time */ 24, /* fpetime */ 24, /* fpet */ 25, /* fpe_count */ 25, /* fpecount */ 25, /* fpec */ 26, /* trm_real_time */ 26, /* trmrealtime */ 26, /* trmr */ 27, /* trm_cpu_time */ 27, /* trmcputime */ 27, /* trmc */ 28, /* unload_on_detach */ 28, /* unlo */ 29, /* authentication_level */ 29, /* auth */ 30, /* default_pdir_quota */ 30, /* df_pdsq */ 31, /* rsc_mgmt_enabled */ 31, /* rsc_ */ 32, /* auto_registration */ 32, /* auto */ 33, /* enable_ss_volume_mount */ 34, /* foreground_queue_position */ 34, /* fore */ 35, /* idle_time_constant */ 35, /* idle */ 36, /* sus_cpu_time */ 36, /* susc */ 37, /* sus_real_time */ 37, /* susr */ 38, /* max_abs */ 39, /* min_abs */ 40, /* pct_abs */ 41, /* max_qres */ 42, /* min_qres */ 43, /* pct_qres */ 44, /* abs_cpu_max_limit */ 44, /* abscpumx */ 45, /* abs_timax */ 46, /* abs_cpu_default_limit */ 46, /* abscpudf */ 47, /* foreground_cpu_default_limit */ 47, /* fgcpudf */ 48, /* abs_default_queue */ 48, /* absdfq */ 49, /* cwe_time */ 49, /* cwet */ 50, /* cwe_count */ 50, /* cwec */ 51, /* rates */ 52, /* devices */ 52, /* device */ 53, /* resources */ 53, /* resource */ 54, /* rate_structure_names */ 54, /* rate_structure_name */ 54, /* rsn */ 55, /* all_structures */ 56, /* default_pdir_dir_quota */ 56, /* df_pddq */ 57, /* require_operator_login */ 58, /* operator_inactive_time */ 58, /* op_inac */ 59, /* validate_daemon_commands */ 60, /* password_min_length */ 60, /* pwml */ 61, /* password_gpw_length */ 61, /* psgl */ 62, /* password_change_interval */ 62, /* pwci */ 63, /* password_expiration_interval */ 63, /* pwei */ 64 /* vchn_requires_accept */ ); %page; /* valid_for_rs contains the indices of all change identifiers which may be used while editing a rate_structure. They must be in ascending order. A flag of 999 must be the last element. */ dcl valid_for_rs (13) fixed bin static options (constant) init (1, 4, 12, 14, 20, 21, 22, 51, 52, 53, 54, 55, 999); /* sequence_ALL defines the order in which individual requests will be made if the 'all' request is issued. */ dcl sequence_ALL (54) fixed bin static options (constant) init (1, 2, 5, 7, 8, 9, 10, 49, 50, 11, 4, 14, 52, 53, 3, 6, 16, 17, 18, 19, 57, 64, 58, 59, 60, 61, 62, 63, 13, 23, 30, 56, 24, 25, 26, 27, 37, 36, 28, 29, 31, 32, 33, 35, 34, 47, 48, 15, 38, 39, 40, 41, 42, 43); /* sequence_RATES controls the order in which operations are performed when the identifier 'rates' (or 'all' when editing a rate_structure) is used. It contains only indices of rate_structure identifiers, in the same order as sequence_ALL. */ dcl sequence_RATES (5) fixed bin static options (constant) init (51, 4, 14, 12, 21); /* sequence_ABS_Q controls the abs_queue_parameters identifier */ dcl sequence_ABS_Q (4) fixed bin static options (constant) init (15, 44, 45, 46); %page; /* DIVERS POINTS This program supports the editing of installation_parms and up to nine additional rate_structures. The accounting system is designed to charge for resources based upon pricing information contained in the rate_structure to which a user or project is assigned. The default pricing is contained in installation_parms, and is considered to be rate_structure 0. If a site defines other rate_structures, they are numbered 1 through 9. The rate_structure definition is the same as installation_parms. However, certain fields are designated as invalid in a rate_structure. Additional rate_structures exist in segments names rate_structure_N. When accounting, a routine accesses all pricing information by using the rate_structure segment appropriate to the user/project being charged. Rate_structure names appear in installation_parms.rate_structures. There are installation_parms.nrates structures (<= 9), where structure 0 is "default" (i.e. installation_parms). This program is designed to allow the user to alter the fields of one rate_structure at a time. The user indicates which rate_structure is under consideration via the "rate_structure" command. In general, all subsequent editing requests act upon the last-specified rate_structure. Terminology: installation_parms is rate_structure 0. Its name is initially "default". Within this program, the notion of editing a rate_structure is typically defined as editing a rate_structure other than installation_parms. There are a number of operations on rate_structure field which can only be performed while editing the default rate_structure (i.e. installation_parms). In general, any operation which affects more than one rate_structure (such as renaming or retyping device information) can only be performed while editing installation_parms. WITHIN this program: the requests of principal interest are: add, change, print and retype. These requests are dispatched to the procedure do_any. The do_any procedure does first-level checks to determine if a valid field identifier has been specified. It also determines whether or not the field is "defined" in non-default rate_structures. An identifier is valid for a rate_structure only if its index appears in the array valid_for_rs. (This technique is used to avoid having to add a control for every new identifier (most of which will be non-rate_structure). The do_any procedure calls the appropriate processor for the request given. If there is any conflict, an individual processor is responsible for detecting an invalid use of a non-rate_structure field. There are several field identifiers which correspond to a group of field identifiers. Examples are "all", "abs_queue_parameters" and "rates". In these cases, do_any will make a number of calls to the designated processor. The identifier "all_structures" causes do_any to loop over all rate_structures (including installation_parms). THERE are a number of internal procedures with entries. Said entries have names of the form int_proc$$entry_name. */ %page; /* INITIALIZATION */ call ask_$ask_clr (); /* make sure nothing in ask_ buffer */ ip = null; /* initialize pointers */ ip1 = null; rs_ptrs (*), rs_ptrs1 (*) = null; edit_rs = "0"b; /* and switches */ selected_rs_ptr, cur_rs_ptr = null; critical_op = "0"b; on cleanup call clean_up; dn = ""; call cu_$arg_count (nargs); /* look for control arguments */ if nargs > 0 then do argno = 1 to nargs; call cu_$arg_ptr (argno, argp, argl, ec); /* next, please */ if ec ^= 0 then do; call com_err_ (ec, me); /* horrors! */ go to exit; end; else if arg = "-directory" | arg = "-dr" then do; /* containing directory? */ if path ^= "" then /* already have a path? */ go to er2; /* inconsitent... */ else do; argno = argno + 1; /* go for directory name */ call cu_$arg_ptr (argno, argp, argl, ec); if ec ^= 0 then do; /* user's fingers wore out */ call com_err_ (ec, me); /* display our distress */ go to exit; /* clean up */ end; else do; /* where to go */ call absolute_pathname_ (arg, dn, ec); if ec ^= 0 then do; call com_err_ (ec, me, "^a", arg); go to exit; end; en = "installation_parms"; end; end; end; else if substr (arg, 1, 1) = "-" then do; /* look like a control arg? */ call com_err_ (error_table_$badopt, me, "^a", arg); /* well, it isn't */ go to exit; end; else if dn ^= "" then do; /* pathname? */ er2: call com_err_ (error_table_$inconsistent, me, "pathname and -directory arguments may not both be specified."); go to exit; end; else do; /* pathname, and it makes sense */ path = arg; call expand_pathname_ (path, dn, en, ec); if ec ^= 0 then do; call com_err_ (ec, me, "^a", path); go to exit; end; end; end; else do; /* default path */ path = "installation_parms"; call expand_pathname_ (path, dn, en, ec); if ec ^= 0 then do; call com_err_ (ec, me, "^a", path); go to exit; end; end; if dn = ">" then dnvar = ">"; else dnvar = rtrim (dn) || ">"; /* Find all rate structures. NOTE: When i is set to 0 (the first trip), we get the value of rs_ptrs (0), i.e. also the value of the pointer "ip". Then, we have an installation_parms structure 'defined', and can loop from 1 - installation_parms.nrates. */ do i = 0, 1 repeat i + 1 while (i <= installation_parms.nrates); if i = 0 then do; en = "installation_parms"; /* make or initiate installation_parms */ call hcs_$make_seg (dn, en, "", RW_ACCESS_BIN, rsp1, ec); if ec = 0 then do; /* segment was just created */ rsp1 -> installation_parms.version = installation_parms_version_2; create_addname: /* add the name rate_structure_0 to installation_parms */ call hcs_$chname_file (dn, "installation_parms", "", "rate_structure_0", ec); if ec ^= 0 & ec ^= error_table_$segnamedup & ec ^= error_table_$incorrect_access then do; /* not on installation_parms? */ call nd_handler_ (me, dn, "rate_structure_0", ec); /* try to get the name freed */ if ec = 0 then go to create_addname; /* try again */ end; call hcs_$set_ring_brackets (dn, en, ip_rings, ec); /* so try to set rings */ if ec ^= 0 then call com_err_ (ec, me, "Setting ring brackets of ^a.", en); end; /* set the version, so we don't 'convert' later */ else if ec ^= error_table_$segknown then do; call com_err_ (ec, me, "rate_structure_^d ^a.", i, dnvar || rtrim (en)); go to exit; end; end; else do; /* if installation_parms says there an RS */ en = "rate_structure_" || ltrim (char (i)); /* then the RS segment MUST exist */ call initiate_file_ (dn, en, R_ACCESS, rsp1, (0), ec); end; if rsp1 = null then do; /* something go wrong? */ call write_error (ec, i, dnvar || rtrim (en)); go to exit; end; call hcs_$make_seg ("", "", "", RW_ACCESS_BIN, rsp, ec); /* now get temporaries */ if rsp = null then do; call write_error (ec, i, "temporary segment"); go to exit; end; ipl = currentsize (rsp1 -> installation_parms); /* copy contents to temp segment */ unspec (rsp -> copy_ip) = unspec (rsp1 -> copy_ip); rs_ptrs (i) = rsp; rs_ptrs1 (i) = rsp1; if i = 0 then do; /* some gullibility checks */ selected_rs_ptr, cur_rs_ptr = ip; if installation_parms.version ^= installation_parms_version_2 then do; if installation_parms.version ^= installation_parms_version_1 then do; call ioa_ ("The installation_parms segment is either damaged or a pre-MR9.0 version.^/If it is damaged, recover it from backup. If it is pre-MR9.0, MR10.2 or earlier must be used to convert it."); go to exit; end; else do; call ioa_ ("Converting installation parms to MR11 format."); installation_parms.version = installation_parms_version_2; installation_parms.trusted_path_login = "0"b; installation_parms.require_operator_login = "0"b; installation_parms.vchn_requires_accept = "0"b; installation_parms.operator_inactive_time = installation_parms.inactive_time; installation_parms.syserr_log_copy_threshold = 0; installation_parms.validate_daemon_commands = "0"b; installation_parms.password_min_length = 0; /* no minimum */ installation_parms.password_gpw_length = 6; installation_parms.password_change_interval = 0; /* no change interval */ installation_parms.password_expiration_interval = 0; /* no expiration */ call set_pdir_quota_defaults; /* knows about communications */ end; end; if installation_parms.nrates < 0 | installation_parms.nrates > hbound (rs_ptrs, 1) then do; call com_err_ (0, me, "Invalid number of rate_structures at offset ^o (8): ^d. Forcing value to 0.", bin (rel (addr (installation_parms.nrates)), 18), installation_parms.nrates); installation_parms.nrates = 0; end; end; end; /* Handler for PROGRAM_INTERRUPT condition If a 'critical' operation is in progress, we ask the user whether or not we should really punt. If not critical, or user says it's OK, we non-local goto back to the main loop. Otherwise, restart. */ on program_interrupt begin; dcl yn char (4); if critical_op then do; /* HOT? */ call ioa_ ("Terminating the current operation may leave tables in an inconsistent state."); call ask_$ask_yn ("Do you want to terminate? (""no"" will restart the operation) ", yn); if yn = "yes" then go to main1; /* we warned you */ end; else go to main1; /* safe to zap, so do it */ end; %page; /* MAIN REQUEST LOOP */ main1: call ask_$ask_clr (); main: if ^told_user then do; /* Should we give instructions? */ call ioa_ ("Hit QUIT and use ""program_interrupt"" to return this request loop."); told_user = "1"b; /* never again in this process */ end; cur_rs_ptr = selected_rs_ptr; /* make sure we're using the proper rate_structure */ edit_rs = (cur_rs_ptr ^= ip); /* editing a rate_structure? */ critical_op = "0"b; all_sw = "0"b; /* OFF until: all, all_structures */ all_abs_queue_sw = "0"b; /* OFF until: all, all_structures, abs_queue_parameters */ all_rates_sw = "0"b; /* OFF until: all, all_structures, rates */ all_structures_sw = "0"b; /* OFF until: all_structures */ change_request = "0"b; /* OFF unless 'change' command */ call ask_ ("type ", comm); /* get command */ if comm = "q" then do; exit: call clean_up; return; end; else if comm = "w" then do; /* write? */ call ask_$ask_n (char8, j); /* write -force? */ if j ^= 0 then if ^(char8 = "-force" | char8 = "-fc") then j = 0; do i = installation_parms.nrates to 0 by -1; /* write all rate_structures */ /* and then installation_parms */ ipl = currentsize (rs_ptrs (i) -> rate_structure); /* HOW big was it? */ call hcs_$truncate_seg (rs_ptrs1 (i), (ipl), ec); /* tidy up end */ if ec ^= 0 then do; /* nice way to detect no-write */ call write_error (ec, i, ""); /* let user know */ if j ^= 0 then go to main1; /* if not -force */ end; unspec (rs_ptrs1 (i) -> copy_ip) = unspec (rs_ptrs (i) -> copy_ip); /* copy to real segment */ call hcs_$set_bc_seg (rs_ptrs1 (i), 36 * ipl, ec); /* show 'em how big it is */ if ec ^= 0 then do; /* any little problems? */ call write_error (ec, i, ""); if j = 0 then go to main1; /* give up, or -force ? */ end; call hcs_$set_safety_sw_seg (rs_ptrs1 (i), "1"b, ec); if ec ^= 0 then do; /* ok or not */ call write_error (ec, i, ""); if j = 0 then go to main1; /* not -force? */ end; end; end; else if comm = "a" | comm = "add" then call do_any (ADD); else if comm = "c" | comm = "change" then call do_any (CHANGE); else if comm = "p" | comm = "pr" | comm = "print" then call do_any (PRINT); else if comm = "r" | comm = "retype" then call do_any (RETYPE); else if comm = "default" then go to default; /* defaults of some kind */ else if comm = "v" | comm = "verify" then call verify_structures; else if comm = "h" | comm = "help" then do; /* help of some kind */ call ioa_ ("Requests: change ID, print ID, retype ID, add ID, w, q"); /* basic requests */ call ioa_ ("help {-long}, default, mrXX_default, rate_structure RSN, copy, verify"); if edit_rs then call ioa_ ("Use: ""rate_structure ."" to edit the ""installation_parms"" segment."); call ioa_ (" Valid ids: all"); /* special case first */ call ask_$ask_n (char32, k); /* user wants long output? */ if k ^= 0 & (char32 = "long" | char32 = "-long" | char32 = "-lg") then k = 1; /* long, it is */ else k = 0; /* 2 to 1 user types it later... */ j = 1; do i = 2 to hbound (keyw, 1); /* print all keywords */ do while (keyn (i) > valid_for_rs (j) & j < hbound (valid_for_rs, 1)); j = j + 1; /* next valid RS id */ end; if ^edit_rs | keyn (i) = valid_for_rs (j) then /* not RS, or OK for RS */ if k ^= 0 | keyn (i) ^= keyn (i - 1) then /* not same 'ID', or -long */ call ioa_ ("^13x^[^2x^]^a", (keyn (i) = keyn (i - 1)), keyw (i)); /* with short forms indented */ end; go to main1; end; else if comm = "rates" | comm = "rate_structure" then do; call ask_$ask_n (char32, i); /* trying to go somewhere? */ if i = 0 then /* no - just lost */ call ioa_ ("Editing rate_structure ""^a"".", ptr_rs_name (cur_rs_ptr)); else do; call ask_ ("", char32); /* pick it off the line */ i = rstab$$defined (char32, COMPLAIN); /* does it exist? */ if i < 0 then go to main1; /* oh my, no it doesn't */ selected_rs_ptr = rs_ptrs (i); /* all works out at label main */ end; end; else if comm = "copy" then go to copy_rs; /* from 1 RS to another */ else do; call ioa_ ("Illegal command ""^a"". Type help for instructions.", comm); go to main1; end; go to main; /* beg for more */ %page; /* DEFAULT HANDLING for INSTALLATION_PARMS */ default: if edit_rs then go to default_rs; /* will this change device table or resource table? VERY dangerous */ if installation_parms.nrscp > 0 | installation_parms.ndevices > hbound (dev_id, 1) | installation_parms.version < 0 | installation_parms.version > installation_parms_version_1 | installation_parms.version = 0 & ptr (ip, 1076) -> based_integer > 0 then do; call ioa_ ("This operation may make other system tables invalid."); call ask_$ask_yn ("Do you want to proceed? ", char8); if char8 ^= "yes" then go to main1; end; installation_parms.installation_id = "Installation and location"; installation_parms.company = "Company Name"; installation_parms.department = "Department Name"; installation_parms.companyds = "C o m p a n y N a m e"; installation_parms.departmentds = "D e p a r t m e n t"; call set_std_shifttab; do i = 0 to 7; rate_structure.cpu_price (i) = 240e0; rate_structure.log_base_price (i) = 1.25e0; rate_structure.io_ops_price (i) = 0e0; rate_structure.core_price (i) = 15e0; end; rate_structure.ndevices = hbound (dev_id, 1); /* define those devices for which charging is built in */ do i = 1 to 16; if i <= rate_structure.ndevices then rate_structure.device_id (i) = dev_id (i); else rate_structure.device_id (i) = "dev" || ltrim (char (i)); /* fill in non-garbage for undefined ones */ do j = 0 to 7; rate_structure.device_price (i, j) = 1e0; /* initialize for all shifts */ end; end; installation_parms.default_pdir_dir_quota, installation_parms.default_pdir_seg_quota = 1000; installation_parms.operator_inactive_time, installation_parms.inactive_time = 3600; installation_parms.warning_time = 300; installation_parms.login_time = 360; installation_parms.acct_update = 900; installation_parms.login_tries = 6; rate_structure.disk_price = .19290120e-6; rate_structure.registration_price = 0e0; rate_structure.dolsign = "$"; do i = 1 to 4; rate_structure.abs_cpu_price (i) = 200e0; rate_structure.abs_mem_price (i) = 15e0; rate_structure.iod_rec_price (i) = 1.80e0; installation_parms.abs_timax (i) = 16000000; installation_parms.abs_cpu_default_limit (i) = 1200; /* 1200 seconds = 20 minutes */ end; do i = 1 to hbound (installation_parms.level_names (*), 1); installation_parms.level_names (i) = "level_" || ltrim (char (i)); installation_parms.short_level_names (i) = "l" || ltrim (char (i)); /* man-or-boy common sub-expression test */ end; installation_parms.level_names (0) = ""; /* level zero is blank */ installation_parms.short_level_names (0) = ""; do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1); installation_parms.category_names (i) = "category_" || ltrim (char (i)); installation_parms.short_category_names (i) = "c" || ltrim (char (i)); end; installation_parms.access_authorization_ceiling = ""b; /* Level 0, no categories */ installation_parms.ncon = 1; installation_parms.cpu (1) = 8; installation_parms.shift (1) = 7; installation_parms.x1 (1) = 0; installation_parms.kmem (1) = 16384; installation_parms.kbulk (1) = 16384; installation_parms.x2 (1) = 0; installation_parms.maxa (1) = 3; installation_parms.maxq (1) = 3; installation_parms.maxu_base (1) = 900; installation_parms.response_high (1) = 300; installation_parms.response_low (1) = 100; installation_parms.x3 (1) = 0; installation_parms.syserr_log_copy_threshold = 0; /* use default value in ring 0. */ /* Following parameters added for MR6.5 */ unspec (installation_parms.rcp_init_flags) = ""b; /* all flags off */ installation_parms.nrscp = 0; /* no resource prices defined */ installation_parms.rsc_timer_seconds = 300; /* 5 minutes between tries for resource reservations */ installation_parms.fatal_error_loop_count = 3; /* any user who gets 3 fatal process errors */ installation_parms.fatal_error_loop_seconds = 60; /* within one minute, gets logged out */ installation_parms.term_real_time_seconds = 120; /* allow 2 minutes to signal finish after getting trm_ signal */ installation_parms.term_cpu_time_seconds = 5; /* and only 5 seconds of cpu time (in case of runaway process) */ /* Following parameters added for MR7.0 */ do i = 1 to 4; if installation_parms.abs_cpu_default_limit (i) > MILLION then /* if limit is still in microseconds */ installation_parms.abs_cpu_default_limit (i) = divide (installation_parms.abs_cpu_default_limit (i), MILLION, 35, 0); /* convert it to seconds */ end; installation_parms.foreground_queue_position = 0; /* foreground queue comes after Q 0, before Q 1 */ installation_parms.foreground_cpu_default_limit = installation_parms.abs_cpu_default_limit (3); /* current shift 3 limit is better than none at all */ installation_parms.idle_time_constant_seconds = 900; /* average the idle units over the last 5 minutes */ installation_parms.sus_cpu_time_seconds = 5; /* allow suspended process to use up to 5 cpu seconds */ installation_parms.sus_real_time_seconds = 180; /* and up to 3 minutes for it to respond, before destroying it */ do i = 0 to 7; /* go thru shifts */ installation_parms.max_abs (i) = -1; /* -1 means "use the abs_maxu in the config array" */ installation_parms.min_abs (i) = 0; installation_parms.pct_abs (i) = 0; do j = 1 to 4; /* go thru queues */ installation_parms.abs_cpu_max_limit (i, j) = installation_parms.abs_cpu_default_limit (j); /* keeping the effective limits the same as they are now */ installation_parms.max_qres (i, j) = 0; /* no slots reserved, by default */ installation_parms.min_qres (i, j) = 0; installation_parms.pct_qres (i, j) = 0; end; end; /* Following parameters added for MR8.0 */ if substr (installation_parms.rcp_init_flags.pad1, 1, 1) then /* old skip_validation bit */ installation_parms.rcp_init_flags.authentication_level = No_authentication; else if substr (installation_parms.rcp_init_flags.pad1, 2, 1) then /* old exact_authentication bit */ installation_parms.rcp_init_flags.authentication_level = Automatic_authentication; else installation_parms.rcp_init_flags.authentication_level = Nominal_authentication; installation_parms.rcp_init_flags.pad1 = ""b; /* zero obsolete bits */ if edit_rs then go to cant_comm_rs; installation_parms.default_absentee_queue = 3; /* for enter_abs_request, etc. */ installation_parms.chn_wakeup_error_loop_count = 10; /* to control Answering Service hacking */ installation_parms.chn_wakeup_error_loop_seconds = 3; /* ditto */ installation_parms.nrates = 0; /* only RS 0 (installation_parms) */ installation_parms.rate_structures (*) = ""; /* all RS names are blank */ installation_parms.rate_structures (0) = "default"; /* except the zero-th */ installation_parms.trusted_path_login = "0"b; installation_parms.require_operator_login = "0"b; installation_parms.vchn_requires_accept = "0"b; installation_parms.validate_daemon_commands = "0"b; installation_parms.operator_inactive_time = installation_parms.inactive_time; installation_parms.password_min_length = 0; /* none */ installation_parms.password_gpw_length = 6; /* compatibility */ installation_parms.password_change_interval = 0; /* none */ installation_parms.password_expiration_interval = 0; /* none */ call verify_structures; /* make a fast check */ go to main; cant_comm_rs: call ioa_ ("""^a"" is not allowed while editing a rate_structure.", comm); go to main1; %page; /* DEFAULT HANDLING for RATE-STRUCTURES */ default_rs: /* default for a rate_structure working installation_parms */ rsp = ip; go to copy_rs1; copy_rs: /* copy anywhere but into installation_parms */ if cur_rs_ptr = ip then do; call ioa_ ("A copy into the default rate structure is not allowed. Use default or change all."); go to main1; end; crs1a: call ask_ ("from^-", char32); /* what is user's desire? */ i = rstab$$defined (char32, COMPLAIN); /* is it feasible? */ if i < 0 then go to crs1a; /* 'fraid not */ rsp = rs_ptrs (i); /* pointer to it */ if rsp = cur_rs_ptr then do; /* how silly */ call ioa_ ("A copy from the same rate structure is not allowed."); call ask_$ask_clr (); go to crs1a; end; copy_rs1: /* copy all pricing info */ do i = 0 to 7; rate_structure.cpu_price (i) = rsp -> rate_structure.cpu_price (i); rate_structure.log_base_price (i) = rsp -> rate_structure.log_base_price (i); rate_structure.io_ops_price (i) = rsp -> rate_structure.io_ops_price (i); rate_structure.core_price (i) = rsp -> rate_structure.core_price (i); end; rate_structure.disk_price = rsp -> rate_structure.disk_price; rate_structure.registration_price = rsp -> rate_structure.registration_price; rate_structure.ndevices = rsp -> rate_structure.ndevices; rate_structure.devtab (*) = rsp -> rate_structure.devtab (*); rate_structure.abs_cpu_price (*) = rsp -> rate_structure.abs_cpu_price (*); rate_structure.abs_mem_price (*) = rsp -> rate_structure.abs_mem_price (*); rate_structure.iod_rec_price (*) = rsp -> rate_structure.iod_rec_price (*); rate_structure.nrscp = rsp -> rate_structure.nrscp; /* Keep resources in order and position. */ rate_structure.resource (*).name = rsp -> rate_structure.resource (*).name; rate_structure.resource (*).price = rsp -> rate_structure.resource (*).price; go to main; %page; /* OPERATION SUPERVISOR */ do_any: procedure (OP); dcl OP fixed bin; dcl IX fixed bin; dcl i fixed bin; dcl seq_ptr ptr; dcl seq_size fixed bin; dcl sequence (seq_size) fixed bin based (seq_ptr); /* This internal procedure calls the correct processor for OP */ worker: procedure (IX); /* dispatch */ /* keep everything pl1-quick */ dcl IX fixed bin; did_something = "1"b; /* assume the best */ suppress_nl = "0"b; /* ditto */ if OP = ADD then call do_add (IX); else if OP = CHANGE then call do_change (IX); else if OP = PRINT then call do_print (IX); else if OP = RETYPE then call do_retype (IX); return; end worker; /* BEGIN do_any */ if OP = ADD then do; /* get a nice long name for request */ print_comm = "add"; end; else if OP = CHANGE then do; print_comm = "change"; change_request = "1"b; /* this really is change, not retype */ end; else if OP = PRINT then do; print_comm = "print"; end; else if OP = RETYPE then do; print_comm = "retype"; end; else do; call com_err_ (0, me, "Internal error. Argument to ""do_any"" is ^d.", OP); return; end; call ask_ ("id ", char32); /* OP on what? */ keywx = checkid (char32, COMPLAIN); /* is it legit? */ if keywx < 0 then go to main1; /* something was wrong */ do_any_common: if keywx = 1 | keywx = 15 | keywx = 51 then do; /* ALL, ABS_QUEUE_PARAMETERS, RATES */ if keywx = 1 then do; /* all */ if edit_rs then go to do_rates; /* simulate 'rates ' */ all_rates_sw = "1"b; /* all => rates */ all_abs_queue_sw = "1"b; /* all => abs_queue_parameters */ all_sw = "1"b; /* indicate 'all' */ seq_ptr = addr (sequence_ALL); /* where is the sequence array? */ seq_size = hbound (sequence_ALL, 1); /* and how big? */ end; else if keywx = 15 then do; /* abs_queue_parameters */ all_abs_queue_sw = "1"b; /* indicate 'abs_queue_parameters' */ seq_ptr = addr (sequence_ABS_Q); /* pointer to sequence array */ seq_size = hbound (sequence_ABS_Q, 1); /* size thereof */ end; else if keywx = 51 then do; /* rates */ do_rates: all_rates_sw = "1"b; /* indicate all rates */ seq_ptr = addr (sequence_RATES); /* pointer to sequence array */ seq_size = hbound (sequence_RATES, 1); /* size thereof */ end; do i = 1 to seq_size; /* NOW, do each sub-request */ call worker (sequence (i)); /* appropriate processor for OP */ if ^suppress_nl & did_something then call ioa_ (""); /* blank line, if required */ end; end; else if keywx = 55 then do; all_structures_sw = "1"b; /* indicate 'all_structures' */ all_sw = "1"b; /* => all */ all_rates_sw = "1"b; /* => rates */ all_abs_queue_sw = "1"b; /* => abs_queue_parameters */ do i = 0 to installation_parms.nrates; /* now, for each rate_structure */ cur_rs_ptr = rs_ptrs (i); /* setup pointer ro RS */ edit_rs = (cur_rs_ptr ^= ip); /* flag if not IP */ call do_any$$given_index (OP, 1); /* 'all' for this rate_structure */ end; cur_rs_ptr = selected_rs_ptr; /* back to whatever it was */ edit_rs = (cur_rs_ptr ^= ip); end; else do; call worker (keywx); /* run-of-the-mill */ end; return; do_any$$given_index: entry (OP, IX); /* alternate entry - have index already */ keywx = IX; go to do_any_common; end do_any; %page; /* PROCESS SINGLE ADD REQUEST */ do_add: procedure (IX); dcl IX fixed bin; dcl (i, j) fixed bin; dcl devnm char (8); dcl rscnm char (32); if IX < lbound (add, 1) | IX > hbound (add, 1) then do; call com_err_ (0, me, "Internal error. do_add index ^d.", IX); return; end; go to add (IX); add (1): /* all */ add (2): /* installation_id */ add (3): /* shift_table */ add (4): /* prices */ add (5): /* titles */ add (6): /* level_names */ add (7): /* inactive_time */ add (8): /* warning_time */ add (9): /* login_time */ add (10): /* tries */ add (11): /* update_time */ add (14): /* queue_prices */ add (15): /* abs_queue_parameters */ add (16): /* category_names */ add (17): /* access_ceiling */ add (18): /* log_parameters */ add (19): /* trusted_path_login */ add (23): /* resource_wait_time */ add (24): /* fpe_time */ add (25): /* fpe_count */ add (26): /* trm_real_time */ add (27): /* trm_cpu_time */ add (28): /* unload_on_detach */ add (29): /* authentication_level */ add (30): /* default_pdir_seg_quota */ add (56): /* default_pdir_dir_quota */ add (31): /* rsc_mgmt_enabled */ add (32): /* auto_registration */ add (33): /* enable_ss_volume_mount */ add (34): /* foreground_queue_position */ add (35): /* idle_time_constant */ add (36): /* sus_cpu_time */ add (37): /* sus_real_time */ add (38): /* max_abs */ add (39): /* min_abs */ add (40): /* pct_abs */ add (41): /* max_qres */ add (42): /* min_qres */ add (43): /* pct_qres */ add (44): /* abs_cpu_max_limit */ add (45): /* abs_timax */ add (46): /* abs_cpu_default_limit */ add (47): /* foreground_cpu_default_limit */ add (48): /* abs_default_queue */ add (49): /* cwe_time */ add (50): /* cwe_count */ add (51): /* rates */ add (55): /* all_structures */ add (57): /* require_operator_login */ add (58): /* operator_inactive */ add (59): /* validate_daemon_commands */ add (60): /* password_min_length */ add (61): /* password_gpw_length */ add (62): /* password_change_interval */ add (63): /* password_expiration_interval */ add (64): /* vchn_requires_accept */ call ioa_ ("""add ^a"" is not allowed. Try ""retype"".", idt (keywx)); go to main1; add (12): /* device_prices */ go to add (52); add (13): /* config table */ if installation_parms.ncon = 51 then do; call ioa_ ("config table full"); call ask_$ask_clr (); return; end; i = installation_parms.ncon + 1; call input_config_element (i); if installation_parms.cona (i).cpu > 0 then installation_parms.ncon = i; call sort_config_table; return; add (20): /* device_names */ go to add (52); add (21): /* resource_prices */ add (22): /* resource_names */ go to add (53); add (52): /* devices */ if edit_rs then go to cant_add_rs; if installation_parms.ndevices = 16 then do; call ioa_ ("device table full"); call ask_$ask_clr (); return; end; add52a: call ask_ ("device^-", devnm); j = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN); /* best not exist */ if j >= 0 then go to add52a; /* oh dear, it does */ call input_device_price (installation_parms.ndevices + 1, devnm, ALL_RS, SET_HI); return; add (53): /* resources */ if edit_rs then go to cant_add_rs; call ask_ ("resource^-", rscnm); j = rsctab$$undefined (rscnm, COMPLAIN); /* best not exist */ if j >= 0 then go to add (53); /* horrors! it does */ call input_resource_price (installation_parms.nrscp + 1, rscnm, ALL_RS, SET_HI); return; add (54): /* rate_structure_name */ if edit_rs then go to cant_add_rs; if installation_parms.nrates >= hbound (installation_parms.rate_structures, 1) then do; call ioa_ ("An attempt to add more than ^n rate structures has been made and ignored.", hbound (installation_parms.rate_structures, 1)); go to main1; end; j = installation_parms.nrates + 1; add54a: call ask_ ("new rate_structure name ", rscnm); i = rstab$$undefined (rscnm, COMPLAIN); /* ensure no such RS already */ if i >= 0 then go to add54a; /* oh dear - try again */ en = "rate_structure_" || ltrim (char (j)); /* make the live segment */ call hcs_$make_seg (dn, en, "", RW_ACCESS_BIN, rsp1, ec); if rsp1 = null then do; call write_error (ec, j, dnvar || rtrim (en)); return; end; call hcs_$set_ring_brackets (dn, en, ip_rings, ec); /* make sure it's accessible to ring 5 */ if ec ^= 0 then call com_err_ (ec, me, "Setting ring brackets of ^a.", en); call hcs_$make_seg ("", "", "", RW_ACCESS_BIN, rsp, ec); /* make the temp copy */ if rsp = null then do; call write_error (ec, j, "temporary segment"); return; end; critical_op = "1"b; /* critical while we setup the RS */ rs_ptrs1 (j) = rsp1; rs_ptrs (j) = rsp; /* make new RS look like all the rest, with 0.0 prices */ rsp -> rate_structure.rate_structure_number = j; /* unique */ rsp -> rate_structure.rate_structures (*) = installation_parms.rate_structures (*); rsp -> rate_structure.cpu_price (*) = 0e0; rsp -> rate_structure.log_base_price (*) = 0e0; rsp -> rate_structure.io_ops_price (*) = 0e0; rsp -> rate_structure.core_price (*) = 0e0; rsp -> rate_structure.disk_price = 0e0; rsp -> rate_structure.registration_price = 0e0; rsp -> rate_structure.dolsign = "$"; rsp -> rate_structure.ndevices = installation_parms.ndevices; rsp -> rate_structure.devtab (*).device_id = installation_parms.devtab (*).device_id; rsp -> rate_structure.devtab (*).device_price (*) = 0e0; rsp -> rate_structure.abs_cpu_price (*) = 0e0; rsp -> rate_structure.abs_mem_price (*) = 0e0; rsp -> rate_structure.iod_rec_price (*) = 0e0; rsp -> rate_structure.nrscp = installation_parms.nrscp; rsp -> rate_structure.resource (*).name = installation_parms.resource (*).name; rsp -> rate_structure.resource (*).price = 0e0; do i = j to 0 by -1; /* add new rate_structure to all structures */ rs_ptrs (i) -> rate_structure.nrates = j; rs_ptrs (i) -> rate_structure.rate_structures (j) = rscnm; end; critical_op = "0"b; call ioa_ ("rate_structure ""^a"" defined. All prices are 0.0.", rscnm); return; cant_add_rs: call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX)); go to main1; end do_add; %page; /* PROCESS SINGLE CHANGE REQUEST */ do_change: procedure (IX); dcl IX fixed bin; dcl (i, i1, i2, i3, i4, j, k, n) fixed bin; dcl rscnm char (32); dcl devnm char (8); if IX < lbound (change, 1) | IX > hbound (change, 1) then do; call com_err_ (0, me, "Internal error. do_change index ^d.", IX); return; end; go to change (IX); change (2): /* installation_id */ change (5): /* titles */ change (7): /* inactive_time */ change (8): /* warning_time */ change (9): /* login_time */ change (10): /* tries */ change (11): /* update_time */ change (15): /* abs_queue_parameters */ change (17): /* access_ceiling */ change (18): /* log_parameters */ change (19): /* trusted_path_login */ change (23): /* rsctime */ change (24): /* fpetime */ change (25): /* fpecount */ change (26): /* trmrealtime */ change (27): /* trmcputime */ change (28): /* unload_on_detach */ change (29): /* authentication_level */ change (30): /* default_pdir_seg_quota */ change (56): /* default_pdir_dir_quota */ change (31): /* rsc_mgmt_enabled */ change (32): /* auto_registration */ change (33): /* enable_ss_volume_mount */ change (34): /* foreground_queue_position */ change (35): /* idle_time_constant */ change (36): /* sus_cpu_time */ change (37): /* sus_real_time */ change (38): /* max_abs */ change (39): /* min_abs */ change (40): /* pct_abs */ change (41): /* max_qres */ change (42): /* min_qres */ change (43): /* pct_qres */ change (44): /* abs_cpu_max_limit */ change (45): /* abs_timax */ change (46): /* abs_cpu_default_limits */ change (47): /* foreground_cpu_default_limit */ change (48): /* abs_default_queue */ change (49): /* cwe_time */ change (50): /* cwe_count */ change (51): /* rates */ change (57): /* require_operator_login */ change (58): /* operator_inactive */ change (59): /* validate_daemon_commands */ change (60): /* password_min_length */ change (61): /* password_gpw_length */ change (62): /* password_change_interval */ change (63): /* password_expiration_interval */ change (64): /* vchn_requires_accept */ call do_retype (IX); return; change (1): /* all */ go to cant_change; change (3): /* shift table */ call ask_ ("day^-", char8); i = index (daynam, substr (char8, 1, 3)) - 1; if i < 0 then do; badday: call ioa_ ("^a illegal day", char8); call ask_$ask_clr (); go to change (3); end; i = divide (i, 3, 17, 0); badhour: call set_half_al ("hour", "", j, 0, 23); badhalf: call ask_$ask_int ("half^-", n); if n = 30 then n = 1; else if n ^= 0 & n ^= 1 then do; call ioa_ ("illegal half hour ^d. Must be 0 for the hour and 1 or 30 for the half.", n); call ask_$ask_clr (); go to badhalf; end; call ask_$ask_n (char8, i1); /* check for type ahead */ if i1 ^= 0 & char8 = "thru" then do; /* if "thru" typed ahead */ call ask_ ("", char8); /* get it off the input line */ call ask_ ("thru day^-", char8); i2 = divide (index (daynam, substr (char8, 1, 3)) - 1, 3, 17, 0); if i2 < 0 then go to badday; call ask_$ask_int ("thru hour^-", i3); /* i3 = hour = final value of j */ if i3 < 0 | i3 > 23 then go to badhour; call ask_$ask_int ("thru half^-", i4); /* i4 = half = final value of n */ if i4 > 0 then i4 = 1; else i4 = 0; end; else i1 = 0; /* remember that thru was not given */ call set_half_al ("shift", "", k, 0, 7); call set_shift_field (i, j, k, n); if i1 ^= 0 then /* if "thru" was given */ do while (i ^= i2 | j ^= i3 | n ^= i4); /* set shifts til we reach the thru time */ n = n + 1; /* advance half hour */ if n = 2 then do; /* if next hour */ n = 0; j = j + 1; /* advance hour */ if j = 24 then do; /* if end of day */ j = 0; i = i + 1; /* advance day */ if i = 7 then /* if end of week */ i = 0; end; end; call set_shift_field (i, j, k, n); end; return; change (4): /* prices */ call set_half_al ("shift", "", k, 0, 7); call ask_$ask_flo ("cpu^-", rate_structure.cpu_price (k)); call ask_$ask_flo ("log^-", rate_structure.log_base_price (k)); call ask_$ask_flo ("mem^-", rate_structure.core_price (k)); call ask_$ask_flo ("io ops^-", rate_structure.io_ops_price (k)); return; change (6): /* sensitivity level names */ call set_half_al ("level", "", i, lbound (installation_parms.level_names, 1), hbound (installation_parms.level_names, 1)); call enter_level_name (i); return; change (12): /* device prices */ call ask_ ("device^-", devnm); i = devtab$$defined (devnm, SPECIAL_DEVICES_OK, COMPLAIN); /* find that device */ if i < 0 then go to change (12); /* I beg your pardon */ call input_device_price (i, devnm, THIS_RS, NO_SET_HI); return; change (13): /* config table */ do while ("1"b); call ask_$ask_int ("ncpu ", i1); call ask_$ask_int ("nmem ", i2); call ask_$ask_int ("bulk ", i3); call ask_$ask_int ("shift ", i4); do i = 1 to installation_parms.ncon; if installation_parms.cona.cpu (i) = i1 then if installation_parms.cona.kmem (i) = i2 then if installation_parms.cona.kbulk (i) = i3 then if installation_parms.cona.shift (i) = i4 then do; call print_config_element (i); call input_config_element (i); call sort_config_table; return; end; end; call ioa_ ("config ^d ^d ^d ^d not found", i1, i2, i3, i4); call ask_$ask_clr (); end; change (14): /* queue prices */ call set_half_al ("queue", "", i, 1, 4); call ask_$ask_flo ("abs CPU ^d^-", rate_structure.abs_cpu_price (i), i); call ask_$ask_flo ("abs mem ^d^-", rate_structure.abs_mem_price (i), i); call ask_$ask_flo ("iod records ^d^-", rate_structure.iod_rec_price (i), i); return; change (16): /* category names */ call set_half_al ("category", "", i, lbound (installation_parms.category_names, 1), hbound (installation_parms.category_names, 1)); call enter_category_name (i); return; change (20): /* device name */ if edit_rs then go to cant_change_rs; call ask_ ("device^-", devnm); i = devtab$$defined (devnm, NO_SPECIAL_DEVICES, COMPLAIN); /* find it in devtab */ if i < 0 then go to change (20); /* couldn't find it */ ch20a: call ask_ ("new device name^-", devnm); if devnm = installation_parms.device_id (i) then do; k = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN); /* new name must not exist */ if k >= 0 then go to ch20a; /* try again */ end; k = installation_parms.ndevices; if devnm = "dev" || ltrim (char (i)) & i = k then k = k - 1; critical_op = "1"b; do j = installation_parms.nrates to 0 by -1; /* All rate structures must have the same devices */ rs_ptrs (j) -> rate_structure.ndevices = k; rs_ptrs (j) -> rate_structure.device_id (i) = devnm; end; critical_op = "0"b; return; change (21): /* resource_prices */ call ask_ ("resource^-", rscnm); i = rsctab$$defined (rscnm, COMPLAIN); /* find resource */ if i < 0 then go to change (21); /* couldn't */ call input_resource_price (i, rscnm, THIS_RS, NO_SET_HI); return; change (22): /* rscname */ if edit_rs then go to cant_change_rs; call ask_ ("resource^-", rscnm); i = rsctab$$defined (rscnm, COMPLAIN); /* find resource */ if i < 0 then go to change (22); /* not present */ call ask_ ("new resource name^-", rscnm); ch22a: if rscnm ^= installation_parms.resource (i).name then do; j = rsctab$$undefined (rscnm, COMPLAIN); /* look out for duplicates */ if j >= 0 then go to ch22a; /* try for another name */ end; critical_op = "1"b; do j = installation_parms.nrates to 0 by -1; rs_ptrs (j) -> rate_structure.resource (i).name = rscnm; end; critical_op = "0"b; return; change (52): /* devices */ go to change (12); change (53): /* resources */ go to change (21); change (54): /* rate_structure_name */ if edit_rs then go to cant_change_rs; call ask_ ("rate_structure^-", rscnm); i = rstab$$defined (rscnm, COMPLAIN); /* find the RS */ if i < 0 then go to change (54); /* doesn't exist */ ch54a: call ask_ ("new rate_structure name^-", rscnm); if rscnm ^= installation_parms.rate_structures (i) then do; j = rstab$$undefined (rscnm, COMPLAIN); /* look out for duplicate names */ if j >= 0 then go to ch54a; /* oh dear - found duplicate */ end; critical_op = "1"b; do j = installation_parms.nrates to 0 by -1; rs_ptrs (j) -> rate_structure.rate_structures (i) = rscnm; end; critical_op = "0"b; return; change (55): /* all_structures */ go to cant_change; changed_nothing: did_something = "0"b; return; cant_change: call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX)); go to main1; cant_change_rs: call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX)); go to main1; end do_change; %page; /* PROCESS SINGLE PRINT REQUEST */ do_print: procedure (IX); dcl IX fixed bin; dcl (i, j, k, m, n) fixed bin; dcl c15 char (15); dcl char48 char (48); dcl no_charge bit (1) aligned; dcl (dflt, mx, tmx) bit (1) aligned; dcl rscnm char (32); dcl devnm char (8); dcl pass_sw bit (1) aligned; if IX < lbound (print, 1) | IX > hbound (print, 1) then do; call com_err_ (0, me, "Internal error. do_print index ^d.", IX); return; end; go to print (IX); print (1): /* all */ call ioa_ ("^/^-Installation parameters^/"); return; print (2): /* installation_id */ call ioa_ ("Installation id:^-^a", installation_parms.installation_id); return; print (3): /* shift_table */ call ioa_ ("^4xM^15x8^7xN^11x6"); do i = 0 to 6; char48 = ""; m = 1; do j = 0 to 23; do n = 0 to 1; k = fixed (installation_parms.shifttab (48 * i + 2 * j + n + 1), 3); substr (char48, m, 1) = ltrim (char (k)); m = m + 1; end; end; call ioa_ ("^a ^a", substr (daynam, 3 * i + 1, 3), char48); end; return; print (4): /* prices */ call ioa_ ("disk price:^-$^f/page-second, $^f/page-30-days", rate_structure.disk_price, rate_structure.disk_price * SECONDS_PER_MONTH); call ioa_ ("registration fee:^-^a/user^/", cv_$mwvf (rate_structure.registration_price)); call ioa_ ("Shift^13xcpu^13xlog^13xmem^10xio ops"); do i = 0 to 7; if rate_structure.cpu_price (i) + rate_structure.log_base_price (i) + rate_structure.io_ops_price (i) + rate_structure.core_price (i) > 0.0e0 then call ioa_ ("^4x^1d ^15a ^15a ^15a ^15a", i, cv_$mwvf (rate_structure.cpu_price (i)), cv_$mwvf (rate_structure.log_base_price (i)), cv_$mwvf (rate_structure.core_price (i)), cv_$mwvf (rate_structure.io_ops_price (i))); end; return; print (5): /* titles */ call ioa_ ("Company:^-^-^a", installation_parms.company); call ioa_ ("Department:^-^a", installation_parms.department); call ioa_ ("Companyds:^-^a", installation_parms.companyds); call ioa_ ("Departmentds:^-^a", installation_parms.departmentds); return; print (6): /* level_names */ call ioa_ ("Level Short Name Name"); do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1); call ioa_ ("^3d^6x^8a^6x^a", i, installation_parms.short_level_names (i), installation_parms.level_names (i)); end; return; print (7): /* inactive_time */ call ioa_ ("inactive_time:^-^d sec.", installation_parms.inactive_time); suppress_nl = "1"b; /* tight output */ return; print (58): call ioa_ ("operator_inactive_time:^-^d sec.", installation_parms.operator_inactive_time); suppress_nl = "1"b; /* tight output */ return; print (8): /* warning_time */ call ioa_ ("warning_time:^-^d sec.", installation_parms.warning_time); suppress_nl = "1"b; /* tight output */ return; print (9): /* login_time */ call ioa_ ("login_time:^-^d sec.", installation_parms.login_time); suppress_nl = "1"b; /* tight output */ return; print (10): /* tries */ call ioa_ ("tries:^2-^d", installation_parms.login_tries); suppress_nl = "1"b; return; print (11): /* update_time */ call ioa_ ("acct_update:^-^d sec.", installation_parms.acct_update); return; print (12): /* device_prices */ go to print (52); /* devices */ print (13): /* config_table */ call ioa_ (" cpu mem bulk shift min max base abs absq"); do i = 1 to installation_parms.ncon; call print_config_element (i); end; return; print (14): /* queue_prices */ call ioa_ ("Queue Abs CPU Abs mem IO recs"); do i = 1 to 4; call ioa_ (" ^1d ^8.2f ^8.2f ^8.2f", i, rate_structure.abs_cpu_price (i), rate_structure.abs_mem_price (i), rate_structure.iod_rec_price (i)); end; return; print (15): /* abs_queue_parameters */ tmx, dflt, mx = "1"b; /* print all 3 parameters */ go to print_abs_queue_parameters; print (16): /* category_names */ call ioa_ ("Category Short Name Name"); do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1); call ioa_ ("^3d^6x^8a^6x^a", i, installation_parms.short_category_names (i), installation_parms.category_names (i)); end; return; print (17): /* access_ceiling */ call ioa_ ("Access ceiling:^-level = ^d, categories = ^6.3b", /* N.B. Format depends on number of categories */ addr (installation_parms.access_authorization_ceiling) -> aim_template.level, addr (installation_parms.access_authorization_ceiling) -> aim_template.categories); return; print (18): /* log_parameters */ if installation_parms.syserr_log_copy_threshold = -1 then call ioa_ ("Syserr log copying disabled."); else if installation_parms.syserr_log_copy_threshold = 0 then call ioa_ ("Syserr log copying threshold is using default value."); else call ioa_ ("Syserr log copying threshold: ^d pages", installation_parms.syserr_log_copy_threshold); return; print (19): /* trusted_path_login */ call ioa_ ("trusted_path_login: ^[yes^;no^]. Terminal disconnection is^[ not^] required to change authorization.", installation_parms.trusted_path_login, ^installation_parms.trusted_path_login); return; print (57): call ioa_ ("require_operator_login: ^[yes^;no^]. Operators are^[ not^] required to sign on before entering commands.", installation_parms.require_operator_login, ^installation_parms.require_operator_login); return; print (59): call ioa_ ("validate_daemon_commands: ^[yes^;no^]. Access to .mcacs segments is^[ not^] required to reply, quit, login, logout, or new_proc daemons.", installation_parms.validate_daemon_commands, ^installation_parms.validate_daemon_commands); return; print (60): call ioa_ ("password_min_length: ^[no minimum length^s^;^d^].", (installation_parms.password_min_length = 0), installation_parms.password_min_length); return; print (61): call ioa_ ("password_gpw_length: ^d.", installation_parms.password_gpw_length); return; print (62): call ioa_ ("password_change_interval: ^[no enforced interval^s^;^d days^].", (installation_parms.password_change_interval = 0), installation_parms.password_change_interval); return; print (63): call ioa_ ("password_expiration_interval: ^[no enforced interval^s^;^d days^].", (installation_parms.password_expiration_interval = 0), installation_parms.password_expiration_interval); return; print (64): call ioa_ ("vchn_requires_accept: ^[yes^;no^]. virtual channel MC attachments do^[ not^] require ""accept""", installation_parms.vchn_requires_accept, ^installation_parms.vchn_requires_accept); return; print (20): /* devname */ if all_rates_sw then go to printed_nothing; /* device_prices will do it */ do i = 1 to rate_structure.ndevices; call ioa_ ("^2d)^2x^8a", i, rate_structure.device_id (i)); end; return; print (21): /* resource_prices */ go to print (53); /* resources */ print (22): /* rscname */ if all_rates_sw then go to printed_nothing; /* resource_prices will do it */ pass_sw = "1"b; do i = 1 to rate_structure.nrscp; if rate_structure.resource (i).price >= 0 then do; pass_sw = "0"b; call ioa_ ("^3d)^2x^a", i, rate_structure.resource (i).name); end; end; if pass_sw then call ioa_ ("no resources defined"); return; print (23): /* rsctime */ call ioa_ ("resource wait time: ^d sec.", installation_parms.rsc_timer_seconds); return; print (24): /* fpetime */ call ioa_ ("fatal error loop time: ^d sec.", installation_parms.fatal_error_loop_seconds); return; print (25): /* fpecount */ call ioa_ ("fatal error loop count: ^d", installation_parms.fatal_error_loop_count); return; print (26): /* trmrealtime */ call ioa_ ("trm_ real time limit: ^d sec.", installation_parms.term_real_time_seconds); return; print (27): /* trmcputime */ call ioa_ ("trm_ cpu time limit: ^d sec.", installation_parms.term_cpu_time_seconds); return; print (28): /* unload_on_detach */ call ioa_ ("^a:^-^[on^;off^]", idt (28), installation_parms.rcp_init_flags.unload_on_detach); return; print (29): /* authentication_level */ call ioa_ ("^a:^-^a", idt (29), authentication_level_names (installation_parms.rcp_init_flags.authentication_level)); return; print (30): /* default_pdir_seg_quota */ call ioa_ ("^a:^-^d", idt (30), installation_parms.default_pdir_seg_quota); return; print (56): /* default_pdir_dir_quota */ call ioa_ ("^a:^-^d", idt (56), installation_parms.default_pdir_dir_quota); return; print (31): /* rsc_mgmt_enabled */ call ioa_ ("^a:^-^[on^;off^]", idt (31), installation_parms.rcp_init_flags.resource_mgmt_enabled); return; print (32): /* auto_registration */ call ioa_ ("^a:^-^[on^;off^]", idt (32), installation_parms.rcp_init_flags.auto_registration); return; print (33): /* enable_ss_volume_mount */ /* COMMENT OUT UNTIL rcp_init_flags.incl.pl1 is modified: call ioa_ ("^a:^-^[on^;off^],idt(33),installation_parms.rcp_init_flags.enable_ss_volume_mount); /* END COMMENT OUT */ go to printed_nothing; print (34): /* foreground_queue_position */ call print_halfword (idt (34), installation_parms.foreground_queue_position); return; print (35): /* idle_time_constant */ call print_halfword (idt (35), installation_parms.idle_time_constant_seconds); return; print (36): /* sus_cpu_time */ call ioa_ ("^a: ^d sec.", idt (36), installation_parms.sus_cpu_time_seconds); return; print (37): /* sus_real_time */ call ioa_ ("^a: ^d sec.", idt (37), installation_parms.sus_real_time_seconds); return; print (38): /* max_abs */ call print_sval (idt (38), installation_parms.max_abs); return; print (39): /* min_abs */ call print_sval (idt (39), installation_parms.min_abs); return; print (40): /* pct_abs */ call print_sval (idt (40), installation_parms.pct_abs); return; print (41): /* max_qres */ call print_sqval (idt (41), installation_parms.max_qres); return; print (42): /* min_qres */ call print_sqval (idt (42), installation_parms.min_qres); return; print (43): /* abs_cpu_default_limit */ call print_sqval (idt (43), installation_parms.pct_qres); return; print (44): /* abs_cpu_max_limit */ if all_abs_queue_sw then go to printed_nothing; mx = "1"b; tmx, dflt = ""b; go to print_abs_queue_parameters; print (45): /* abs_timax */ if all_abs_queue_sw then go to printed_nothing; tmx = "1"b; mx, dflt = ""b; go to print_abs_queue_parameters; print (46): /* abs_cpu_default_limit */ if all_abs_queue_sw then go to printed_nothing; dflt = "1"b; mx, tmx = ""b; go to print_abs_queue_parameters; print_abs_queue_parameters: /* Print lines of the following form: Q TIMAX DEFAULT PER-SHIFT MAX CPU TIME LIMITS - LIMIT 0 1 2 3 4 5 6 7 1 timax dflt mx0 mx1 mx2 mx3 mx4 mx5 mx6 mx7 */ call ioa_ ("Q^[^xABS-TIMAX^]^[^xDEFAULT^]^[^xPER-SHIFT MAX CPU TIME LIMITS^]", tmx, dflt, mx); if (dflt | mx) then call ioa_ ("^x^[^10x^]^[^3xLIMIT^]^[^x^6x0^6x1^6x2^6x3^6x4^6x5^6x6^6x7^]", tmx, dflt, mx); do i = 1 to 4; call ioa_ ("^d^[^x^9d^;^s^]^[^x^7d^;^s^]^[^x^8(^x^6d^)^]", i, tmx, installation_parms.abs_timax (i), dflt, installation_parms.abs_cpu_default_limit (i), mx, installation_parms.abs_cpu_max_limit (*, i)); end; return; print (47): /* foreground_cpu_default_limit */ call ioa_ ("foreground default cpu limit: ^d sec.", installation_parms.foreground_cpu_default_limit); return; print (48): /* abs_default_queue */ call print_halfword (idt (48), installation_parms.default_absentee_queue); return; print (49): /* cwe_time */ call ioa_ ("^a:^21t^d sec.", idt (49), installation_parms.chn_wakeup_error_loop_seconds); suppress_nl = "1"b; /* tight output */ return; print (50): /* cwe_count */ call ioa_ ("^a:^21t^d", idt (50), installation_parms.chn_wakeup_error_loop_count); suppress_nl = "1"b; /* tight output */ return; print (51): /* rates */ call ioa_ ("^/^-rate_structure ""^a""^/", ptr_rs_name (cur_rs_ptr)); return; print (52): /* devices */ k = 0; if ^all_rates_sw then call ask_$ask_n (devnm, k); /* look ahead on line for device name */ if k ^= 0 then do; /* if something is there */ m, n = devtab$$defined (devnm, SPECIAL_DEVICES_OK, COMPLAIN); /* find the device */ if m < 0 then go to print (52); /* sorry, chum */ call ask_ ("", char8); /* clear it off the input line */ end; else do; if ^check_device_names () then /* check for missing ones, and if we complained about any */ call ioa_ (""); /* skip a line */ m = 1; n = installation_parms.ndevices; end; do i = m to n; call ioa_ ("device:^-^a", rate_structure.device_id (i)); no_charge = "1"b; /* check for zero prices on all shifts */ do j = 0 to 7; if rate_structure.device_price (i, j) > 0.0e0 then do; call ioa_ ("^-shift ^d ^15a/hr", j, cv_$mwvf (rate_structure.device_price (i, j))); no_charge = ""b; /* at least one shift has nonzero price */ end; end; if no_charge then call ioa_ ("^2-^7xno charge"); end; return; print (53): /* resources */ k = 0; if ^all_rates_sw then call ask_$ask_n (rscnm, k); /* look ahead for a resource name */ if k ^= 0 then do; /* if something is there */ j, k = rsctab$$defined (rscnm, COMPLAIN); /* find the resource */ if j < 0 then go to print (53); call ask_ ("", char32); /* it was; remove it from the input line */ end; else do; j = 1; /* print them all */ k = rate_structure.nrscp; end; pass_sw = "1"b; do i = j to k; if rate_structure.resource (i).price >= 0 then do; c15 = cv_$mwvf (rate_structure.resource (i).price); /* format price */ if length (ltrim (c15)) < 8 then c15 = substr (c15, 8, 8); /* right-adjust price in 8 column field */ else c15 = ltrim (c15); /* but don't throw away any nonblanks */ if pass_sw then do; pass_sw = "0"b; call ioa_ ("^3xPRICE^xNAME"); end; call ioa_ ("^8a^x^a", c15, rate_structure.resource (i).name); end; end; if pass_sw then call ioa_ ("no resources defined"); return; print (54): /* rate_structure_name */ call ioa_ ("Rate_structure names:"); do i = 0 to installation_parms.nrates; call ioa_ ("^-^a ^[ (current rate_structure)^]", installation_parms.rate_structures (i), (cur_rs_ptr = rs_ptrs (i))); end; return; print (55): /* all_structures */ go to printed_nothing; printed_nothing: did_something = "0"b; return; cant_print: call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX)); go to main1; cant_print_rs: call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX)); go to main1; end do_print; %page; /* PROCESS SINGLE RETYPE REQUEST */ do_retype: procedure (IX); dcl IX fixed bin; dcl (i, j, k, n) fixed bin; dcl c1 char (1); dcl category_set bit (36) aligned; dcl rscnm char (32); dcl devnm char (8); dcl yn char (4); if IX < lbound (retype, 1) | IX > hbound (retype, 1) then do; call com_err_ (0, me, "Internal error. do_retype index ^d.", IX); return; end; go to retype (IX); retype (1): /* all */ call ioa_ ("^/Retype installation_parms"); return; retype (2): /* installation_id */ call ask_$ask_line ("Installation id^-", installation_parms.installation_id); return; retype (3): /* shift_table */ call ask_ ("standard shifts?^-", c1); if c1 = "y" then do; call set_std_shifttab; end; else do; call ioa_ ("Each digit specifies the shift for that half-hour. Shifts may be 0-7"); do i = 0 to 6; do j = 0 to 23; do n = 0 to 1; badshf: call ask_$ask_int ("^a ^2d^2d^-", k, substr (daynam, i * 3 + 1, 3), j, 30 * n); if k > 7 | k < 0 then do; call ioa_ ("Shifts must be 0-7"); call ask_$ask_clr (); go to badshf; end; call set_shift_field (i, j, k, n); end; end; end; end; return; retype (4): /* prices */ call get_disk_price (rate_structure.disk_price); call ask_$ask_flo ("registration^-", rate_structure.registration_price); call ask_$ask_yn ("Do you want to retype CPU, log, mem and io ops prices^-", yn); if yn ^= "yes" then return; call ioa_ ("Input CPU, log, mem, io ops prices for each shift from 0 to 7"); do i = 0 to 7; call ask_$ask_flo ("CPU ^d^-", rate_structure.cpu_price (i), i); call ask_$ask_flo ("log ^d^-", rate_structure.log_base_price (i), i); call ask_$ask_flo ("mem ^d^-", rate_structure.core_price (i), i); call ask_$ask_flo ("io ops ^d^-", rate_structure.io_ops_price (i), i); end; return; retype (5): /* titles */ call ask_$ask_line ("company^-^-", installation_parms.company); call ask_$ask_line ("department^-", installation_parms.department); call ask_$ask_line ("company (ds)^-", installation_parms.companyds); call ask_$ask_line ("department (ds)^-", installation_parms.departmentds); return; retype (6): /* level_names */ call ioa_ ("Enter names for ^d security levels.", dimension (installation_parms.level_names (*), 1)); do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1); call enter_level_name (i); end; return; retype (7): /* inactive_time */ call set_half_al (idt (7), "seconds", installation_parms.inactive_time, 0, NOLIMIT); return; retype (58): /* inactive_time */ call set_half_al (idt (58), "seconds", installation_parms.operator_inactive_time, 0, NOLIMIT); return; retype (8): /* warning_time */ call set_half_al (idt (8), "seconds", installation_parms.warning_time, 0, NOLIMIT); return; retype (9): /* login_time */ call set_half_al (idt (9), "seconds", installation_parms.login_time, 0, NOLIMIT); return; retype (10): /* tries */ call set_half_al (idt (10), "", installation_parms.login_tries, 1, NOLIMIT); return; retype (11): /* update_time */ call set_half_al ("acct update", "seconds", installation_parms.acct_update, 0, NOLIMIT); return; retype (12): /* device_prices */ call ioa_ ("Enter device prices for all shifts"); do i = 1 to rate_structure.ndevices; call input_device_price (i, (installation_parms.devtab (i).device_id), THIS_RS, NO_SET_HI); end; return; retype (13): /* config_table */ call ioa_ ("Enter config table"); do i = 1 to hbound (installation_parms.cona, 1); call input_config_element (i); installation_parms.ncon = i - 1; if installation_parms.cona.cpu (i) = 0 then do; call check_config_table; return; end; end; call ioa_ ("config table full"); call ask_$ask_clr (); return; retype (14): /* queue_prices */ call ioa_ ("Enter queue prices"); do i = 1 to 4; call ask_$ask_flo ("abs CPU ^d^-", rate_structure.abs_cpu_price (i), i); call ask_$ask_flo ("abs mem ^d^-", rate_structure.abs_mem_price (i), i); call ask_$ask_flo ("iod records ^d^-", rate_structure.iod_rec_price (i), i); end; return; retype (15): /* abs_queue_parameters */ call ioa_ ("Enter abs timax (microseconds) and default and max limits (seconds) for queues 1-4"); return; retype (16): /* category_names */ call ioa_ ("Enter names for ^d security categories.", dimension (installation_parms.category_names (*), 1)); do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1); call enter_category_name (i); end; return; retype (17): /* access_ceiling */ call set_half_al ("Maximum sensitivity level", "", i, lbound (installation_parms.level_names, 1), hbound (installation_parms.level_names, 1)); retype_category_set: category_set = ""b; n = divide (dimension (installation_parms.category_names (*), 1), 3, 17, 0); call ask_$ask_line ("Categories in use: (^d octal digits) ", char48, n); if verify (substr (char48, 1, n), "01234567") ^= 0 then do; call ioa_ ("Must be ^d octal digits. Retype it.", n); call ask_$ask_clr (); go to retype_category_set; end; do j = 1 to n; substr (category_set, 3 * j - 2, 3) = bit (fixed (index ("01234567", substr (char48, j, 1)) - 1, 3), 3); end; addr (installation_parms.access_authorization_ceiling) -> aim_template.level = i; addr (installation_parms.access_authorization_ceiling) -> aim_template.categories = category_set; string (addr (installation_parms.access_authorization_ceiling) -> aim_template.privileges) = ""b; return; retype (18): /* log_parameters */ call ask_$ask_int ("syserr log copying threshold:^-", i); if i > 256 | i < -1 then do; call ioa_ ("Threshold must be: -1 (disable log copying)^/^20x0 (use built-in default)"); call ioa_ ("^16x1-256 (max size of log in pages before copying begins)^/Please retype."); call ask_$ask_clr (); go to retype (18); end; installation_parms.syserr_log_copy_threshold = i; return; retype (19): /* strict_trusted_path */ call ask_$ask_yn ("trusted path login:^-", yn); installation_parms.trusted_path_login = (yn = "yes"); return; retype (57): /* require_operator_login */ call ask_$ask_yn ("require operator login:^-", yn); installation_parms.require_operator_login = (yn = "yes"); return; retype (59): /* validate_daemon_commands */ call ask_$ask_yn ("validate daemon commands:^-", yn); installation_parms.validate_daemon_commands = (yn = "yes"); return; retype (60): /* password_min_length */ call set_half_al (idt (60), "", installation_parms.password_min_length, 0, 8); return; retype (61): /* password_gpw_length */ call set_half_al (idt (61), "", installation_parms.password_gpw_length, 1, 8); return; retype (62): /* password_change_interval */ call ask_$ask_int ("Password Change Interval (in days):^-", i); if i < 0 then do; call ioa_ ("Password Change Interval must be greater than zero."); goto retype (62); end; installation_parms.password_change_interval = i; return; retype (63): /* password_expiration_interval */ call ask_$ask_int ("Password Expiration Interval (in days):^-", i); if i < 0 then do; call ioa_ ("Password Expiration Interval must be greater than zero."); goto retype (62); end; installation_parms.password_expiration_interval = i; return; retype (64): call ask_$ask_yn ("vchn_requires_accept:^-", yn); installation_parms.vchn_requires_accept = (yn = "yes"); return; retype (20): /* devname */ go to cant_retype_must_change; retype (21): /* resource_prices */ call ioa_ ("Enter resource prices"); do i = 1 to rate_structure.nrscp; if rate_structure.resource (i).price >= 0e0 then /* not a rate structure */ call input_resource_price (i, (installation_parms.resource (i).name), THIS_RS, NO_SET_HI); end; return; retype (22): /* rscname */ go to cant_retype_must_change; retype (23): /* resource_wait_time */ call set_halfword ("resource wait time", "seconds", installation_parms.rsc_timer_seconds, 0, NOLIMIT); return; retype (24): /* fpe_time */ call set_halfword ("fatal process error loop time", "seconds", installation_parms.fatal_error_loop_seconds, 0, NOLIMIT); return; retype (25): /* fpe_count */ call set_halfword ("fatal process error loop count", "", installation_parms.fatal_error_loop_count, 0, NOLIMIT); return; retype (26): /* trm_real_time */ call set_halfword ("trm_ real time limit", "seconds", installation_parms.term_real_time_seconds, 0, NOLIMIT); return; retype (27): /* trm_cpu_time */ call set_halfword ("trm_ cpu time limit", "seconds", installation_parms.term_cpu_time_seconds, 0, NOLIMIT); return; retype (28): /* unload_on_detach */ installation_parms.rcp_init_flags.unload_on_detach = ask_on_off (idt (keywx)); return; retype (29): /* authentication_level */ installation_parms.rcp_init_flags.authentication_level = enter_authentication_level (); return; retype (30): /* default_pdir_seg_quota */ call set_halfword ("default pdir segment quota", "records", installation_parms.default_pdir_seg_quota, 100, NOLIMIT); return; retype (56): /* default_pdir_dir_quota */ call set_halfword ("default pdir directory quota", "records", installation_parms.default_pdir_dir_quota, 100, NOLIMIT); return; retype (31): /* rsc_mgmt_enabled */ installation_parms.rcp_init_flags.resource_mgmt_enabled = ask_on_off (idt (31)); return; retype (32): /* auto_registration */ installation_parms.rcp_init_flags.auto_registration = ask_on_off (idt (32)); return; retype (33): /* enable_ss_volume_mount */ go to retyped_nothing; retype (34): /* foreground_queue_position */ call set_halfword (idt (34), "", installation_parms.foreground_queue_position, 0, 4); return; retype (35): /* idle_time_constant */ call set_halfword (idt (35), "seconds", installation_parms.idle_time_constant_seconds, 60, 1800); return; retype (36): /* sus_cpu_time */ call set_halfword (idt (36), "seconds", installation_parms.sus_cpu_time_seconds, 1, NOLIMIT); return; retype (37): /* sus_real_time */ call set_halfword (idt (37), "seconds", installation_parms.sus_real_time_seconds, 30, NOLIMIT); return; retype (38): /* max_abs */ call set_sval (idt (38), installation_parms.max_abs, -1, NOLIMIT); return; retype (39): /* min_abs */ call set_sval (idt (39), installation_parms.min_abs, 0, NOLIMIT); return; retype (40): /* pct_abs */ call set_sval (idt (40), installation_parms.pct_abs, 0, 100); return; retype (41): /* max_qres */ call set_sqval (idt (41), installation_parms.max_qres, 0, NOLIMIT); return; retype (42): /* min_qres */ call set_sqval (idt (42), installation_parms.min_qres, 0, NOLIMIT); return; retype (43): /* pct_qres */ call set_sqval (idt (43), installation_parms.pct_qres, 0, 100); return; retype (44): /* abs_cpu_max_limit */ call set_sqlval (idt (44), installation_parms.abs_cpu_max_limit, 0, NOLIMIT); call check_abs_cpu_limit; return; retype (45): /* abs_timax */ call set_qval (idt (45), installation_parms.abs_timax, 1000000, NOLIMIT); return; retype (46): /* abs_cpu_default_limit */ call set_qval (idt (46), installation_parms.abs_cpu_default_limit, 0, NOLIMIT); call check_abs_cpu_limit; return; retype (47): /* foregound_cpu_default_limit */ call set_word (idt (47), "seconds", installation_parms.foreground_cpu_default_limit, 0, NOLIMIT); return; retype (48): /* abs_default_queue */ call set_halfword (idt (48), "", installation_parms.default_absentee_queue, 1, 4); return; retype (49): /* cwe_time */ call set_halfword ("channel wakeup error loop time", "seconds", installation_parms.chn_wakeup_error_loop_seconds, 0, NOLIMIT); return; retype (50): /* cwe_count */ call set_halfword ("channel wakeup error loop count", "", installation_parms.chn_wakeup_error_loop_count, 0, NOLIMIT); return; retype (51): /* rates */ call ioa_ ("^/Retype rate_structure ^a", ptr_rs_name (cur_rs_ptr)); return; retype (52): /* devices */ if edit_rs then go to cant_retype_rs; call ioa_ ("Warning: this operation changes the positions of devices in device table;"); call ioa_ ("it should only be done in a special session just after billing has been run."); call ask_$ask_yn ("Do you wish to proceed? ", char8); if char8 ^= "yes" then go to main1; call ioa_ ("Enter device prices."); do i = 1 to hbound (installation_parms.devtab, 1); if i <= hbound (dev_id, 1) then devnm = dev_id (i); else do; deviclp: call ask_ ("Enter device id or ""x"" to exit^-", devnm); if devnm = "x" then return; j = devtab$$undefined (devnm, NO_SPECIAL_DEVICES, COMPLAIN); /* unique device name? */ if j >= 0 then go to deviclp; /* no - try again */ end; call input_device_price (i, devnm, ALL_RS, SET_HI); end; call ioa_ ("Device table full"); call ask_$ask_clr (); return; retype (53): /* resources */ if edit_rs then go to cant_retype_rs; call ioa_ ("Warning: retyping the resource price list might make other system tables invalid."); call ask_$ask_yn ("Do you want to retype the resource price list?^-", char8); if char8 = "no" then return; call ioa_ ("Enter resource names and prices, or ""x"" to exit."); i = 0; rt53a: call ask_ ("resource:^-", rscnm); if rscnm = "x" then return; j = rsctab$$undefined (rscnm, COMPLAIN); /* unique resource name */ if j < 0 then do; /* nope */ i = i + 1; call input_resource_price (i, rscnm, ALL_RS, SET_HI); end; go to rt53a; retype (54): /* rate_structure_name */ go to cant_retype_must_change; retype (55): /* all_structures */ if edit_rs then go to cant_retype_rs; go to retyped_nothing; retyped_nothing: did_something = "0"b; return; cant_retype_must_change: call ioa_ ("cannot retype ^a; use change", idt (keywx)); go to main1; cant_retype: call ioa_ ("""^a ^a"" is not allowed.", print_comm, idt (IX)); go to main1; cant_retype_rs: call ioa_ ("""^a ^a"" is not allowed while editing a rate_structure.", print_comm, idt (IX)); go to main1; end do_retype; %page; /* ------------------------------ */ ask_on_off: procedure (name) returns (bit (1) aligned); dcl name char (*); call ask_ ("^a:^-", char8, name); do while ("1"b); if char8 = "yes" | char8 = "on" then return ("1"b); else if char8 = "no" | char8 = "off" then return (""b); else do; call ask_$ask_clr (); call ask_ ("Please answer ""yes"", ""no"", ""on"", or ""off""; ^a: ^x", char8, name); end; end; end ask_on_off; /* ------------------------------ */ check_abs_cpu_limit: /* make sure each default is OK */ procedure; dcl (qok, qbad) (4) bit (1) aligned init ((4) (1)""b); dcl nbad fixed bin init (0); dcl (s, q) fixed bin; do q = 1 to 4; do s = 0 to 7; if installation_parms.abs_cpu_default_limit (q) <= installation_parms.abs_cpu_max_limit (s, q) then qok (q) = "1"b; end; if ^qok (q) then do; qbad (q) = "1"b; nbad = nbad + 1; end; end; if nbad > 0 then do; call ioa_ ("Warning: the default limit is higher than the max limit"); call ioa_ ("on all shifts, for queue^[s^]^[^x1^]^[^x2^]^[^x3^]^[^x4^].", (nbad > 1), qbad); call ioa_ ("If you don't change one of them, jobs using the default will never log in."); end; return; end check_abs_cpu_limit; /* ------------------------------ */ check_device_names: procedure returns (bit (1) aligned); dcl (i, j) fixed bin; do i = 1 to hbound (dev_id, 1); /* for each required device name */ do j = 1 to rate_structure.ndevices while (dev_id (i) ^= rate_structure.device_id (j)); end; if j > rate_structure.ndevices then call ioa_ ("Warning: device ""^a"" not in device table. It should be added.", dev_id (i)); end; return ("0"b); end check_device_names; /* ------------------------------ */ checkid: procedure (xid, loud_sw) returns (fixed bin (17)); dcl xid char (*); dcl loud_sw bit (1) aligned; dcl ib fixed bin; dcl i fixed bin; dcl keywx fixed bin; do ib = 1 to hbound (keyw, 1); if xid = keyw (ib) then do; keywx = keyn (ib); /* key number */ if edit_rs then do; /* not valid for rate_structures? */ do i = 1 to hbound (valid_for_rs, 1) while (valid_for_rs (i) < keywx); end; if valid_for_rs (i) > keywx then do; if loud_sw then do; call ioa_ ("The identifier ""^a"" is not valid while editing a rate_structure.", idt (keywx)); call ask_$ask_clr (); end; return (NOT_RS_ID); end; end; return (keywx); end; end; if loud_sw then do; call ioa_ ("illegal change id ""^a"". Type help for instructions.", xid); call ask_$ask_clr (); end; return (ID_NOT_FOUND); end checkid; /* ------------------------------ */ check_config_table: procedure; dcl (this_ord, highest_ord) fixed bin (71); dcl i fixed bin; dcl (bad_dup, bad_null, bad_order) bit (1) aligned; bad_dup, bad_null, bad_order = ""b; highest_ord = -2; do i = 1 to installation_parms.ncon; this_ord = gen_config_ordinal ((installation_parms.cona (i).cpu), (installation_parms.cona (i).kmem), (installation_parms.cona (i).kbulk), (installation_parms.cona (i).shift)); if this_ord = -1 then bad_null = "1"b; else if this_ord < highest_ord then bad_order = "1"b; else if this_ord = highest_ord then bad_dup = "1"b; else highest_ord = this_ord; end; if bad_dup | bad_null | bad_order then do; call ioa_ ("Config table error(s).^[ Duplicate entires.^]^[ Null entries.^]^[ Entries out of order.^]", bad_dup, bad_null, bad_order); call sort_config_table; end; end check_config_table; /* ------------------------------ */ clean_up: procedure; dcl i fixed bin; if ip = null then return; /* no segments active */ do i = hbound (rs_ptrs, 1) to 0 by -1; /* do installation_parms & copy last */ if rs_ptrs (i) ^= null then do; /* working copy? */ call hcs_$delentry_seg (rs_ptrs (i), ec); /* delete it */ rs_ptrs (i) = null; /* remember it's gone */ end; if rs_ptrs1 (i) ^= null then do; /* real segment? */ call terminate_file_ (rs_ptrs1 (i), (0), TERM_FILE_TERM, ec); /* get rid of it */ rs_ptrs1 (i) = null; /* forget it */ end; end; end clean_up; /* ------------------------------ */ devtab$$defined: /* search devtab */ procedure (devnm, any_sw, loud_sw) returns (fixed bin); dcl devnm char (*); dcl any_sw bit (1) aligned; dcl loud_sw bit (1) aligned; dcl i fixed bin; dcl j fixed bin; dcl should_find bit (1) aligned; should_find = "1"b; /* we WANT to find it */ go to devtab_common; devtab$$undefined: /* search devtab */ entry (devnm, any_sw, loud_sw) returns (fixed bin (17)); should_find = "0"b; /* don't want to find it */ devtab_common: do i = 1 to installation_parms.ndevices; /* whole devtab */ if installation_parms.devtab (i).device_id = devnm then do; /* what we're checking for? */ if should_find then /* did we want to find it? */ if any_sw ^= SPECIAL_DEVICES_OK then do; /* have to check for special */ do j = 1 to hbound (dev_id, 1); /* see if special name */ if devnm = dev_id (j) then do; /* yes, it's special */ if loud_sw then do; /* complain? */ call ioa_ ("""^a"" is a reserved device name.", devnm); call ask_$ask_clr (); /* clean up */ end; return (-1); /* indicate we're unhappy */ end; /* found a special name */ end; /* loop to check for special */ end; /* have to check for special */ if ^should_find & loud_sw then do; /* shouldn't have found it */ call ioa_ ("Device ""^a"" is already defined.", devnm); call ask_$ask_clr (); end; return (i); end; end; if should_find & loud_sw then do; /* should have found it, but we didn't */ call ioa_ ("Device ""^a"" is not defined.", devnm); call ask_$ask_clr (); end; return (-1); end devtab$$defined; /* ------------------------------ */ enter_authentication_level: procedure returns (fixed bin); dcl i fixed bin, ans char (32); get_again: call ask_$ask_line ("Authentication level: ", ans); do i = lbound (authentication_level_names, 1) to hbound (authentication_level_names, 1); if (authentication_level_names (i) = ans) then return (i); end; call ioa_ ("Authentication level must be ^v(^a, ^) or ^a. Reenter level.", dim (authentication_level_names, 1) - 1, authentication_level_names (*)); call ask_$ask_clr (); go to get_again; end enter_authentication_level; /* ------------------------------ */ enter_category_name: procedure (i); dcl i fixed bin; dcl name char (32); dcl short_name char (8); installation_parms.category_names (i) = ""; /* null out so invalid_name doesn't find a duplicate. */ installation_parms.short_category_names (i) = ""; change_this_name: call ask_$ask_line ("Category ^d: ", name, i); if name = "." then do; reenter_name: call ioa_ ("No categories may be unnamed. Reenter name."); call ask_$ask_clr (); go to change_this_name; end; call ask_$ask_line (" (short name) Category ^d: ", short_name, i); if short_name = "." then go to reenter_name; if invalid_name (name, length (installation_parms.category_names (1)), "1"b) then go to change_this_name; if invalid_name (short_name, length (installation_parms.short_category_names (1)), "0"b) then go to change_this_name; installation_parms.category_names (i) = name; installation_parms.short_category_names (i) = short_name; end enter_category_name; /* ------------------------------ */ enter_level_name: procedure (i); dcl i fixed bin; dcl name char (32); dcl short_name char (8); installation_parms.level_names (i) = ""; /* null out so invalid_name doesn't find a duplicate. */ installation_parms.short_level_names (i) = ""; change_this_name: call ask_$ask_line ("Level ^d: ", name, i); if name = "." then if i = 0 then name = ""; else do; reenter_name: call ioa_ ("Only level 0 may be unnamed. Reenter name."); call ask_$ask_clr (); go to change_this_name; end; call ask_$ask_line (" (short name) Level ^d: ", short_name, i); if short_name = "." then if i = 0 then short_name = ""; else go to reenter_name; if invalid_name (name, length (installation_parms.level_names (0)), "1"b) then go to change_this_name; if invalid_name (short_name, length (installation_parms.short_level_names (0)), "0"b) then go to change_this_name; installation_parms.level_names (i) = name; installation_parms.short_level_names (i) = short_name; return; end enter_level_name; /* ------------------------------ */ gen_config_ordinal: /* make a number which describes NCPU, NMEM, NBULK and SHIFT */ /* of a config-table entry */ procedure (ncpu, nmem, nbulk, shift) returns (fixed bin (71)); dcl (ncpu, nmem, nbulk, shift) fixed bin; if ncpu < 0 | nmem < 0 | nbulk < 0 | shift < 0 then /* something naughty? */ return (-1); else return ((((ncpu * 100000 + nmem) * 100000) + nbulk) * 10 + shift); end gen_config_ordinal; /* ------------------------------ */ get_disk_price: procedure (price); dcl price float bin (27); dcl char32 char (32); dcl f float bin (27); dcl i fixed bin; call ask_$ask_n (char32, i); if i = 0 then /* no typeahead */ call ioa_ ("enter disk price as 'N' (page-second) or 'N/month' (page-30-days)"); do while ("1"b); /* keep going until user gets it right */ call ask_ ("disk price^-", char32); if index (char32, "/mo") ^= 0 then do; /* per-30-day month */ call cv_float_ (rtrim (before (char32, "/mo")), ec, f); if ec = 0 then do; price = f / SECONDS_PER_MONTH; /* units are page-seconds */ return; end; end; else do; /* per second */ call cv_float_ (rtrim (char32), ec, f); if ec = 0 then do; price = f; return; end; end; call ask_$ask_clr (); /* error in floating point number */ end; end get_disk_price; /* ------------------------------ */ get_nums: procedure (prompt, n1, n2); dcl prompt char (*); dcl (n1, n2) fixed bin; dcl ia fixed bin; ask_for_nums: call ask_ ("^a", char32, prompt); if verify (rtrim (char32), "0123456789-") ^= 0 then do; bad_nums: call ask_$ask_clr (); call ioa_ ("""^a"" invalid. Give one number or two joined by a hyphen.", char32); go to ask_for_nums; end; ia = index (char32, "-"); if ia = 0 then n1, n2 = cv_dec_ (char32); /* we already checked */ else do; if ia = 1 /* if leading hyphen */ | substr (char32, ia + 1) = "" /* or trailing hyphen */ | index (substr (char32, ia + 1), "-") ^= 0 /* or more than one hyphen */ then go to bad_nums; /* go complain */ n1 = cv_dec_ ((substr (char32, 1, ia - 1))); n2 = cv_dec_ ((substr (char32, ia + 1))); end; return; end get_nums; /* ------------------------------ */ get_shift_queue: procedure (q_lo, q_hi, s_lo, s_hi); /* Checks for typed-ahead shift and queue numbers; returns first and last shift in s_lo and s_hi; s_lo = -1 if no shift typed ahead; same for q_lo and q_hi for queues. */ dcl (q_lo, q_hi, s_lo, s_hi) fixed bin; dcl (get_shift, get_queue) bit (1) aligned init (""b); dcl x fixed bin; /* Main entry point - get both shift and queue */ get_shift, get_queue = "1"b; s_lo, q_lo = -1; /* we haven't gotten either one, yet */ gsq_common: /* come here from get_shift or get_queue */ call ask_$ask_n (char32, x); if x = 0 then return; /* if nothing typed ahead */ if get_shift & char32 = "shift" then do; call ask_ ("", char32); /* clear it from the line */ call get_nums ("shift(s)", s_lo, s_hi); /* get "s" or "s1-s2" */ get_shift = ""b; /* we have gotten it */ end; else if get_queue & char32 = "queue" then do; call ask_ ("", char32); call get_nums ("queue(s)", q_lo, q_hi); get_queue = ""b; end; else return; /* if we wanted both, go back for the other one */ if get_shift | get_queue then go to gsq_common; return; get_shift: entry (s_lo, s_hi); s_lo = -1; get_shift = "1"b; go to gsq_common; get_queue: entry (q_lo, q_hi); q_lo = -1; get_queue = "1"b; go to gsq_common; end get_shift_queue; /* ------------------------------ */ idt: procedure (n) returns (char (32)); /* returns primary keyword, given key number */ dcl n fixed bin; dcl ia fixed bin; do ia = 1 to hbound (keyn, 1); if keyn (ia) = n then return (keyw (ia)); end; call com_err_ (0, me, "Internal error in ""idt"" function."); return ("UNKNOWN!"); end idt; /* ------------------------------ */ input_config_element: procedure (i); dcl i fixed bin; dcl j fixed bin; dcl ftmp float bin; call set_half_al ("ncpu", "", j, -1, 8); installation_parms.cona.cpu (i) = j; if j <= 0 then return; call set_half_al ("mem", "Kwords", j, 0, NOLIMIT); installation_parms.cona.kmem (i) = j; call set_half_al ("bulk", "Kwords", j, 0, NOLIMIT); installation_parms.cona.kbulk (i) = j; call set_half_al ("shift", "", j, 0, 7); installation_parms.cona.shift (i) = j; call ask_$ask_flo ("min ", ftmp); installation_parms.cona.response_low (i) = ftmp * 1e1; call ask_$ask_flo ("max ", ftmp); installation_parms.cona.response_high (i) = ftmp * 1e1; call ask_$ask_flo ("base ", ftmp); installation_parms.cona.maxu_base (i) = ftmp * 1e1; call set_half_al ("absu", "", j, 0, NOLIMIT); installation_parms.cona.maxa (i) = j; call set_half_al ("absq", "", j, 1, 4); installation_parms.cona.maxq (i) = j; installation_parms.cona.x1 (i) = 0; installation_parms.cona.x2 (i) = 0; installation_parms.cona.x3 (i) = 0; end input_config_element; /* ------------------------------ */ input_device_price: procedure (devx, devnm, all_sw, set_hi); dcl devx fixed bin; dcl devnm char (*); dcl all_sw bit (1) aligned; dcl set_hi bit (1) aligned; dcl rsp ptr; dcl i fixed bin; dcl s fixed bin; dcl (hi, lo) fixed bin; dcl save_crit bit (1) aligned; /* maybe allow copy or zero? */ save_crit = critical_op; critical_op = critical_op | (all_sw = ALL_RS); if all_sw = ALL_RS then do; /* one, or all RS? */ hi = installation_parms.nrates; lo = 0; end; else hi, lo = rate_structure.rate_structure_number; do i = lo to hi; /* run the gamut */ rsp = rs_ptrs (i); /* which RS now? */ if all_sw = ALL_RS & installation_parms.nrates > 0 then /* tell user which one, if more than one */ call ioa_ ("rate_structure ""^a""", ptr_rs_name (rsp)); rsp -> rate_structure.device_id (devx) = devnm; do s = 0 to 7; /* get price for each shift */ call ask_$ask_flo ("^a shift ^d^-", rsp -> rate_structure.device_price (devx, s), devnm, s); end; end; if set_hi = SET_HI then /* do installation_parms last */ do i = hi to lo by -1; /* set number of devices */ rs_ptrs (i) -> rate_structure.ndevices = devx; end; critical_op = save_crit; /* restore old critical indicator */ end input_device_price; /* ------------------------------ */ input_resource_price: procedure (rscx, rscnm, all_sw, set_hi); dcl rscx fixed bin; dcl rscnm char (*); dcl all_sw bit (1) aligned; dcl set_hi bit (1) aligned; dcl f float bin (27); dcl i fixed bin; dcl rsp ptr; dcl (hi, lo) fixed bin; dcl save_crit bit (1) aligned; save_crit = critical_op; critical_op = critical_op | (all_sw = ALL_RS); if all_sw = ALL_RS then do; /* which RS? */ hi = installation_parms.nrates; lo = 0; end; else hi, lo = rate_structure.rate_structure_number; do i = lo to hi; /* for each appropriate RS */ rsp = rs_ptrs (i); /* point to RS */ if all_sw = ALL_RS & installation_parms.nrates > 0 then /* more than one - tell user which */ call ioa_ ("rate_structure ""^a""", ptr_rs_name (rsp)); call ask_$ask_flo ("Price of ^a:^-", f, rscnm); /* price, please */ rsp -> rate_structure.resource (rscx).price = f; rsp -> rate_structure.resource (rscx).name = rscnm; end; if set_hi then /* do installation_parms last */ do i = hi to lo by -1; /* set number of resources */ rs_ptrs (i) -> rate_structure.nrscp = rscx; end; critical_op = save_crit; /* restore saved indicator */ return; end input_resource_price; /* ------------------------------ */ invalid_name: /* check level and category names for duplicates, valid chars, etc. */ procedure (bv_name, bv_max_len, blank_ok) returns (bit (1) aligned); /* parameters */ declare bv_name char (*); declare bv_max_len fixed bin; declare blank_ok bit (1) aligned; /* automatic */ declare i fixed bin; /* program */ if bv_name = "" then return ("0"b); /* null names are always ok */ if bv_name = "system_low" | bv_name = "system_high" then do; call ioa_ ("The keyword ^a is not allowed as a level or category name. Reenter both names.", bv_name); go to invalid; end; i = length (bv_name) - verify (reverse (bv_name), " ") + 1; if i > bv_max_len then do; call ioa_ ("Name ^a is longer than allowed maximum of ^d characters. Reenter both names.", bv_name, bv_max_len); go to invalid; end; if verify (substr (bv_name, 1, i), " '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`abcdefghijklmnopqrstuvwxyz~") ^= 0 then do; call ioa_ ("Name ^a contains illegal character (s). Reenter both names.", bv_name); go to invalid; end; if blank_ok then ; else if index (substr (bv_name, 1, i), " ") ^= 0 then do; call ioa_ ("Short level and category names may not contain embedded blanks. Reenter both names."); call ask_$ask_clr (); return ("1"b); end; do i = lbound (installation_parms.level_names (*), 1) to hbound (installation_parms.level_names (*), 1); if installation_parms.level_names (i) = bv_name then go to found_duplicate; end; do i = lbound (installation_parms.category_names (*), 1) to hbound (installation_parms.category_names (*), 1); if installation_parms.category_names (i) = bv_name then go to found_duplicate; end; do i = lbound (installation_parms.short_level_names (*), 1) to hbound (installation_parms.short_level_names (*), 1); if installation_parms.short_level_names (i) = bv_name then go to found_duplicate; end; do i = lbound (installation_parms.short_category_names (*), 1) to hbound (installation_parms.short_category_names (*), 1); if installation_parms.short_category_names (i) = bv_name then go to found_duplicate; end; return ("0"b); found_duplicate: call ioa_ ("Name ^a is already in use. Reenter both names.", bv_name); invalid: call ask_$ask_clr (); return ("1"b); end invalid_name; /* ------------------------------ */ out_of_range: /* NOLIMIT should check hw/word limit */ procedure (prompt, v, v_lo, v_hi) returns (bit (1) aligned); dcl v fixed bin (35); dcl (v_hi, v_lo) fixed bin (35); dcl prompt char (*); dcl dummy char (1); dcl flag fixed bin; dcl (error, error_lo, error_hi) bit (1) aligned init (""b); if v_lo ^= NOLIMIT then if v < v_lo then error, error_lo = "1"b; if v_hi ^= NOLIMIT then if v > v_hi then error, error_hi = "1"b; if error then do; /* value is out of range */ call ask_$ask_n (dummy, flag); /* see if anything else was typed ahead */ call ask_$ask_clr (); /* clear anything that was typed ahead */ call ioa_ ("ERROR: value of ^a (^d) may not be^[ below ^d^;^s^]^[ or^]^[ above ^d^;^s^].", prompt, v, (error_lo), v_lo, (error_lo & error_hi), (error_hi), v_hi); call ioa_ ("Please retype it^[^x(and everything that followed it)^].", (flag > 0)); return ("1"b); end; return (""b); /* value is ok */ end out_of_range; /* ------------------------------ */ print_config_element: procedure (i); dcl i fixed bin; call ioa_ ("^5d ^5d ^5d ^5d ^7.1f ^7.1f ^7.1f ^5d ^5d", installation_parms.cona.cpu (i), installation_parms.cona.kmem (i), installation_parms.cona.kbulk (i), installation_parms.cona.shift (i), installation_parms.cona.response_low (i) * 1e-1, installation_parms.cona.response_high (i) * 1e-1, installation_parms.cona.maxu_base (i) * 1e-1, installation_parms.cona.maxa (i), installation_parms.cona.maxq (i)); end print_config_element; /* ------------------------------ */ print_halfword: procedure (name, v); dcl name char (*); dcl v fixed bin (17) unaligned; call ioa_ ("^a:^x^d", name, v); return; end print_halfword; /* ------------------------------ */ print_sval: procedure (name, sarray); dcl name char (*); dcl sarray (0:7) fixed bin (17) unaligned; dcl nq fixed bin; dcl i fixed bin; dcl arrayp ptr; dcl array (0:7, nq) fixed bin (17) unaligned based (arrayp); nq = 1; arrayp = addr (sarray); print_sval_common: call ioa_ ("^a - PER ^[QUEUE AND^x^]SHIFT", name, (nq = 4)); call ioa_ ("^[Q^x^]^5x0^6x1^6x2^6x3^6x4^6x5^6x6^6x7", (nq = 4)); do i = 1 to nq; call ioa_ ("^[^d^x^;^s^]^8(^6d^x^)", (nq = 4), i, array (*, i)); end; return; print_sqval: entry (name, sqarray); dcl sqarray (0:7, 4) fixed bin (17) unaligned; nq = 4; arrayp = addr (sqarray); go to print_sval_common; end print_sval; /* ------------------------------ */ ptr_rs_name: /* get name of RS, given pointer to temp seg */ procedure (rsp) returns (char (32)); dcl rsp ptr; dcl i fixed bin; do i = 0 to installation_parms.nrates; if rsp = rs_ptrs (i) then return (installation_parms.rate_structures (i)); end; call com_err_ (0, me, "Internal error in ""ptr_rs_name""."); return ("UNKNOWN!"); /* OOG! */ end ptr_rs_name; /* ------------------------------ */ rstab$$defined: /* search rate_structure name table */ /* just like devtab$$= */ procedure (rsnm, loud_sw) returns (fixed bin); dcl rsnm char (*); dcl loud_sw bit (1) aligned; dcl i fixed bin; dcl should_find bit (1) aligned; should_find = "1"b; go to rstab_common; rstab$$undefined: entry (rsnm, loud_sw) returns (fixed bin (17)); should_find = "0"b; rstab_common: do i = 0 to installation_parms.nrates; if installation_parms.rate_structures (i) = rsnm | rsnm = "." then do; if ^should_find & loud_sw then do; call ioa_ ("rate_structure ""^a"" is already defined.", rsnm); call ask_$ask_clr (); end; return (i); end; end; if should_find & loud_sw then do; call ioa_ ("rate_structure ""^a"" is not defined.", rsnm); call ask_$ask_clr (); end; return (-1); end rstab$$defined; /* ------------------------------ */ rsctab$$defined: /* search resource table. */ /* just like devtab$$= */ procedure (rscnm, loud_sw) returns (fixed bin); dcl rscnm char (*); dcl loud_sw bit (1) aligned; dcl i fixed bin; dcl should_find bit (1) aligned; should_find = "1"b; go to rsctab_common; rsctab$$undefined: entry (rscnm, loud_sw) returns (fixed bin (17)); should_find = "0"b; rsctab_common: do i = 0 to installation_parms.nrscp; if installation_parms.resource (i).name = rscnm then do; if ^should_find & loud_sw then do; call ioa_ ("resource ""^a"" is already defined.", rscnm); call ask_$ask_clr (); end; return (i); end; end; if should_find & loud_sw then do; call ioa_ ("resource ""^a"" is not defined.", rscnm); call ask_$ask_clr (); end; return (-1); end rsctab$$defined; /* ------------------------------ */ set_halfword: procedure (prompt, units, v17unal, v_lo, v_hi); /* to set fixed bin (17) unaligned scalars */ dcl prompt char (*); dcl units char (*); dcl v17unal fixed bin (17) unaligned; dcl v17al fixed bin (17) aligned; dcl v35al fixed bin (35) aligned; dcl v fixed bin (35); dcl (v_hi, v_lo) fixed bin (35); dcl long_sw bit (1) aligned; dcl aligned_sw bit (1) aligned; long_sw = "0"b; aligned_sw = "0"b; go to set_join; set_half_al: entry (prompt, units, v17al, v_lo, v_hi); long_sw = "0"b; aligned_sw = "1"b; go to set_join; set_word: entry (prompt, units, v35al, v_lo, v_hi); aligned_sw = "1"b; long_sw = "1"b; go to set_join; set_join: do while ("1"b); call ask_$ask_int ("^a^[^x(^a)^;^s^]:^x", v, prompt, (units ^= ""), units); if ^out_of_range (prompt, v, v_lo, v_hi) then do; if long_sw then v35al = v; else if aligned_sw then v17al = v; else v17unal = v; return; end; end; end set_halfword; /* ------------------------------ */ /* Internal procedure to set per-queue, per-shift, and per-queue-and-shift parameters */ set_qval: procedure (prompt, qarray, v_lo, v_hi); /* to set per-queue parameters 45 and 46 */ dcl prompt char (*); dcl qarray (4) fixed bin (35); dcl (v_lo, v_hi) fixed bin (35); dcl (set_shift, set_queue) bit (1) aligned init (""b); dcl esw fixed bin; dcl prompted bit (1) aligned init (""b); dcl (q, nq, s, ns) fixed bin; dcl v fixed bin (35); dcl (qx, q_ext, sx, s_ext) fixed bin; dcl ask_again bit (1) aligned; dcl (q_lo, q_hi, s_lo, s_hi) fixed bin; esw = 1; /* remember which entry point we came in at */ set_queue = "1"b; /* and what we are supposed to do */ go to set_common; set_sval: entry (prompt, sarray, v_lo, v_hi); /* to set parameters 38, 39, and 40 */ dcl sarray (0:7) fixed bin (17) unaligned; esw = 2; /* remember which entry point we came in at */ set_shift = "1"b; /* and what we are supposed to do */ go to set_common; set_sqval: entry (prompt, sqarray, v_lo, v_hi); /* to set parameters 41 thru 43 */ dcl sqarray (0:7, 4) fixed bin (17) unaligned; esw = 3; /* remember which entry point we came in at */ set_shift, set_queue = "1"b; /* and what we are supposed to do */ go to set_common; set_sqlval: entry (prompt, sqlarray, v_lo, v_hi); /* for parameter 44 */ dcl sqlarray (0:7, 4) fixed bin (35); esw = 4; /* remember which entry point we came in at */ set_shift, set_queue = "1"b; /* and what we are supposed to do */ go to set_common; set_common: ns, nq = 1; /* go around shift and queue loops at least once each */ /* See if any shift or queue numbers were typed ahead */ if esw = 1 then call get_queue (q_lo, q_hi); else if esw = 2 then call get_shift (s_lo, s_hi); else call get_shift_queue (q_lo, q_hi, s_lo, s_hi); /* Check on what was typed ahead, and fill in defaults in the absence of typeahead */ if set_queue then do; /* if setting a per-queue or per-shift-and-queue parameter */ if q_lo = -1 then do; /* if queue not typed ahead */ if change_request then do; /* default for change is to ask for, and set, a single queue */ ask_again = "1"b; do while (ask_again); call ask_$ask_int ("queue:^x", q_lo); /* ask for it */ ask_again = out_of_range ("queue", (q_lo), 1, 4); end; q_hi = q_lo; /* q_hi=q_lo means set value for only one queue */ end; else do; /* default for retype is set all queues */ nq = 4; /* ask for 4 values */ q_lo = 1; /* for queues 1 */ q_hi = 4; /* thru 4 */ end; end; if nq = 1 then /* if we will ask for only one per-queue value */ q_ext = q_hi - q_lo; /* set this many extra elements to that value */ else q_ext = 0; /* otherwise, set only one element per value typed in */ end; /* end setting per-queue parameter */ if set_shift then do; /* if setting a per-shift or per-shift-and-queue parameter */ if s_lo = -1 then do; /* if shift not typed ahead */ if change_request then do; /* default for change is a single shift */ ask_again = "1"b; do while (ask_again); call ask_$ask_int ("shift:^x", s_lo); /* ask for it */ ask_again = out_of_range ("shift", (s_lo), 0, 7); end; s_hi = s_lo; /* one shift */ end; else do; /* default for retype is all shifts */ ns = 8; /* so ask for 8 values */ s_lo = 0; /* for shifts 0 */ s_hi = 7; /* thru 7 */ end; end; if ns = 1 then /* if we will ask for only one per-shift value */ s_ext = s_hi - s_lo; /* set this many extra elements to that value */ else s_ext = 0; /* otherwise, set only one element per value typed in */ end; /* end setting per-shift value */ /* Now, ask for, and store, the value(s) */ /* Outer loop on queue. If not setting per-queue, or per-shift-and-queue parameter, go around this loop just once, to get to the inner loop */ do q = q_lo to q_lo + nq - 1; /* Inner loop on shift. If not setting per-shift or per-shift-and-queue parameter, go thru this loop just once for each time around the outer loop */ do s = s_lo to s_lo + ns - 1; /* This is what we're here for */ ask_again = "1"b; do while (ask_again); call ask_$ask_int ( "^[^s^;^a:^x^]^[queue^[s ^d-^d^; ^d^s^]:^x^;^3s^]^[shift^[s ^d-^d^; ^d^s^]:^x^;^3s^]", v, /* the value to be typed in */ prompted, prompt, /* print the prompting word only once (first time around) */ (set_queue & s = s_lo), (q_ext > 0), q, q_hi, /* if setting per-queue parm, print 1 or 2 queue numbers */ (set_shift), (s_ext > 0), s, s_hi); /* if setting per-shift parm, print 1 or 2 shift #s */ ask_again = out_of_range (prompt, v, v_lo, v_hi); end; prompted = "1"b; /* remember not to print prompting word again */ /* Now store the value into one or more array elements */ if esw = 1 then do qx = 0 to q_ext; qarray (q + qx) = v; end; else if esw = 2 then do sx = 0 to s_ext; sarray (s + sx) = v; end; else do qx = 0 to q_ext; do sx = 0 to s_ext; if esw = 3 then sqarray (s + sx, q + qx) = v; else if esw = 4 then sqlarray (s + sx, q + qx) = v; end; end; end; /* end inner loop on shift */ end; /* end outer loop on queue */ return; end set_qval; /* ------------------------------ */ set_shift_field: procedure (i, j, k, n); dcl (i, j, k, n) fixed bin; installation_parms.shifttab (48 * i + (2 * j + n) + 1) = bit (fixed (k, 3), 3); return; end set_shift_field; /* ------------------------------ */ set_std_shifttab: procedure; dcl (i, j) fixed bin; do i = 0 to 6; do j = 0 to 15; installation_parms.shifttab (48 * i + j + 1) = "011"b; end; do j = 16 to 35; installation_parms.shifttab (48 * i + j + 1) = "001"b; end; do j = 36 to 47; installation_parms.shifttab (48 * i + j + 1) = "010"b; end; end; do i = 5 to 6; do j = 16 to 47; installation_parms.shifttab (48 * i + j + 1) = "100"b; end; end; end set_std_shifttab; /* ------------------------------ */ sort_config_table: procedure; dcl i fixed bin; dcl o1 fixed bin (71); dcl o2 fixed bin (71); dcl changed bit (1) aligned; dcl ever_changed bit (1) aligned; dcl save_crit bit (1) aligned; dcl ncon fixed bin; dcl 1 tcona like installation_parms_part_1.cona aligned; changed = "1"b; ever_changed = "0"b; save_crit = critical_op; critical_op = critical_op | (all_sw = ALL_RS); ncon = installation_parms.ncon; /* number of config table elements */ do while (changed & ncon > 1); /* keep going until we drop */ changed = "0"b; do i = 1 repeat i + 1 while (i < ncon); o1 = gen_config_ordinal ((installation_parms.cona (i).cpu), (installation_parms.cona (i).kmem), /* get a number describing this element */ (installation_parms.cona (i).kbulk), (installation_parms.cona (i).shift)); o2 = gen_config_ordinal ((installation_parms.cona (i + 1).cpu), /* and one for this element */ (installation_parms.cona (i + 1).kmem), (installation_parms.cona (i + 1).kbulk), (installation_parms.cona (i + 1).shift)); if o1 < 0 | installation_parms.cona (i).cpu <= 0 then do; /* should we dump this one? */ installation_parms.cona (i) = installation_parms.cona (ncon); ncon = ncon - 1; changed = "1"b; end; else if o2 < 0 | installation_parms.cona (i + 1).cpu <= 0 then do; /* dump this one (only one at a time, please)? */ installation_parms.cona (i + 1) = installation_parms.cona (ncon); ncon = ncon - 1; changed = "1"b; end; else if o1 > o2 then do; /* out of order? */ tcona = installation_parms.cona (i); /* fiddle about */ installation_parms.cona (i) = installation_parms.cona (i + 1); installation_parms.cona (i + 1) = tcona; changed = "1"b; end; ever_changed = ever_changed | changed; end; end; if ever_changed then do; /* tell user if we changed anything */ call ioa_ ("Config table sorted."); installation_parms.ncon = ncon; end; critical_op = save_crit; /* back to where we were */ end sort_config_table; /* ------------------------------ */ verify_structures: procedure; dcl (i, j) fixed bin; dcl rsn fixed bin; dcl force bit (1) aligned; dcl char8 char (8); dcl phoo bit (1) aligned; dcl rsname char (32); call ask_$ask_n (char8, i); force = (i > 0 & (char8 = "-force" | char8 = "-fc" | char8 = "force" | char8 = "fc")); if force then call ask_ ("", char8); /* remove it from line */ do rsn = 0 to installation_parms.nrates; /* for all rate-structures */ cur_rs_ptr = rs_ptrs (rsn); rsname = installation_parms.rate_structures (rsn); /* check device tables against installation_parms */ if rate_structure.ndevices ^= installation_parms.ndevices then do; /* first, check the counts */ call ioa_ ("installation_parms has ^d devices, rate_structure ""^a"" has ^d", installation_parms.ndevices, rsname, rate_structure.ndevices); if force then do; call ioa_ ("Forcing change."); rate_structure.ndevices = installation_parms.ndevices; end; end; do j = 1 to installation_parms.ndevices; /* now check all the names */ if installation_parms.device_id (j) ^= rate_structure.device_id (j) then do; call ioa_ ( "installation_parms has device ""^a"" at position ^d.^/rate_structure ""^a"" has device ""^a""." , installation_parms.device_id (j), j, rsname, rate_structure.device_id (j)); if force then do; call ioa_ ("Forcing change, price set to 0.0"); rate_structure.device_id (j) = installation_parms.device_id (j); rate_structure.device_price (j, *) = 0e0; end; end; end; /* check resources */ if installation_parms.nrscp ^= rate_structure.nrscp then do; /* first check the counts */ call ioa_ ( "installation_parms has ^d resource array entries, rate_structure ""^a"" has ^d.^[ Forcing change^]" , installation_parms.nrscp, rsname, rate_structure.nrscp, force); if force then rate_structure.nrscp = installation_parms.nrscp; end; do i = 1 to installation_parms.nrscp; /* then check the names */ if installation_parms.resource (i).name ^= rate_structure.resource (i).name then do; call ioa_ ( "installation_parms has resource ^a as entry ^d, the rate_structure resource is ""^a"".", installation_parms.resource (i).name, i, rate_structure.resource (i).name); if force then do; call ioa_ ("Forcing change, price set to 0.0"); rate_structure.resource (i).name = installation_parms.resource (i).name; rate_structure.resource (i).price = 0e0; end; end; end; /* then check all the rate_structure name stuff */ if rate_structure.rate_structure_number ^= rsn then do; /* do I point to myself? */ call ioa_ ("rate_structure ^d (^a) has incorrect rate_structure_number field ^d. ^[Forcing change^]", rsn, installation_parms.rate_structures (rsn), rate_structure.rate_structure_number, force); if force then rate_structure.rate_structure_number = rsn; end; if rate_structure.nrates ^= installation_parms.nrates then do; /* first, check the counts */ call ioa_ ("installation_parms has ^d rate_structures, rate_structure ""^a"" has ^d.", installation_parms.nrates, rsname, rate_structure.nrates); if force then do; call ioa_ ("Forcing change."); rate_structure.nrates = installation_parms.nrates; end; end; do i = 0 to installation_parms.nrates; /* now check the names */ if installation_parms.rate_structures (i) ^= rate_structure.rate_structures (i) then do; call ioa_ ( "installation_parms has rate_structure ""^a"" at position ^d.^/rate_structure ""^a"" has rate_structure ""^a""." , installation_parms.rate_structures (i), i, rsname, rate_structure.rate_structures (i)); if force then do; call ioa_ ("Forcing change."); rate_structure.rate_structures (i) = installation_parms.rate_structures (i); end; end; end; end; cur_rs_ptr = selected_rs_ptr; /* return to normalcy */ edit_rs = (cur_rs_ptr ^= ip); critical_op = "0"b; call check_config_table; /* config table ok? */ phoo = check_device_names (); /* device table have required names? */ end verify_structures; /* ------------------------------ */ write_error: procedure (ec, i, msg); dcl ec fixed bin (35); dcl i fixed bin; dcl msg char (*); call com_err_ (ec, me, "rate_structure_^d (^a) ^a.", i, installation_parms.rate_structures (i), msg); end write_error; set_pdir_quota_defaults: procedure; declare code fixed bin (35); /**** OLD COMMUNICATIONS SEGMENT */ dcl com_p pointer; dcl 1 communications based (com_p) aligned, /* Administrators and answering service use it */ 2 admin_word char (8) unal, /* Operator password for admin mode */ 2 ppmdl fixed bin, /* Per-process master drum limit */ 2 ppmdl_daemon fixed bin, /* ... for daemon */ 2 ssdq fixed bin, /* Process directory disk quota */ 2 ssdq_daemon fixed bin, /* ... for daemon */ 2 junk (4) fixed bin, 2 version fixed bin, 2 admin_sw fixed bin, /* Length of administrator's command */ 2 admin_comment char (80) unal, /* any old comment */ 2 admin_sender char (32) unal, /* Who sent it */ 2 as_procid bit (36), /* Process id of answering service */ 2 admin_com_chn fixed bin (71), /* Event-call channel for admin command */ 2 admin_com char (4000) unaligned; /* actual command line */ call initiate_file_ (sc_stat_$sysdir, "communications", R_ACCESS, com_p, (0), code); if code = 0 then do; installation_parms.default_pdir_seg_quota = communications.ssdq; call terminate_file_ (com_p, (0), TERM_FILE_TERM, (0)); end; else installation_parms.default_pdir_seg_quota = 1000; installation_parms.default_pdir_dir_quota = 1000; return; end set_pdir_quota_defaults; /* ------------------------------ */ %page; %include access_mode_values; %page; %include aim_template; %page; %include devid; %page; %include installation_parms; %include rate_structure; %include terminate_file; %include sc_stat_; end ed_installation_parms;  ed_mgt.pl1 04/09/85 1352.0r w 04/08/85 1134.5 791082 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* format: style4 */ ed_mgt: procedure options (variable); /* ed_mgt - edit "master_group_table" which gives load control parameters for the load control groups and work class definitions for the work classes used by the priority scheduler Modified by T. Casey, June 1975, to edit work class information for priority scheduler Modified by T. Casey, October 1975 to fix bugs Modified by T. Casey, October 1976 to add deadline scheduler parameters. Modified by T. Casey, Sept 1977, to fix bugs in print and verify requests, . and to permit the deletion of a group (which used to produce a warning). Modified by T. Casey, November 1978, to add group parameters: absentee_(max min pct). Modified May 1979 by T. Casey for MR7.0a to fix bug in verify (re the above absentee parameters). Modified July 1981 by J. Bongiovanni for governed work classes Modified 1984-09-17 BIM to remove call to reformat_mgt_, add page_weight support. Modified 1984-09-26 by E. Swenson to fix bug introduced by above change. */ %include mgt; %include access_mode_values; %include terminate_file; %page; dcl arg_count fixed bin; dcl created_new_mgt bit (1) aligned; dcl dn char (168), en char (32), grp char (8), change_code char (20), (i, j, k, n) fixed bin, mgtp1 ptr init (null), comm char (8), movelen fixed bin, ap ptr, al fixed bin (21), bchr char (al) unaligned based (ap), code fixed bin (35), mgtp ptr init (null), /* ptr to master group table (work copy) */ qq ptr, ask_$ask_clr entry options (variable), ask_$ask_flo entry options (variable), ask_$ask_int entry options (variable), ask_$ask_yn entry options (variable), ask_ entry options (variable), ask_$ask_n entry options (variable), ask_$ask_nint entry options (variable), ask_$ask_nflo entry options (variable), ask_$ask_c entry options (variable), ask_$ask_cint entry options (variable), ask_$ask_cflo entry options (variable), ask_$ask_setline entry (char (*)), btemp bit (1) aligned, itemp fixed bin, ftemp float bin; dcl (addr, fixed, float, hbound, index, length, max, min, mod, null, reverse, size, string, substr, verify) builtin; dcl program_interrupt condition; dcl cleanup condition; dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); dcl pathname_ entry (character (*), character (*)) returns (character (168)); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ioa_$nnl entry options (variable); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry () options (variable); dcl initiate_file_$create entry (character (*), character (*), bit (*), pointer, bit (1) aligned, fixed binary (24), fixed binary (35)); dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35)); dcl get_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl release_temp_segment_ entry (character (*), pointer, fixed binary (35)); dcl get_group_id_ entry () returns (char (32)); dcl get_wdir_ entry () returns (character (168)); dcl error_table_$unimplemented_version fixed bin (35) ext static; dcl mgtix fixed bin; dcl change_item fixed bin; dcl change_type fixed bin; dcl (fshift, lshift, nshift) fixed bin; dcl (mxval, nval) fixed bin; dcl flag fixed bin; dcl (gcfirst, gclast) fixed bin; dcl undefwc fixed bin; dcl shift fixed bin; dcl shift_pct fixed bin; dcl no_abs_count fixed bin; dcl dflt_g (4) fixed bin; dcl ival (8) fixed bin; dcl fval (8) float bin; dcl bval (8) bit (1) aligned; dcl shifts (8) fixed bin; dcl shf (8) fixed bin; /* set by get_shift_spec: list of shifts to be changed */ dcl nshf fixed bin; dcl print_pct_ignored bit (1) aligned; dcl default_absentee bit (1) aligned; dcl int_wc bit (1) aligned; dcl gcsw bit (1) aligned; dcl wcsw bit (1) aligned; dcl wcundef bit (1) aligned; dcl (got_shift_spec, got_int_abs, got_values) bit (1) aligned; dcl (padflt, pawc, pagrp, patot, paxrf) bit (1) aligned; dcl no_abs bit (1) aligned; dcl shift_used (0:7) bit (1) aligned; dcl q (4) bit (1) aligned; dcl dflt_q (4) bit (1) unaligned; dcl wcp ptr; dcl char32 char (32); dcl change_entry_type (2:26) fixed bin int static options (constant) init /* entry types that each change_code is valid for: 0=header,1=group,2=work class,3=group OR work class */ (0, /* 2: prio sked */ (9) 1, /* 3-11: maxu thru wc */ 3, /* 12: absentee */ (7) 2, /* 13-19: pct thru mode */ (2) 0, /* 20,21: normal moce, shifts */ (3) 1, /* 22-24: absentee_(max min pct) */ (2) 2); /* 25: max_pct, 26: page_weight */ dcl change_types (2:26) fixed bin int static options (constant) init /* data types for each item that change deals with */ (3, 2, 0, 2, 1, 1, 1, 1, 2, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 1, 1, 1, 4, 4); /* 0=char;1=float;2=float*10;3=yes/no;4=variable_format */ dcl vtypes (11:26) fixed bin int static options (constant) init /* mapping between change_item and value type, for the variable format change items */ (1, 3, 1, 3, 2, 2, 2, 2, 3, 3, 0, 0, 0, 0, 1, 1); /* 1=integer;2=floating point;3=keyword */ dcl change_names (2:26) char (12) int static options (constant) init (/* ITEM - names used in prompting messages */ "prio_sked" /* 2 */ , "max_prim" /* 3 */ , "id" /* 4 */ , "abs_max" /* 5 */ , "numerator" /* 6 */ , "denominator" /* 7 */ , "num1" /* 8 */ , "denom1" /* 9 */ , "constant" /* 10 */ , "work_class" /* 11 */ , "absentee y/n" /* 12 */ , "percent(s)" /* 13 */ , "defined y/n" /* 14 */ , "int_resp" /* 15 */ , "int_quantum" /* 16 */ , "resp" /* 17 */ , "quantum" /* 18 */ , "mode norm/rt" /* 19 */ , "deadline/pct" /* 20 */ , "shifts" /* 21 */ , "absentee_max" /* 22 */ , "absentee_min" /* 23 */ , "absentee_pct" /* 24 */ , "max_pct(s)" /* 25 */ , "page_weight" /* 26 */ ); dcl change_items (50) fixed bin int static options (constant) init /* correspondence between the 50 change_codes and the 26 items */ (1, 1, 2, 2, 3, 3, 3, 3, 4, 5, 5, 5, 6, 6, 7, 7, 7, 8, 9, 9, 10, 10, 10, 11, 11, 12, 13, 13, 13, 14, 14, 15, 15, 16, 16, 17, 17, 18, 18, 19, 20, 20, 21, 22, 23, 24, 25, 25, 26, 26); dcl change_codes (50) char (12) int static options (constant) init ( /* CODE ITEM - names that user can give in change request */ /* control items - used to exit from change mode */ "*" /* 1 1 */ , "." /* 2 1 */ /* header items (see additional header items below) */ , "prio" /* 3 2 */ , "prio_sked" /* 4 2 */ /* group items */ , "maxu" /* 5 3 */ , "max_prim" /* 6 3 */ , "maxp" /* 7 3 */ , "m" /* 8 3 */ , "id" /* 9 4 */ , "abs" /* 10 5 */ , "abs_max" /* 11 5 */ , "minamax" /* 12 5 */ , "numerator" /* 13 6 */ , "num" /* 14 6 */ , "denominator" /* 15 7 */ , "den" /* 16 7 */ , "denom" /* 17 7 */ , "num1" /* 18 8 */ , "denom1" /* 19 9 */ , "den1" /* 20 9 */ , "constant" /* 21 10 */ , "const" /* 22 10 */ , "con" /* 23 10 */ , "work_class" /* 24 11 */ , "wc" /* 25 11 */ /* both group and work class item */ , "absentee" /* 26 12 */ /* work class only items */ , "percent" /* 27 13 */ , "pct" /* 28 13 */ , "%" /* 29 13 */ , "defined" /* 30 14 */ , "def" /* 31 14 */ , "int_resp" /* 32 15 */ , "ir" /* 33 15 */ , "int_quantum" /* 34 16 */ , "iq" /* 35 16 */ , "resp" /* 36 17 */ , "r" /* 37 17 */ , "quantum" /* 38 18 */ , "q" /* 39 18 */ , "mode" /* 40 19 */ /* additional header items */ , "normal_mode" /* 41 20 */ , "norm" /* 42 20 */ , "shifts" /* 43 21 */ , "absentee_max" /* 44 22 */ , "absentee_min" /* 45 23 */ , "absentee_pct" /* 46 24 */ /* additional work class only items */ , "max_percent" /* 47 25 */ , "max_pct" /* 48 25 */ , "page_weight" /* 49 26 */ , "pw" /* 50 26 */ ); declare ME char (32) int static init ("ed_mgt") options (constant); declare DEFAULT_MGT_PATH char (168) init ("MGT.mgt") int static options (constant); call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; if arg_count > 1 then do; call com_err_$suppress_name (0, ME, "Usage: ed_mgt {pathname}"); return; end; if arg_count = 0 then do; ap = addr (DEFAULT_MGT_PATH); al = length (rtrim (DEFAULT_MGT_PATH)); end; else call cu_$arg_ptr (1, ap, al, (0)); call expand_pathname_$add_suffix (bchr, "mgt", dn, en, code); if code ^= 0 then do; call com_err_ (code, "ed_mgt", bchr); return; end; created_new_mgt = "0"b; mgtp, mgtp1 = null (); on cleanup call clean_up; call initiate_file_$create (dn, en, RW_ACCESS, mgtp1, created_new_mgt, (0), code); if code ^= 0 then do; call com_err_ (code, ME, "^a", pathname_ (dn, en)); call clean_up; end; call get_temp_segment_ (ME, mgtp, code); if code ^= 0 then do; call com_err_ (code, ME, "Internal error; cannot get a temp segment."); call clean_up; end; on condition (program_interrupt) go to main1; if ^(created_new_mgt | mgtp1 -> mgt.version_indicator ^= "VERSION ") then mgtp -> mgt = mgtp1 -> mgt; else do; call ioa_ ("Creating new MGT ^a.", pathname_ (dn, en)); call initialize_mgt; end; if mgt.version ^= MGT_version_3 then do; /* if not current version, see what it is */ call com_err_ (error_table_$unimplemented_version, ME, "MGT version is ^d, must be ^d.", mgt.version, MGT_version_3); call clean_up; return; end; /* end version not 3 */ /* Initialize current position and enter request loop */ mgtix = 17; /* group 1 */ mgtep = addr (mgt.entry (17)); /* gotta start somewhere */ if mgt.current_size < mgtix then do; /* nobody home? */ call ioa_ ("no groups defined, ""add"" assumed"); go to acom; end; /* Come here after an error, to clear any typed ahead input before prompting for next request */ main1: call ask_$ask_clr; /* Come here to prompt for another request */ main: call ask_ ("type ", comm); /* get command */ mgtep = addr (mgt.entry (mgtix)); /* mgtep gets moved around - mgtix is the true "current pointer" */ if comm = "quit" then goto qcom; else if comm = "q" then qcom: exit: do; call clean_up; return; end; else if comm = "write" | comm = "w" then do; /* write? */ wcom: created_new_mgt = "0"b; /* don't delete me! */ mgtp1 -> mgt = mgtp -> mgt; call terminate_file_ (mgtp1, 36 * (64 + mgtp1 -> mgt.current_size * 32), TERM_FILE_TRUNC | TERM_FILE_BC, (0)); goto main; /* leave pointer where it was, after a write */ end; else if comm = "f" then go to fcom; /* find */ else if comm = "find" then do; fcom: call ask_ ("group ", grp); do i = 1 to mgt.current_size; mgtep = addr (mgt.entry (i)); if group.group_id = grp then do; mgtix = i; go to pentry; end; end; call ioa_ ("group ""^a"" not found", grp); go to main1; end; else if comm = "c" then go to ccom; /* change */ else if comm = "change" then do; ccom: gcsw = "0"b; /* not global change */ if mgtix <= 16 then wcsw = "1"b; else wcsw = "0"b; call change; end; else if comm = "gc" then goto gccom; else if comm = "global_change" then do; gccom: gcsw = "1"b; call ask_ ("entry type ", change_code); if change_code = "load_control_group" then goto lctype; if substr (change_code, 1, 5) = "group" then goto lctype; /* allow singular or plural */ else if change_code = "lcg" then do; lctype: wcsw = "0"b; end; else if change_code = "work_class" then goto wctype; else if change_code = "wc" then do; wctype: wcsw = "1"b; end; else do; call ioa_ ("bad entry type: ""^a""^/must be ""work_class"" or ""load_control_group""", change_code); call ask_$ask_clr; goto gccom; end; call change; end; else if comm = "p" then go to pcom; else if comm = "print" then do; pcom: if mgtix > 16 then call prgp (mgtep); else do; wcundef = ""b; call prwc (mgtep); if wcundef then do; call ioa_ (" is undefined"); wcundef = ""b; end; end; end; else if comm = "p*" then go to pacom; else if comm = "pa" then go to pacom; else if comm = "pall" then do; pacom: padflt = "1"b; /* assume no optional arguments */ patot, pawc, pagrp, paxrf = "0"b; paloop: call ask_$ask_n (char32, flag); /* check for optional arguments */ if flag = 0 then goto no_pa_arg; /* if nothing there */ if substr (char32, 1, 3) = "tot" then do; /* allow "tot", "total", "totals" */ patot = "1"b; pa_arg: padflt = "0"b; /* remember that some args were given */ call ask_$ask_c (char32, flag); /* get rid of it from line */ goto paloop; /* go see if more */ end; else if char32 = "lcg" then goto pa_grp; else if substr (char32, 1, 5) = "group" then goto pa_grp; /* allow singular or plural form */ else if substr (char32, 1, 18) = "load_control_group" then do; pa_grp: pagrp = "1"b; goto pa_arg; end; else if char32 = "wc" then goto pa_wc; else if substr (char32, 1, 10) = "work_class" then do; /* allow singular or plural form */ pa_wc: pawc = "1"b; goto pa_arg; end; else if char32 = "xref" then goto pa_xref; else if char32 = "cref" then goto pa_xref; else if substr (char32, 1, 5) = "cross" then do; /* allow cross reference, in any form */ pa_xref: paxrf = "1"b; goto pa_arg; end; no_pa_arg: /* fall thru if no match, or come here if no typed ahead arg */ if padflt then /* if no args given, use the default */ patot, pawc, pagrp, paxrf = "1"b; /* which is to print everything */ /* now, print the stuff */ if patot then do; /* if we are to print totals from mgt header */ call ioa_ ("max_size ^d", mgt.max_size); call ioa_ ("current_size ^d", mgt.current_size); call ioa_ ("total_units ^d", mgt.total_units); call ioa_ ("prio_sked_enabled: ^[yes^;no^]", mgt.switches.prio_sked_enabled); call ioa_ ("wc_initialized: ^[yes^;no^]", mgt.switches.wc_initialized); call print_shfs (mgt.shift_defined, "defined shifts: ", "^x^d"); call print_bvals (mgt.shift_defined, "scheduling mode:", "^x^[d^;%^]", mgt.switches.deadline_mode); end; if pagrp then /* if we should print all groups */ do n = 17 to mgt.current_size; /* do so */ qq = addr (mgt.entry (n)); call prgp (qq); end; if pawc then do; /* if we should print all work classes */ wcundef = ""b; /* we check for a series of undefined work classes */ do n = 1 to 16; /* to avoid aggravating the user */ qq = addr (mgt.entry (n)); /* by printing a long list of "... is undefined" lines */ if wcundef then do; /* if the previous one was undefined */ if string (qq -> work_class.switches.defined) ^= ""b then do; /* but this one is defined */ plast: wcundef = ""b; if undefwc = n - 1 then /* if only the last one was undefined */ call ioa_ (" is undefined"); else call ioa_ ("-^d are undefined", n - 1); if n <= 16 then /* if not entered at plast to print "last few undefined" */ call prwc (qq); /* go print the current work class */ end; end; else do; /* previous one was not undefined */ call prwc (qq); if wcundef then /* prwc checks, and sets this switch */ undefwc = n; /* remember the first undefined one in the series */ end; end; if wcundef then /* if last few were undefined */ goto plast; /* go print message to that effect */ end; if paxrf then /* if we are to print a cross reference */ call pxref; /* go do so */ end; else if comm = "a" then go to acom; else if comm = "add" then do; acom: call ask_ ("group ", grp); do mgtix = 1 to mgt.current_size; mgtep = addr (mgt.entry (mgtix)); if group.group_id = grp then do; if mgtix < 17 then call ioa_ ("use the ""change"" request to define a work class"); else call ioa_ ("group ""^a"" already exists", grp); go to main1; end; end; mgtix = mgt.current_size + 1; mgtep = addr (mgt.entry (mgtix)); group.group_id = grp; group.minamax = 32767; /* will have to change this if Multics gets really big */ group.absentee.allowed = "1"b; /* by default */ call ask_$ask_flo ("constant ", ftemp); if ftemp < 0e0 then group.max_prim = -1; else group.minu = ftemp * 10; if mgt.switches.wc_initialized then /* if work classes (other than the initial default of 1) have been defined */ call ask_$ask_int ("work class ", itemp); /* keep it simple - just ask for one */ else itemp = 1; /* none defined - use the initial default work class */ do i = 0 to 7; if mgt.shift_defined (i) then group.int_wc (i), group.abs_wc (i) = itemp; else group.int_wc (i), group.abs_wc (i) = 0; end; mgt.current_size = mgtix; end; else if comm = "delete" then do; if mgtix <= 16 then do; call ioa_ ("use the ""change"" request to undefine a work class"); goto main1; end; do i = mgtix + 1 to mgt.current_size; mgt.entry (i - 1) = mgt.entry (i); end; mgt.current_size = mgt.current_size - 1; mgtix = min (mgtix, mgt.current_size); /* in case we deleted the last group */ mgtep = addr (mgt.entry (mgtix)); goto pentry; /* tell user the current group has changed */ end; else if comm = "n" then go to ncom; else if comm = "next" then do; ncom: mgtix = mgtix + 1; if mgtix > mgt.current_size then do; call ioa_ ("EOF"); mgtix = mgt.current_size; end; mgtep = addr (mgt.entry (mgtix)); goto pentry; end; else if comm = "top" then go to tcom; else if comm = "t" then go to tcom; else if comm = "-" then do; mgtix = mgtix - 1; if mgtix <= 0 then do; call ioa_ ("TOP"); tcom: mgtix = 1; end; mgtep = addr (mgt.entry (mgtix)); goto pentry; end; else if comm = "verify" then goto vcom; else if comm = "v" then do; vcom: call verify_mgt; end; else if comm = "define" then call define; else if comm = "redefine" then call redefine; else if comm = "undefine" then call undefine; else do; /* ? */ call ioa_ ("illegal command ""^a""", comm); go to main1; end; /* Fall thru to here after executing a request, unless: 1) an error occurred and we went directly to main1 to flush possible typeahead; or 2) we moved the current pointer and went to pentry (just below) to print the name of the new current entry. */ go to main; pentry: /* come here to print line telling user where he is */ call ask_$ask_n (char32, flag); /* see if anything typed ahead */ if flag ^= 0 then goto main; /* if user typed ahead, we assume he knows where he is */ if mgtix <= 16 then call ioa_ ("work class: ^a", work_class.wc_name); else call ioa_ ("group: ^a", group.group_id); goto main; /* ****************************************************************************************************************** */ /* Internal procedures, in alphabetic order */ ask_cval: proc (vtype, where, flag); dcl (flag, vtype, where) fixed bin; if vtype = 1 then call ask_$ask_cint (ival (where), flag); else if vtype = 2 then call ask_$ask_cflo (fval (where), flag); else if vtype = 3 then call ask_ckey (bval (where), flag); return; end ask_cval; /* ****************************************************************************************************************** */ ask_key: proc (bval, prompt); dcl prompt char (*); dcl bval bit (1) aligned; dcl (prompt_sw, remove_sw, yn_sw) bit (1) aligned; dcl (flag, local_flag) fixed bin; prompt_sw, remove_sw = "1"b; yn_sw = ""b; goto key_common; /* ********** */ ask_ckey: entry (bval, flag); flag = 0; prompt_sw, yn_sw = ""b; remove_sw = "1"b; goto key_common; /* ********** */ ask_nkey: entry (bval, flag); flag = 0; prompt_sw, remove_sw, yn_sw = ""b; goto key_common; /* ********** */ ask_yn: entry (bval, prompt); prompt_sw, yn_sw = "1"b; remove_sw = ""b; goto dont_ask_key; /* caller already asked, and char32 contains the response */ /* ********** */ ask_cyn: entry (bval, flag); remove_sw, prompt_sw = ""b; yn_sw = "1"b; goto dont_ask_key; /* caller already asked, as above */ /* ********** */ key_common: if prompt_sw then ask_key_again: call ask_ ("^a ", char32, prompt); else do; call ask_$ask_n (char32, flag); if flag = 0 then return; end; dont_ask_key: local_flag = 0; if change_item = 12 | change_item = 14 | yn_sw then call scan_key ("allowed,yes,y,on,1,ok,^allowed,not_allowed,no,n,off,0", (6), bval, local_flag); else if change_item = 19 then call scan_key ("realtime,rt,normal,norm", (2), bval, local_flag); else if change_item = 20 then call scan_key ("deadline,percent,pct,%", (1), bval, local_flag); if local_flag = 0 then do; /* no match with keywords */ if prompt_sw then do; /* but caller insists on getting one */ call ioa_ ("bad value: ""^a""", char32); call ask_$ask_clr; /* flush typeahead */ goto ask_key_again; /* and go insist */ end; else flag = -1; /* caller just wants to know, so say "something there but not what you want" */ end; else /* there was a match */ if ^prompt_sw then do; /* if caller was not insisting */ flag = 1; /* tell him we found good value */ if remove_sw then call ask_$ask_c (char32, local_flag); /* read it again to remove it from the input line */ end; return; end ask_key; /* ****************************************************************************************************************** */ ask_val: proc (vtype, where, prompt); dcl (vtype, where) fixed bin; dcl prompt char (*); if vtype = 1 then call ask_$ask_int ("^a ", ival (where), prompt); else if vtype = 2 then do; call ask_$ask_flo ("^a ", fval (where), prompt); if change_item >= 15 & change_item <= 18 then/* int_resp, int_quantum, resp, or quantum */ fval (where) = fval (where) * 100e0 + .005e0; end; else if vtype = 3 then call ask_key (bval (where), prompt); return; end ask_val; /* ****************************************************************************************************************** */ assign_value: proc (vtype, to, from); dcl (from, to, vtype) fixed bin; if vtype = 1 then ival (to) = ival (from); else if vtype = 2 then fval (to) = fval (from); else if vtype = 3 then bval (to) = bval (from); return; end assign_value; /* ****************************************************************************************************************** */ change: proc; /* procedure to implement the change subcommand. it is called by both the change and global_change requests. it dechange_codes one change request and makes the change (to one entry or all entries of the specified type), and then reads the next request. the "." and "*" requests cause exit from the change subcommand */ dcl i fixed bin; ask_code: call ask_ ("code ", change_code); do i = 1 to hbound (change_codes, 1) while (change_code ^= change_codes (i)); end; if i > hbound (change_codes, 1) then do; /* not found */ call ioa_ ("bad change code: ""^a""", change_code); change_clr: call ask_$ask_clr; goto ask_code; end; change_item = change_items (i); /* pick up which variable is to be changed */ change_type = change_types (change_item); /* and what type it is */ if change_item = 1 then return; /* "." or "*" */ /* See of change_code is valid for entry type being changed */ if change_entry_type (change_item) ^= 0 then do; /* if change_code is for a header item, it is ok; otherwise, check */ if wcsw & change_entry_type (change_item) = 1 then do; /* we're changing a work class, but change_code is for groups only */ call ioa_ ("code ""^a"" is not legal for a work class", change_code); goto change_clr; end; else if ^wcsw & change_entry_type (change_item) = 2 then do; /* we're changing a group, but change_code is for work classes only */ call ioa_ ("code ""^a"" is not legal for a load control group", change_code); goto change_clr; end; /* notice that we fall thru for change_entry_type = 3, which means "valid for both group and work class" */ end; goto ask_type (change_type); /* go read value(s) from the input line */ ask_type (0): /* character string */ ask_type (3): /* yes or no word */ call ask_ ("^a ", char32, change_names (change_item)); if change_type = 3 then call ask_yn (bval (1), change_names (change_item)); goto asked_type; ask_type (1): /* float */ ask_type (2): /* float*10e0 */ call ask_$ask_flo ("^a ", ftemp, change_names (change_item)); if change_type = 2 then /* if float*10e0 */ if ftemp > 0e0 then /* and value is not negative */ ftemp = ftemp * 10e0; /* multiply it by 10 */ goto asked_type; /* variable format - got to look ahead on the line to see what we have */ ask_type (4): /* "c absentee" for a group is different from all the other variable format requests it can be either of: c absentee c absentee queue |none */ if change_item = 12 & ^wcsw then do; /* if that's what we have */ ask_abs: call ask_ ("""yes"" or ""no"" or ""queue""", char32); if char32 = "queue" then goto abs_q; else if char32 = "q" then do; abs_q: call get_int_list ("queue(s)", 4, nval); q (*) = "0"b; do i = 1 to nval; /* if nval = 0, q(*) stays = "0"b, which is what we want */ if ival (i) <= 0 then goto badq; if ival (i) > 4 then do; badq: call ioa_ ("bad absentee queue number: ^d", ival (i)); call ask_$ask_clr; goto abs_q; end; q (ival (i)) = "1"b; end; default_absentee = "1"b; /* we are changing this group's default absentee switch */ end; else do; /* changing the absentee allowed bit */ call ask_cyn (bval (1), itemp); /* see if yes or no word there */ if itemp <= 0 then do; /* not a yes or no word */ call ioa_ ("bad value: ^a", char32); call ask_$ask_clr; goto ask_abs; end; default_absentee = "0"b; /* we are not changing this group's default absentee switch */ end; end; /* end of "c absentee for a group" do group */ /* all the other variable format requests */ else do; /* * ITEM FORMAT ( "[]" denotes an optional argument) * 11 work_class [shift spec] [int|abs] * 12 absentee [shift spec] * 13 percent [shift spec] * 14 defined [shift spec] * 15 int_resp [shift spec] * 16 int_quantum [shift spec] * 17 resp [shift spec] * 18 quantum [shift spec] * 19 mode [shift spec] <"normal" or "realtime" per-shift mode indicators> * 25 max_percent [shift spec] * * THE ABOVE APPLY SEPARATELY TO EACH WORK CLASS * * THE FOLLOWING APPLY TO ALL WORK CLASSES AND ARE STORED IN THE MGT HEADER * * 20 normal_mode [shift spec] <"deadline" or "percent" per-shift mode indicators> * 21 shifts (can be i j k OR m-n OR mixture) * * There are several comments below, related to whether or not "values" have been typed ahead. * These refer only to the values described in "< >" brackets above. * They specifically exclude the shift spec and the int|abs indicators. * The significant point here is that, if a list of values is typed ahead, omitted * shift specification information takes on default values that are a function * of the number of values typed ahead, but if a list of values is not typed ahead, * then the shift spec is prompted for and must be given. A different path * is taken through the code below in each of these two cases. * * The default when one value is given is "shift all" (all defined shifts get set to the one value). * When a list of values is given, the default is "shift S1" where S1 is the lowest * numbered defined shift, and the values are assigned to successive defined shifts, starting with S1. * * */ /* set up default shift specification */ nshf = 0; /* no shifts have actually been given by the user */ fshift = -1; /* scan for defined shifts starting after -1 (i.e. at zero) */ mxval = 0; /* initialize counter for defined shifts */ call set_default_shift_spec; /* go count defined shifts and remember their numbers */ /* mxval now = number of defined shifts (= number of values we can use) */ lshift, nshift = 0; /* only used when shift spec given, but clear garbage anyway */ got_shift_spec, got_int_abs, got_values = "0"b; int_wc = "1"b; /* the default is interactive work class */ look_ahead: call ask_$ask_n (char32, flag); /* look at next word without removing it from line */ if flag ^= 0 then do; /* something was typed ahead */ if ^got_shift_spec & change_item ^= 21 & substr (char32, 1, 5) = "shift" then do; call get_shift_spec; goto look_ahead; /* go look for more typed ahead stuff */ end; else if ^got_int_abs & change_item = 11 then do; /* check for "int" or "abs" */ got_int_abs = check_int_abs (); if got_int_abs then goto look_ahead; /* go look for more typed ahead stuff */ else goto check_values; /* go see if this is values */ end; else do; /* must be values that were typed ahead */ check_values: nval = 0; /* so we can tell if we got any values */ if change_item = 21 /* shifts */ & ck_int (char32, (0), (0)) then /* and we have shift number(s) */ call get_int_list (change_names (change_item), (8), nval); else call look_ahead_value (vtypes (change_item), nval); if nval > 0 then got_values = "1"b; else do; call ioa_ ("""^a"" unrecognized", char32); call ask_$ask_clr; end; end; /* from here, we fall thru to the label "asked_type", without looking for any more type ahead, or prompting for anything */ end; /* end of "there is type ahead" do group */ else do; /* there is no more type ahead */ /* NOTE: this do group is not entered if values were typed ahead; and note again that "values" do not include the shift_spec or int|abs items */ if ^got_shift_spec then /* if shift not already given */ call get_shift_spec; /* go ask user for it */ if change_item = 11 then /* if this is "c work_class" */ if ^got_int_abs then /* and int|abs was not already given */ call get_int_abs; /* go ask user for it */ /* we know values were not already given, or we would not be here */ if change_item = 21 then /* shifts */ call get_int_list (change_names (change_item), (8), nval); else call get_values (vtypes (change_item), change_names (change_item), nval); end; /* end "no more type ahead" do group */ end; /* end of "all other variable formats" do group */ asked_type: /* we now have all the info necessary to make a change */ if gcsw then do; /* if global change */ if wcsw then do; gcfirst = 1; gclast = 16; end; else do; gcfirst = 17; gclast = mgt.current_size; end; do i = gcfirst to gclast; mgtep = addr (mgt.entry (i)); call change_one_item; end; end; else call change_one_item; /* regular change */ goto ask_code; end change; /* ****************************************************************************************************************** */ change_one_item: proc; /* procedure to change one item in one mgt entry; called in a loop over all entries of one type, for the global_change request, or just once, for the change request */ dcl i fixed bin; goto item (change_item); /* item 1 is a "." or "*" which exits from change without coming here */ item (2): mgt.switches.prio_sked_enabled = bval (1); /* prio, prio_sked */ return; item (3): if ftemp = -1e0 then group.max_prim = -1; /* maxu, max_prim, maxp */ else do; call ioa_ ("warning: changing max_prim to value not -1"); group.max_prim = ftemp; end; return; item (4): group.group_id = char32; /* id */ return; item (5): if ftemp < 0 then group.minamax = 32767; /* Multics will never get that big ... */ else group.minamax = ftemp; /* abs, abs_max, minamax */ return; item (6): group.num = ftemp; /* numerator, num */ return; item (7): group.denom = ftemp; /* denominator, denom, den */ return; item (8): group.num1 = ftemp; /* num1 */ return; item (9): group.denom1 = ftemp; /* denom1, den1 */ return; item (10): group.minu = ftemp; /* constant, const, con */ return; item (11): do i = 1 to nshf; /* work_class, wc */ if int_wc then group.int_wc (shf (i)) = ival (i); else group.abs_wc (shf (i)) = ival (i); end; return; item (12): /* absentee */ if ^wcsw then do; /* c absentee for a group */ if default_absentee then do; do i = 1 to 4; group.absentee.default_queue (i) = q (i); end; if string (group.absentee.default_queue) ^= ""b then /* if it is the default for any queues */ group.absentee.default_group = "1"b; /* flag it as a default absentee group */ else group.absentee.default_group = "0"b; /* otherwise clear possible old value */ end; else group.absentee.allowed = bval (1); end; /* items above are all for groups - those below, for work classes */ else do i = 1 to nshf; /* item 12 can be for group or work class */ if (^gcsw | work_class.switches.defined (shf (i))) then work_class.switches.absentee_allowed (shf (i)) = bval (i); end; return; item (13): do i = 1 to nshf; /* percent, pct, % */ if (^gcsw | work_class.switches.defined (shf (i))) then work_class.min_pct (shf (i)) = ival (i); end; return; item (14): do i = 1 to nshf; /* defined, def */ work_class.switches.defined (shf (i)) = bval (i); if mgtix ^= 1 then /* if we are defining a wc other than 1 */ mgt.switches.wc_initialized = "1"b; /* this is no longer a transitional MGT */ end; return; item (15): /* int_resp, ir */ item (16): /* int_quantum, iq */ item (17): /* resp, r */ item (18): /* quantum, q */ item (19): /* mode */ do i = 1 to nshf; if (^gcsw | work_class.switches.defined (shf (i))) then if change_item = 15 then /* int_resp */ work_class.int_response (shf (i)) = fixed (fval (i)); else if change_item = 16 then /* int_quantum */ work_class.int_quantum (shf (i)) = fixed (fval (i)); else if change_item = 17 then /* resp */ work_class.response (shf (i)) = fixed (fval (i)); else if change_item = 18 then /* quantum */ work_class.quantum (shf (i)) = fixed (fval (i)); else /* change_item = 19 (mode) */ work_class.switches.realtime (shf (i)) = bval (i); end; return; item (25): /* max_percent, max_pct */ do i = 1 to nshf; if (^gcsw | work_class.switches.defined (shf (i))) then work_class.max_pct (shf (i)) = ival (i); end; return; item (26): call ioa_ ("Page_weight is not yet supported."); return; /* items above are per-work_class items; those below are header items, that apply to all work classes */ item (20): /* normal_mode, norm */ do i = 1 to nshf; mgt.switches.deadline_mode (shf (i)) = bval (i); end; return; item (21): /* shifts */ mgt.shift_defined (*) = ""b; /* clear list of defined shifts - we have a new one */ do i = 1 to nval; /* count of defined shifts is in nval, not nshf */ mgt.shift_defined (ival (i)) = "1"b; end; return; item (22): /* absentee_max */ if ftemp > 3276.6e0 & ftemp < 3276.8e0 then /* perpetuate an old design error */ ftemp = 32767e0; group.absentee_max = ftemp; return; item (23): /* absentee_min */ group.absentee_min = ftemp; return; item (24): /* absentee_pct */ if ftemp < 1e0 then /* if user typed 0.10 for 10% */ ftemp = ftemp * 100e0; /* multiply by 100, since we store it as an integer */ group.absentee_pct = ftemp; return; end change_one_item; /* ****************************************************************************************************************** */ ck_int: proc (char_int, f, n) returns (bit (1)); /* procedure to decode a number (or pair of numbers) of the following form: n m-n and return the first value and the number of consecutive values implied by the pair. m and n can be any of the digits 0 thru 7 */ dcl char_int char (*); dcl (f, n) fixed bin; dcl (i, j) fixed bin; dcl digits char (8) int static init ("01234567"); if substr (char_int, 2) = "" then goto onedigit; else if substr (char_int, 4) = "" then goto hyph; else goto bad; onedigit: i = index (digits, substr (char_int, 1, 1)); /* look up the digit */ if i = 0 then goto bad; /* not one of 0 thru 7 */ n = 1; /* one value returned */ f = i - 1; /* its value */ goto good; hyph: if substr (char_int, 2, 1) ^= "-" then goto bad; i = index (digits, substr (char_int, 1, 1)); /* scan digits starting at 0 */ if i = 0 then goto bad; j = index (digits, substr (char_int, 3, 1)); /* therefore i and j are 1+ value of digit */ if j = 0 then goto bad; if j < i then goto bad; /* "6-3" is bad - user must say "3-6" */ f = i - 1; /* first value */ n = j - f; /* number of values */ /* for example, "3-6" => f=3,n=4, since i=4,j=7 */ good: return ("1"b); bad: return ("0"b); end ck_int; /* ****************************************************************************************************************** */ copy_shift: proc (tsh, fsh); dcl (fsh, tsh) fixed bin; dcl i fixed bin; do i = 1 to 16; mgtep = addr (mgt.entry (i)); if work_class.switches.defined (fsh) then do;/* only if wc defined on this shift */ work_class.switches.defined (tsh) = "1"b; work_class.switches.absentee_allowed (tsh) = work_class.switches.absentee_allowed (fsh); work_class.switches.realtime (tsh) = work_class.switches.realtime (fsh); work_class.min_pct (tsh) = work_class.min_pct (fsh); work_class.max_pct (tsh) = work_class.max_pct (fsh); work_class.int_response (tsh) = work_class.int_response (fsh); work_class.int_quantum (tsh) = work_class.int_quantum (fsh); work_class.response (tsh) = work_class.response (fsh); work_class.quantum (tsh) = work_class.quantum (fsh); end; end; do i = 17 to mgt.current_size; mgtep = addr (mgt.entry (i)); group.int_wc (tsh) = group.int_wc (fsh); group.abs_wc (tsh) = group.abs_wc (fsh); end; return; end copy_shift; /* ****************************************************************************************************************** */ default_shift: proc (sh); dcl sh fixed bin; dcl i fixed bin; mgtep = addr (mgt.entry (1)); /* work class 1 is the only one, by default */ work_class.switches.defined (sh) = "1"b; work_class.switches.absentee_allowed (sh) = "1"b; work_class.switches.realtime (sh) = ""b; work_class.min_pct (sh) = 100; work_class.max_pct (sh) = 0; work_class.int_response (sh) = 400; work_class.int_quantum (sh) = 50; work_class.response (sh) = 3200; work_class.quantum (sh) = 100; call undefine_wc (sh, 2, 16); /* make sure of no garbage in wc 2-16 */ do i = 17 to mgt.current_size; mgtep = addr (mgt.entry (i)); group.int_wc (sh) = 1; group.abs_wc (sh) = 1; end; return; end default_shift; /* ****************************************************************************************************************** */ define: proc; dcl (like_sw, redefine_sw, undefine_sw) bit (1) aligned; dcl (i, lsh) fixed bin; redefine_sw, undefine_sw = ""b; define_common: call get_shift_list (nval); if ^undefine_sw then call get_like_shift (lsh, like_sw); do i = 1 to nval; /* shifts to be defined are in ival(1) thru ival(nval) */ if redefine_sw | ^shift_is_defined (ival (i)) then do; /* if it's ok to change this shift */ if undefine_sw then call undefine_shift (ival (i)); else if like_sw then call copy_shift (ival (i), lsh); else call default_shift (ival (i)); if undefine_sw then mgt.shift_defined (ival (i)) = ""b; else mgt.shift_defined (ival (i)) = "1"b; end; else call ioa_ ("shift ^d already defined; use redefine to change it", ival (i)); end; return; redefine: entry; redefine_sw = "1"b; undefine_sw = ""b; goto define_common; undefine: entry; redefine_sw, undefine_sw = "1"b; goto define_common; end define; /* ****************************************************************************************************************** */ get_int_abs: proc; /* procedure to read the interactive|absentee specification; it may be "interactive", "absentee", "int" or "abs"; this entry point prompts for it if it was not typed ahead; the check_int_abs entry point checks if it was typed ahead, if so, reads it and returns "1"b, if not, returns "0"b */ dcl cksw bit (1) aligned; cksw = "0"b; call ask_ ("""interactive"" or ""absentee"" ", char32); int_abs_common: if char32 = "interactive" then goto int; if char32 = "int" then do; int: int_wc = "1"b; goto exit_ok; end; else if char32 = "absentee" then goto abs; else if char32 = "abs" then do; abs: int_wc = "0"b; goto exit_ok; end; else do; if cksw then goto exit_ng; /* go return "0"b */ call ioa_ ("bad value: ""^a""", char32); call ask_$ask_clr; goto int_abs_common; /* insist */ end; exit_ng: return ("0"b); exit_ok: if cksw then do; call ask_$ask_c (char32, flag); /* remove it from the line */ return ("1"b); end; else return; check_int_abs: entry returns (bit (1)); cksw = "1"b; call ask_$ask_n (char32, flag); if flag = 0 then goto exit_ng; /* nothing typed ahead */ goto int_abs_common; /* something there - go see if it is "int" or "abs" */ end get_int_abs; /* ****************************************************************************************************************** */ get_int_list: proc (prompt, mxv, nv); /* procedure to read a list, prompting for it if not typed ahead; the list is of the form: i j k-l m n-o p ... that is, integers, or pairs of the form m-n; m-n pairs are expanded into m m+1 ... n-1 n; prompt is the prompting message; mxv is the most values the caller wants; nv is the actual number of values returned; values are returned in ival(1) thru ival(nv). */ dcl prompt char (*); dcl (mxv, nv) fixed bin; dcl i fixed bin; dcl (f, n) fixed bin; ask_int_list: call ask_ ("^a ", char32, prompt); nv = 0; /* initialize counter */ if char32 = "none" then return; /* the list is empty */ if ^ck_int (char32, f, n) then do; /* bad value */ bad_int: call ioa_ ("bad value: ""^a""", char32); call ask_$ask_clr; goto ask_int_list; end; get_int_loop: if nv + n > mxv then /* if m-n pair expands into too many values */ goto bad_int; /* go complain and start over */ do i = 0 to n - 1; /* this loop stores values for both m-n pairs and single values */ nv = nv + 1; ival (nv) = f + i; end; if nv = mxv then return; /* if we have gotten max allowed values */ call ask_$ask_n (char32, flag); /* see if anything typed ahead */ if flag = 0 then return; /* nothing */ if ^ck_int (char32, f, n) then return; /* something, but not right form */ call ask_$ask_c (char32, flag); /* right form: read it again to remove it from the line */ goto get_int_loop; /* go decode and store it */ end get_int_list; /* ****************************************************************************************************************** */ get_like_shift: proc (sh, sw); dcl sh fixed bin; dcl sw bit (1) aligned; sw = ""b; /* we have not gotten a "like" shift yet */ call ask_$ask_n (char32, flag); /* look for type ahead */ if flag > 0 then /* there is some */ if char32 = "like" then do; /* "like" must be typed ahead if it is to be given */ call ask_$ask_c (char32, flag); /* get past "like" */ call ask_$ask_n (char32, flag); /* see what's next */ if flag > 0 then /* something there */ if char32 = "shift" then /* allow "shift" to preceed the number, if typed ahead */ call ask_$ask_c (char32, flag); /* get past "shift" */ ask_like_shift: call ask_$ask_int ("like shift ", sh); /* ask for one shift number */ if sh < 0 | sh > 7 then do; call ioa_ ("illegal shift number: ^d", sh); call ask_$ask_clr; goto ask_like_shift; end; sw = "1"b; /* we got a like shift */ end; return; end get_like_shift; /* ****************************************************************************************************************** */ get_shift_list: proc (nv); dcl nv fixed bin; call ask_$ask_n (char32, flag); /* see if any type ahead */ if flag > 0 then /* if there is */ if substr (char32, 1, 5) = "shift" then /* allow shift or shifts to be typed ahead */ call ask_$ask_c (char32, flag); /* get past it, if there */ ask_shifts: call get_int_list ("shifts ", (8), nv); if nv = 0 then do; call ioa_ ("some shifts must be given"); call ask_$ask_clr; goto ask_shifts; end; return; end get_shift_list; /* ****************************************************************************************************************** */ get_shift_spec: proc; /* procedure to read a shift specification of one of the following forms, returning output as indicated: shift n nshf=1;shf(1)=n;shf(2) thru shf(mxval) = possible other shifts; mxval = how many altogether. shift m-n nshf = number of shifts defined in m-n range;shf(1) thru shf(nshf) = those shifts; mxval = 1. shift all nshf = number of shifts defined at site;shf(1) thru shf(nshf) = those shifts; mxval = 1. in all cases, fshift = shf(1); lshift = shf(nshf);nshift = lshift-fshift+1 (=nshf unless gaps in defined shifts) */ dcl (f, n) fixed bin; ask_shift: call ask_ ("shift(s) ", char32); /* "shift" is optional if we prompted the user */ if substr (char32, 1, 5) = "shift" then goto ask_shift; /* but required if he typed ahead */ nshf = 0; /* initialize counter of specified shifts */ if char32 = "all" then do; /* all defined shifts */ do shift = 0 to 7; if mgt.shift_defined (shift) then do; /* is this one defined? */ nshf = nshf + 1; /* if so, count it */ shf (nshf) = shift; /* and remember its number */ end; end; fshift = shf (1); lshift = shf (nshf); nshift = lshift - fshift + 1; end; else do; /* not "all" so better be a shift number or s1-s2 pair */ if ^ck_int (char32, f, n) then do; /* if not an integer or an s1-s2 pair */ call ioa_ ("bad shift value: ""^a""", char32); call ask_$ask_clr; goto ask_shift; end; nshift = n; /* number of shifts */ fshift = f; /* first one */ lshift = fshift + nshift - 1; /* last one */ do shift = fshift to lshift; /* fill in shift numbers in this range */ if mgt.shift_defined (shift) /* if shift defined */ | shift = fshift | shift = lshift then do; /* or is one of the shifts typed in */ nshf = nshf + 1; shf (nshf) = shift; end; end; end; got_shift_spec = "1"b; /* remember that user gave it and we are not using the default */ mxval = 1; /* we expect one value, to be assigned to all specified shifts */ if nshift > 1 then return; /* provided that more than one shift (m-n) was specified */ /* but if only a single shift number was specified, then a list of values can be given, to be assigned to successive defined shifts, starting with the one given */ mxval = 1; /* initialize counter of how many values could be given */ /* and fall thru, past the set default entry point */ set_default_shift_spec: entry; /* come here to set defaults before seeing what was typed */ /* a single value is assigned to all defined shifts, by default, while the elements of a list of values are assigned to successive shifts */ do shift = fshift + 1 to 7; /* fshift is -1 if we came in at the set default entry */ if mgt.shift_defined (shift) then do; /* find all defined shifts after the specified one */ mxval = mxval + 1; /* count them in mxval */ shf (mxval) = shift; /* and remember their numbers */ end; end; return; end get_shift_spec; /* ****************************************************************************************************************** */ get_values: proc (vtype, prompt, nv); /* procedure to read a list of one or more values, prompting for them if they are not typed ahead. vtype is the value type: 1=integer;2=floating point;3=keyword. prompt is the prompting message. nv is the number of values returned. values are returned in one of the arrays: ival, fval, or bval, depending on vtype. */ dcl prompt char (*); dcl (nv, vtype) fixed bin; dcl i fixed bin; call ask_val (vtype, 1, prompt); nv = 1; /* we have at least one value */ if mxval > 1 then /* if more than one value allowed */ do i = 2 to mxval; /* see if any more values were given */ call ask_$ask_n (char32, flag); /* look ahead without removing next word from line */ if flag ^= 0 & char32 ^= "." & char32 ^= "*" then do; /* if something there, and not terminator char */ call ask_cval (vtype, i, flag); /* see if it is of the right data type */ if flag > 0 then /* if it is, ask_cval has stored it */ nv = nv + 1; /* count it */ end; /* end something there */ end; /* end loop from 2 to mxval */ /* having gotten one or more values, see what we got, and set some variables accordingly */ if nv > 1 then /* if more than one value was given */ nshf = nv; /* remember to set exactly that many values */ else do; /* only one value was given */ if ^got_shift_spec then /* default is "shift all" when one value given */ nshf = mxval; /* so remember to set values for all defined shifts */ if nshf > 1 then /* if we want to assign values for several shifts */ do i = 2 to nshf; /* since we got only one value */ call assign_value (vtype, i, 1); /* make the right number of copies of it */ end; end; return; end get_values; /* ****************************************************************************************************************** */ look_ahead_value: proc (vtype, nv); /* procedure to look ahead on the line for one or more typed ahead values. If none there, nv = 0 on return. If at least one there, get_values is called to get it, and any others that follow it. Values are returned as described under get_values. */ dcl (nv, vtype) fixed bin; nv = 0; /* until we find something */ if vtype = 1 then /* integers */ call ask_$ask_nint (itemp, flag); else if vtype = 2 then /* floating points */ call ask_$ask_nflo (ftemp, flag); else if vtype = 3 then /* keywords */ call ask_nkey (btemp, flag); /* internal procedure */ if flag = 1 then /* if something was there */ call get_values (vtype, "", nv); /* go get it, and others */ return; end look_ahead_value; /* ****************************************************************************************************************** */ prgp: proc (zp); /* procedure to print all information about one group. zp is a pointer to the mgt entry containing the group. */ dcl zp ptr; dcl (ctmp1, ctmp2) char (32) aligned, ii fixed bin; dcl i fixed bin; if zp -> group.minamax < 32767 then call ioa_$rsnnl ("(abs max ^.1f + ^d/^d)", ctmp1, ii, zp -> group.minamax / 1e1, zp -> group.num1, zp -> group.denom1); else ctmp1 = ""; if zp -> group.denom ^= 0 then call ioa_$rsnnl ("+ ^d/^d", ctmp2, ii, zp -> group.num, zp -> group.denom); else ctmp2 = ""; if zp -> group.max_prim < 0 then call ioa_ ("^/^8a^2x-1 ^a", zp -> group.group_id, ctmp1); else call ioa_ ("^/^8a^2x^5.1f ^a ^a", zp -> group.group_id, zp -> group.minu / 1e1, ctmp2, ctmp1); call ioa_ ("int wc: ^8(^d^x^)", zp -> group.int_wc); call ioa_ ("abs wc: ^8(^d^x^)", zp -> group.abs_wc); /* Print lines of the form: absentee: max min pct . MX MN PCT% */ call ioa_ ("absentee:^11tmax^15tmin^19tpct^/^11t^3d^15t^3d^19t^3d%", zp -> group.absentee_max, zp -> group.absentee_min, zp -> group.absentee_pct); if zp -> group.absentee.allowed then call ioa_ ("absentee allowed"); else call ioa_ ("absentee not allowed"); if zp -> group.absentee.default_group then do; call ioa_$nnl ("default group for queues:"); do i = 1 to 4; if zp -> group.absentee.default_queue (i) then call ioa_$nnl ("^x^d", i); end; call ioa_ (""); end; return; end prgp; /* ****************************************************************************************************************** */ print_ivals: proc (which, heading, fmt, ivals); dcl (which, bvals) (0:7) bit (1) unaligned; dcl ivals (0:7) fixed bin; dcl iflts (0:7) fixed bin (17) unaligned; dcl (fmt, heading) char (*); dcl scale float bin; dcl (i, vtype) fixed bin; vtype = 1; goto print_common; /* ********** */ print_iflt: entry (which, heading, fmt, iflts, scale); vtype = 2; goto print_common; /* ********** */ print_bvals: entry (which, heading, fmt, bvals); vtype = 3; goto print_common; /* ********** */ print_shfs: entry (which, heading, fmt); vtype = 4; goto print_common; /* ********** */ print_ivals_check_zero: entry (which, heading, fmt, iflts); vtype = 5; /* ********** */ print_common: call ioa_$nnl (heading); do i = 0 to 7; if which (i) then if vtype = 1 then call ioa_$nnl (fmt, ivals (i)); else if vtype = 2 then call ioa_$nnl (fmt, float (iflts (i)) / scale); else if vtype = 3 then call ioa_$nnl (fmt, bvals (i)); else if vtype = 4 then call ioa_$nnl (fmt, i); else call ioa_$nnl (fmt, (iflts (i) = 0), iflts (i)); /* vtype must be 5 */ end; call ioa_ (""); return; end print_ivals; /* ****************************************************************************************************************** */ prwc: proc (zp); /* procedure to print all information about one work class. zp is a pointer to the mgt entry containing the work class. */ dcl zp ptr; call ioa_$nnl ("^/^2a", zp -> work_class.wc_name); if string (zp -> work_class.switches.defined) = ""b then do; wcundef = "1"b; return; end; call print_shfs (zp -> work_class.switches.defined, "^xdefined on shifts", "^x^5d"); call print_bvals (zp -> work_class.switches.defined, "^4xabsentee allowed", "^[^3xyes^;^4xno^]", zp -> work_class.switches.absentee_allowed); call print_bvals (zp -> work_class.switches.defined, "^16xmode", "^[^4xrt^;^2xnorm^]", zp -> work_class.switches.realtime); call print_ivals (zp -> work_class.switches.defined, "^9xmin percent", "^3x^3d", zp -> work_class.min_pct); call print_ivals_check_zero (zp -> work_class.switches.defined, "^9xmax percent", "^[^6x^1s^;^3x^3d^]", zp -> work_class.max_pct); call print_iflt (zp -> work_class.switches.defined, "^12xint resp", "^x^5.2f", zp -> work_class.int_response, 100e0); call print_iflt (zp -> work_class.switches.defined, "^9xint quantum", "^x^5.2f", zp -> work_class.int_quantum, 100e0); call print_iflt (zp -> work_class.switches.defined, "^16xresp", "^x^5.2f", zp -> work_class.response, 100e0); call print_iflt (zp -> work_class.switches.defined, "^13xquantum", "^x^5.2f", zp -> work_class.quantum, 100e0); return; end prwc; /* ****************************************************************************************************************** */ pxref: proc; /* procedure to print a cross reference of groups and work classes. NOTE: this code assumes that the mgt passes the "verify" checks, and no attempt is made to do anything sensible with an mgt that fails those checks. User documentation emphasizes this. */ /* Scan work classes and groups - see which shifts are used, and if any groups do not allow absentees (forcing them to be moved to other groups) */ print_pct_ignored = ""b; /* turned on if we must print msg explaining asterisk */ no_abs_count = 0; /* count the no-absentee groups, if any */ no_abs = ""b; /* remember if there are any at all */ nshift = 0; /* count shifts used */ shift_used (*) = ""b; /* remember which ones are used */ do i = 1 to 16; /* go thru work classes */ mgtep = addr (mgt.entry (i)); /* get ptr to work class */ do shift = 0 to 7; /* go thru shifts */ if work_class.switches.defined (shift) then shift_used (shift) = "1"b; end; end; do shift = 0 to 7; /* fill in array of shift numbers (for convenience in later code) */ if shift_used (shift) then do; nshift = nshift + 1; /* count shifts used */ shifts (nshift) = shift; /* and save their numbers */ end; end; do i = 17 to mgt.current_size; /* go thru groups */ mgtep = addr (mgt.entry (i)); /* get ptr to group */ if ^group.absentee.allowed then do; /* if it does not allow absentees */ no_abs = "1"b; /* remember that such groups exists */ no_abs_count = no_abs_count + 1; /* and count them */ end; end; /* Print heading */ call ioa_$nnl ("^/Work classes defined on shift(s):"); do i = 1 to nshift; call ioa_$nnl ("^x^d", shifts (i)); end; call ioa_ ("^2/WC^13xGROUP(S)"); /* Initialize for printing cross reference of each shift */ lshift = -1; /* we don't print out identical shifts more than once - we just say "like shift N" */ /* lshift remembers which one it is like, while we see if there are any more like it */ ival (*) = 0; /* we use ival to remember which ones we actually printed out */ /* Outer loop on shifts - but only the ones for which work classes are defined */ do i = 1 to nshift; shift = shifts (i); /* get actual shift number */ /* Check for this shift being like one we already printed */ if lshift >= 0 then do; /* the previous shift we looked at was like one we printed */ if shifts_alike (lshift, shift) then /* if this one is like it too */ if i < nshift then /* and there are more shifts */ goto next_shift; /* go look at next one */ else i = i + 1; /* trick to special case the last one, when the last n shifts are alike (code below says "i-1") */ /* fall thru and print message which includes this shift */ /* This shift is not like the previous one. Print message for previous ones, of the form: shift(s) i j k ... like shift N */ do j = 1 to nshift /* find index of first shift that was like the one printed */ while (shifts (j) ^= fshift); end; if j = i - 1 then /* if just one shift like it */ print_one_alike: call ioa_ ("^5xshift ^d like shift ^d", shifts (j), lshift); else do; call ioa_$nnl ("^5xshifts"); do k = j to i - 1; call ioa_$nnl ("^x^d", shifts (k)); end; call ioa_ ("^xlike shift ^d", lshift); end; if i > nshift then goto next_shift; /* exit, if last n shifts were alike */ end; /* If this shift was not like the previous one, it might still be like one of the others */ lshift = -1; /* start by assuming it isn't */ if i > 1 then /* if there are any others */ do j = 1 to i - 1; /* go thru them */ if ival (shifts (j)) = 1 then /* only look at ones that were printed */ if shifts_alike (shifts (j), shift)/* compare them to this one */ then do; /* if equal */ lshift = shifts (j); /* remember the number of the earlier one */ fshift = shift; /* and remember that this one is the first one like it */ if i = nshift then do; /* special case last one like one other */ j = nshift; /* index of last shift, used for printing it */ i = i + 1; /* force exit from loop */ goto print_one_alike; end; goto next_shift; /* go look at next one */ end; end; /* if we fall thru here, there is no way we can get out of printing this shift */ call ioa_ ("^5xshift ^d", shift); call pxshft (shift); /* go print it */ ival (shift) = 1; /* and remember that we did so */ next_shift: end; if print_pct_ignored then /* if there was a realtime work class */ call ioa_ ("^/* This percent is not counted because the work class is realtime on this shift."); return; /* ********** INTERNAL PROCEDURE WITHIN THIS INTERNAL PROCEDURE ********** */ shifts_alike: proc (s1, s2) returns (bit (1) aligned); /* procedure to determine whether or not two shifts are alike, with respect to work class and load control group definitions */ dcl (s1, s2) fixed bin; dcl i fixed bin; do i = 1 to 16; mgtep = addr (mgt.entry (i)); if work_class.min_pct (s1) ^= work_class.min_pct (s2) then goto diff; if work_class.max_pct (s1) ^= work_class.max_pct (s2) then goto diff; if work_class.switches.defined (s1) ^= work_class.switches.defined (s2) then goto diff; if work_class.switches.absentee_allowed (s1) ^= work_class.switches.absentee_allowed (s2) then goto diff; end; do i = 17 to mgt.current_size; mgtep = addr (mgt.entry (i)); if group.int_wc (s1) ^= group.int_wc (s2) then goto diff; if group.abs_wc (s1) ^= group.abs_wc (s2) then goto diff; end; return ("1"b); /* we were unable to find any differences */ diff: return ("0"b); /* something was different */ end shifts_alike; end pxref; /* ****************************************************************************************************************** */ pxshft: proc (shift); /* procedure to print cross reference for one shift */ dcl shift fixed bin; dcl (i, j, igrp, agrp, dfct, colct) fixed bin; dcl (int, abs, int_abs_diff) bit (1) aligned; dcl print_asterisk bit (1) aligned; do i = 1 to 16; /* go thru work classes, examining and printing each */ mgtep = addr (mgt.entry (i)); if ^work_class.switches.defined (shift) then goto next_wc; /* skip undefined ones */ wcp = mgtep; /* remember the ptr to it */ int_abs_diff = ""b; /* these are per-work class data */ igrp, agrp = 0; default_absentee = "0"b; string (dflt_q) = ""b; do j = 17 to mgt.current_size; /* pre-scan groups to see what we have to print */ mgtep = addr (mgt.entry (j)); if group.int_wc (shift) = i then int = "1"b; else int = ""b; if ^group.absentee.allowed then goto noabs; if group.abs_wc (shift) = i then abs = "1"b; else noabs: abs = ""b; if ^int & ^abs then /* if this group does not use the work class we're printing */ goto next_group; if int ^= abs then int_abs_diff = "1"b; if int then igrp = igrp + 1; /* count interactive groups */ if abs then agrp = agrp + 1; /* count absentee groups */ if group.absentee.default_group then do;/* if this is a default absentee group */ default_absentee = "1"b; /* remember that such a group exists */ string (dflt_q) = string (dflt_q) | string (group.absentee.default_queue); /* remember which queues have defaults */ end; next_group: end; /* end of prescan loop over groups */ if wcp -> work_class.switches.realtime (shift) then /* if realtime */ print_pct_ignored, print_asterisk = "1"b; /* remember to say so */ else print_asterisk = ""b; /* otherwise don't */ /* now print the stuff */ call ioa_$nnl ("^2d^2x^3d^[*^;%^]^[(^3d)^;^5x^1s^]^2x", i, wcp -> work_class.min_pct (shift), print_asterisk, (^print_asterisk & (wcp -> work_class.max_pct (shift) ^= 0)), wcp -> work_class.max_pct (shift)); if igrp > 0 then do; /* if any interactive groups in this work class */ if int_abs_diff then call ioa_$nnl ("int^x"); else call ioa_$nnl ("i&a^x"); call pxgrps (igrp, 1); /* go print igrp interactive groups */ end; if agrp > 0 & int_abs_diff then do; /* if absentees not identical to interactives */ if igrp > 0 then call ioa_$nnl ("^10xabs^x"); /* if we printed interactives */ else call ioa_$nnl ("abs^x"); call pxgrps (agrp, 2); /* go print agrp absentee groups */ end; else if igrp = 0 then /* if neither interactive nor absentee groups in this wc */ call ioa_ (""); /* get back to left margin - last call was to ioa_$nnl */ if default_absentee then do; /* if a default absentee group is in this work class */ call ioa_$nnl ("^2xq"); /* print which ^2xqueues */ dfct = 0; colct = 0; do j = 1 to 4; /* go over the queues */ if dflt_q (j) then do; dfct = dfct + 1; if dfct = 1 then goto prq; /* go print q number */ if j = 4 then do; /* if last one */ j = 5; /* tricky */ goto prq; /* prq says "j-1" */ end; end; else if dfct = 1 then dfct = 0; /* previous q but not this one */ else if dfct > 0 then do; /* previous few queues - print the last one */ prq: colct = colct + 2; /* count cols, for later spacing to next field */ if dfct > 2 then /* if more than 2 queues */ call ioa_$nnl ("-^d", j - 1); /* print "m-n" */ else call ioa_$nnl ("^x^d", j); /* just print a queue */ if dfct > 1 then dfct = 0; /* previous queues but not this one */ end; end; colct = 11 - colct + 1; /* number of columns left to get to next field */ call ioa_$nnl ("^vxdflt", colct); call pxgrps (no_abs_count, 3); /* go print groups whose absentees get put into this work class */ end; next_wc: end; /* ********** INTERNAL PROCEDURE WITHIN THIS INTERNAL PROCEDURE ********** */ pxgrps: proc (ngroups, type); /* procedure to print ngroups group names, that fit into the category specified by type. type can be 1, 2, or 3, indicating interactive, absentee, and default absentee groups, respectively. names are printed four per line, starting in column 16 */ dcl (ngroups, type) fixed bin; dcl (lct, gct) fixed bin; gct, lct = 0; /* initialize group and groups-per-line counters */ do j = 17 to mgt.current_size; mgtep = addr (mgt.entry (j)); if type = 1 then do; /* interactive */ if group.int_wc (shift) = i then goto prgp; else goto skip_grp; end; else if type = 2 then do; /* absentee */ if group.abs_wc (shift) = i then goto prgp; else goto skip_grp; end; else if type = 3 then do; /* default absentee */ if ^group.absentee.allowed then /* if absentees not allowed in this group */ goto prgp; /* they will have to be moved to a default absentee group */ else goto skip_grp; end; prgp: gct = gct + 1; /* count groups printed */ lct = lct + 1; /* count groups on this line */ if lct >= 5 then do; lct = 1; call ioa_$nnl ("^/^14x"); end; call ioa_$nnl ("^x^8a", group.group_id); skip_grp: if gct >= ngroups then goto ret; /* quit as soon as all groups are printed */ end; ret: if lct > 0 | gct = 0 then call ioa_ (""); /* carriage return, if we have printed part of a line */ return; end pxgrps; end pxshft; /* ****************************************************************************************************************** */ scan_key: proc (keys, comma_count, bval, flag); dcl keys char (*); dcl key char (32) varying; dcl (comma_count, flag) fixed bin; dcl bval bit (1) aligned; dcl (comma_offset, curpos, keypos, kln, ln, n_commas) fixed bin; kln = length (keys); ln = length (char32) + 1 - verify (reverse (char32), " "); /* 1 nonblank gives 32+1-32=1 */ /* See if given keyword is one of the legal ones, and if so, get its position in the set of legal ones */ key = "," || substr (char32, 1, ln) || ","; /* to force match only on word delimited by commas */ if keys = substr (key, 2, kln) then keypos = 1; /* trivial case - only one legal keyword */ else if ln + 1 > kln then keypos = 0; /* keyword plus one comma longer than keys - no match possible */ else if substr (keys, 1, ln + 1) = substr (key, 2, ln + 1) then /* first legal keyword has no leading comma */ keypos = 1; else if substr (keys, kln - ln, ln + 1) = substr (key, 1, ln + 1) then /* last one has no trailing comma */ keypos = kln - ln + 1; else if ln + 2 > kln then keypos = 0; /* keyword plus two commas too long - no match possible */ else do; /* scan for match within legal keyword string */ keypos = index (keys, key); if keypos > 0 then /* if we found a match */ keypos = keypos + 1; /* move past the leading comma */ end; if keypos = 0 then /* if no match */ flag = 0; /* tell caller, and do nothing else */ else do; /* keyword legal, so see if it corresponds to "1"b or "0"b */ flag = 1; /* tell caller */ n_commas = 0; /* count commas before the matching key */ curpos = 1; /* start at beginning of first key */ do while (curpos < keypos); /* keep looking until we hit the matching key */ comma_offset = index (substr (keys, curpos, keypos - curpos), ","); /* look for comma */ if comma_offset > 0 then do; /* if we found one */ n_commas = n_commas + 1; /* count it */ curpos = curpos + comma_offset; /* move past it */ end; end; /* fall thru when curpos >= keypos */ if n_commas < comma_count then /* if the matching key is in the first half */ bval = "1"b; /* the keyword corresponds to "1"b */ else bval = "0"b; /* if in the second half, "0"b */ end; return; end scan_key; /* ****************************************************************************************************************** */ shift_is_defined: proc (sh) returns (bit (1) aligned); dcl sh fixed bin; dcl i fixed bin; do i = 1 to 16 /* look thru all work classes */ while (^addr (mgt.entry (i)) -> work_class.switches.defined (sh)); end; /* to see if any are defined on the specified shift */ if i <= 16 then /* if any are */ return ("1"b); /* say yes */ else return (""b); /* else say no */ end shift_is_defined; /* ****************************************************************************************************************** */ undefine_shift: proc (sh); dcl sh fixed bin; dcl i fixed bin; call undefine_wc (sh, 1, 16); /* undefine work classes 1-16 on this shift */ do i = 17 to mgt.current_size; /* undefine all groups on this shift */ mgtep = addr (mgt.entry (i)); group.int_wc (sh) = 0; group.abs_wc (sh) = 0; end; return; end undefine_shift; /* ****************************************************************************************************************** */ undefine_wc: proc (sh, ft, lt); dcl (ft, lt, sh) fixed bin; dcl i fixed bin; do i = ft to lt; mgtep = addr (mgt.entry (i)); work_class.switches.defined (sh) = ""b; work_class.switches.absentee_allowed (sh) = ""b; work_class.switches.realtime (sh) = ""b; work_class.min_pct (sh) = 0; work_class.max_pct (sh) = 0; work_class.int_response (sh) = 0; work_class.int_quantum (sh) = 0; work_class.response (sh) = 0; work_class.quantum (sh) = 0; end; return; end undefine_wc; /* ****************************************************************************************************************** */ verify_mgt: proc; /* procedure to verify the correctness and consistency of the mgt, and report all errors it finds */ dcl err_max fixed bin init (5); dcl err_count fixed bin init (0); dcl warning_printed bit (1) aligned; dcl wc_printed bit (1) aligned; dcl low_pct (0:7) bit (1) aligned; dcl unused_pct (0:7) bit (1) aligned; dcl print_unused_pct bit (1) aligned; dcl pct_is_used bit (1) aligned; dcl wc_empty (0:7, 16) bit (1) aligned; wc_empty = ""b; /* array initializations */ low_pct = ""b; call ask_$ask_cint (itemp, flag); /* check for optional max error count */ if flag > 0 then err_max = itemp; /* if given, override default with it */ /* The following code makes the same correctness tests that up_mgt_ makes, but when it finds an error, it reports it in more detail, and keeps going instead of quitting at the first error. */ do shift = 0 to 7; /* check consistency on each shift */ shift_used (shift) = ""b; /* remember which shifts are used */ shift_pct = 0; /* sum of percentages */ no_abs = ""b; string (dflt_q) = ""b; /* keep track of absentee groups */ unused_pct (shift) = ""b; /* keep track of pcts unused because of deadline or realtime scheduling */ do i = 1 to 16; /* first go thru work classes */ /* checking if defined, and adding up percentages */ wcp = addr (mgt.entry (i)); if wcp -> work_class.switches.defined (shift) then do; /* if defined */ wc_empty (shift, i) = "1"b; /* since wc defined on shift, see if it is used */ /* assume it is not used until we see that it is */ shift_used (shift) = "1"b; /* at least one is, on this shift */ if mgt.switches.deadline_mode (shift) | wcp -> work_class.switches.realtime (shift) then do; pct_is_used = ""b; /* remember not to count this one's percent */ unused_pct (shift) = "1"b; /* remember to explain, if % < 100 on this shift */ end; else pct_is_used = "1"b; /* remember to add in this one's percent */ if wcp -> work_class.min_pct (shift) <= 0 then do; call ioa_ ("bad percent (^d) for work class ^d on shift ^d", wcp -> work_class.min_pct (shift), i, shift); if ^pct_is_used then call ioa_ ("(percent is ignored for realtime workclass, but must be > 0 to install MGT.)"); call count_error; end; if wcp -> work_class.max_pct (shift) < 0 | wcp -> work_class.max_pct (shift) > 100 then do; call ioa_ ("bad max percent (^d) for work class ^d on shift ^d", wcp -> work_class.max_pct (shift), i, shift); call count_error; end; call check_rq (wcp -> work_class.int_quantum (shift), "010"b); /* resp=0;int=1;realtm=0 */ call check_rq (wcp -> work_class.quantum (shift), "000"b); /* resp=0;int=0;realtm=0 */ if wcp -> work_class.switches.realtime (shift) then do; /* if realtime work class */ call check_rq (wcp -> work_class.int_response (shift), "111"b); /* resp=1;int=1;realtm=1 */ call check_rq (wcp -> work_class.response (shift), "101"b); /* resp=1;int=0;realtm=1 */ end; if pct_is_used then /* except for realtime work classes */ shift_pct = shift_pct + wcp -> work_class.min_pct (shift); /* add up percentages */ end; end; /* end loop on work classes */ if shift_pct > 100 then do; call ioa_ ("sum of work class percents > 100 (^d) on shift ^d", shift_pct, shift); call count_error; end; else if shift_used (shift) then if shift_pct < 100 then low_pct (shift) = "1"b; do i = 17 to mgt.current_size; /* now go thru all groups */ mgtep = addr (mgt.entry (i)); if ^shift_used (shift) then do; /* if no work classes defined on this shift */ if group.int_wc (shift) ^= 0 then call shift_err_int; /* there better be no work classes used */ if group.abs_wc (shift) ^= 0 then call shift_err_abs; end; else do; /* some work classes are defined */ wc_empty (shift, group.int_wc (shift)) = "0"b; /* not empty */ wcp = addr (mgt.entry (group.int_wc (shift))); if ^wcp -> work_class.switches.defined (shift) then /* see if this one is */ call shift_err_int; /* and complain if not */ if group.absentee.allowed then do; /* if absentees allowed in this group */ wc_empty (shift, group.abs_wc (shift)) = "0"b; /* not empty */ wcp = addr (mgt.entry (group.abs_wc (shift))); if ^wcp -> work_class.switches.defined (shift) then /* make sure their work class is defined */ call shift_err_abs; /* and complain if not */ if ^wcp -> work_class.switches.absentee_allowed (shift) then do; call ioa_ ("group ""^a"" absentees on shift ^d are in work class ^d, but that work class does not allow absentees", group.group_id, shift, group.abs_wc (shift)); call count_error; end; if group.absentee.default_group then do; /* if this is a default group for some queue(s) */ do j = 1 to 4; /* go thru queues */ if group.absentee.default_queue (j) then /* if it is for this queue */ if dflt_q (j) then do; /* but there already is one */ call ioa_ ("more than one default group for absentee queue ^d: group ""^a"" is an additional one (group ""^a"" is the first one)", j, group.group_id, addr (mgt.entry (dflt_g (j))) -> group.group_id); call count_error; end; else do; /* otherwise, remember that we have a default for this queue */ dflt_q (j) = "1"b; dflt_g (j) = i; end; /* and remember which group, for possible error message */ end; end; end; /* end absentee allowed */ else do; /* absentee not allowed in this group */ no_abs = "1"b; /* remember that there is such a group */ if group.absentee.default_group then do; call ioa_ ("group ""^a"" does not allow absentees, but is given as the default group for absentee queue ^d", group.group_id, j); call count_error; end; end; /* end absentees not allowed */ end; /* end some work classes defined on this shift */ end; /* end loop thru all groups */ if no_abs then /* if a no-absentee group exists */ if string (dflt_q) ^= "1111"b then do; /* and there are not default groups for all queues */ do j = 1 to 4; /* print message for each queue */ if ^dflt_q (j) then do; call ioa_ ("There is no default group for absentee queue ^d, but there is a group that does not allow absentees", j); call count_error; end; end; end; end; /* end loop on shifts */ do i = 17 to mgt.current_size; /* make a last pass thru groups, checking group only parameters */ mgtep = addr (mgt.entry (i)); if group.absentee_pct < 0 | group.absentee_pct > 100 then do; call ioa_ ("illegal absentee percent (^d%) for group ""^a""", group.absentee_pct, group.group_id); call count_error; end; if group.absentee_min > group.absentee_max then do; call ioa_ ("absentee_min (^d) greater than absentee_max (^d) for group ""^a""", group.absentee_min, group.absentee_max, group.group_id); call count_error; end; if group.absentee_max < 0 then do; call ioa_ ("absentee_max (^d) for group ""^a"" is negative.", group.absentee_max, group.group_id); call count_error; end; end; if err_count = 0 then call ioa_ ("No errors"); else call ioa_ ("^d errors - the mgt can not be installed", err_count); /* Check for suspicious-looking conditions, that are not fatal errors, but are likely to be oversignts on the part of the user */ warning_printed = "0"b; /* remember that we have not printed a heading line */ print_unused_pct = ""b; /* stays off unless we print a * beside some shift */ do shift = 0 to 7; /* check for sum of percents < 100% on any shift */ if low_pct (shift) /* look for first such shift */ & ^mgt.switches.deadline_mode (shift) then do; /* except realtime shifts, whose pcts aren't used */ call print_warning; /* go print heading, if not already done */ call ioa_$nnl ("Sum of work class percents is < 100% on shift(s):"); do shift = shift to 7; /* go thru shifts from this one to last */ if low_pct (shift) then do; call ioa_$nnl ("^x^d^[*^]", shift, unused_pct (shift)); if unused_pct (shift) then print_unused_pct = "1"b; /* remember to explain the * */ end; end; if print_unused_pct then /* if we put asterisks beside some shifts, explain them */ call ioa_ ("^/* There are realtime work classes in this shift; their percents are not counted."); call ioa_ (""); end; end; /* inner loop runs the index of this one out to its limit */ wc_printed = ""b; /* remember we have not printed wc heading */ do shift = 0 to 7; /* check for wc with no groups in it */ do i = 1 to 16; if wc_empty (shift, i) then do; /* search for first such occurrence */ call print_warning; if ^wc_printed then do; wc_printed = "1"b; call ioa_ ("The following work class(es) are unused on the indicated shifts"); end; call ioa_$nnl ("shift ^d: ", shift); do i = i to 16; /* go thru work classes from this one to last */ if wc_empty (shift, i) then call ioa_$nnl ("^x^d", i); end; call ioa_ (""); end; end; /* inner loop runs the index of this one out to its limit */ end; /* end loop on shifts */ do shift = 0 to 7; do i = 1 to 16; wcp = addr (mgt.entry (i)); if wcp -> work_class.switches.defined (shift) & ^wcp -> work_class.switches.realtime (shift) then do; call check_rq (wcp -> work_class.int_response (shift), "110"b); call check_rq (wcp -> work_class.response (shift), "100"b); end; end; end; do i = 17 to mgt.current_size; /* check for reasonable absentee user limits */ mgtep = addr (mgt.entry (i)); if group.absentee_max = 0 /* if max is zero */ & ^(group.absentee_min = 0 /* and min and percent are not */ & group.absentee_pct = 0) then do; /* both zero, no absentee jobs for the group can log in */ call print_warning; /* print warning heading if not already done */ call ioa_ ("group ""^a"": absentee_max=^d, absentee_min=^d, absentee_pct=^d%, so jobs from this group will never log in.", group.group_id, group.absentee_max, group.absentee_min, group.absentee_pct); end; end; verify_exit: return; /* ********** INTERNAL PROCEDURES WITHIN THIS INTERNAL PROCEDURE ********** */ check_rq: proc (val, sw); /* check response and quantum values */ dcl val fixed bin (17) unaligned; dcl sw bit (3) unaligned; dcl resp bit (1) unaligned defined (sw) pos (1); dcl int bit (1) unaligned defined (sw) pos (2); dcl realtm bit (1) unaligned defined (sw) pos (3); if val > 0 then return; /* positive value is ok for anything */ if resp & val = 0 then return; /* zero is ok for realtime response */ /* quantum must always be >0 */ /* realtime response must >= 0 */ /* nonrealtime response should be >= 0, but we only give warning if it is negative */ if resp & ^realtm then /* if just a warning */ call print_warning; /* tell user so */ else call count_error; /* otherwise increment fatal error count */ call ioa_ ("^[^;zero or ^]negative ^[int_^]^[response^;quantum^] (^.2f) for ^[realtime ^]work class ^d on shift ^d", realtm, int, resp, float (val) / 100e0, realtm, i, shift); return; end check_rq; /* ********** ********** */ print_warning: proc; if ^warning_printed then do; call ioa_ ("Warnings (will not prevent installation of MGT):"); warning_printed = "1"b; end; return; end print_warning; /* ********** ********** */ shift_err_int: proc; dcl wc fixed bin; dcl ia char (11); /* interactive or absentee */ wc = group.int_wc (shift); ia = "interactive"; shift_err_common: if wc = 0 then call ioa_ ("^a work class of group ""^a"" on shift ^d is undefined (=0), but work classes are defined on that shift", ia, group.group_id, shift); else call ioa_ ("work class ^d is undefined on shift ^d but is used by group ""^a"" (^a)", wc, shift, group.group_id, ia); call count_error; return; shift_err_abs: entry; wc = group.abs_wc (shift); ia = "absentee"; goto shift_err_common; end shift_err_int; /* ********** ********** */ count_error: proc; err_count = err_count + 1; if mod (err_count, err_max) = 0 then do; call ask_$ask_yn ("^d errors - do you wish to continue? ", char32, err_count); if char32 = "no" then goto verify_exit; /* nonlocal goto */ end; return; end count_error; end verify_mgt; initialize_mgt: procedure; dcl wcx fixed bin; mgt.author.proc_group_id = get_group_id_ (); mgt.table = "MGT"; mgt.w_dir = get_wdir_ (); mgt.max_size = hbound (mgt.entry, 1); mgt.current_size = 17; /* start with WCTE's */ mgt.total_units = 0; mgt.version_indicator = "VERSION "; mgt.version = MGT_version_3; mgt.wc_initialized = "0"b; mgt.prio_sked_enabled = "1"b; mgt.prio_sked_on_tape = "1"b; do wcx = 1 to 16; mgtep = addr (mgt.entry (wcx)); work_class.wc_name = ltrim (char (wcx)); end; string (mgt.user_wc_defined) = "100000000000000"b; string (mgt.shift_defined) = (8)"1"b; /* define all shifts */ mgt.user_wc_min_pct = 100; /**** We will define one work-class and one group */ mgtep = addr (mgt.entry (1)); work_class.switches.defined (*) = "1"b; /* defined on all shifts */ work_class.switches.absentee_allowed (*) = "1"b; /* with absentee allowed */ work_class.min_pct (*) = 100; /* and getting all the time */ work_class.min_pct (*) = 100; work_class.int_response (*) = 400; work_class.int_quantum (*) = 50; work_class.response (*) = 3200; work_class.quantum (*) = 100; mgtep = addr (mgt.entry (17)); group.group_id = "Other"; group.max_prim = -1; group.int_wc = 1; group.abs_wc = 1; group.absentee.allowed = "1"b; group.absentee_max = 1000; group.absentee_pct = 100; return; end initialize_mgt; clean_up: procedure; if mgtp ^= null () then call release_temp_segment_ (ME, mgtp, (0)); if mgtp1 ^= null () then if created_new_mgt then call terminate_file_ (mgtp1, (0), TERM_FILE_DELETE, (0)); else call terminate_file_ (mgtp1, 36 * (64 + mgtp1 -> mgt.current_size * 32), TERM_FILE_TRUNC_BC_TERM, (0)); return; end clean_up; end ed_mgt;  get_uid_with_lastname.pl1 10/27/83 1614.3rew 10/27/83 1441.8 20583 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ get_uid_with_lastname: procedure (Name); declare Name character (*) parameter; /* Originally written April 1971 by K. Willis. */ /* Rewritten for new URF format July 1979 by C. Hornig. */ /* This procedure lists all users with a given last name. */ %include urf_entry; declare ME character (32) init ("get_uid_with_lastname") static options (constant); declare (error_table_$bad_index, error_table_$no_record) fixed bin (35) external; declare cu_$arg_count entry returns (fixed bin), urf_manager_$get_abs_entry entry (fixed bin (35), character (*), pointer, fixed bin (35)), (ioa_, com_err_) entry options (variable); declare code fixed bin (35), rec fixed bin (35), count fixed bin (35), uid character (32), 1 urfe aligned like urf_entry; declare addr builtin; /* * * * * * * * * * GET_UID_WITH_LASTNAME * * * * * * * * * */ if cu_$arg_count () ^= 1 then do; call com_err_ (0, ME, "Usage: get_uid_with_lastname "); return; end; count = 0; do rec = 1 by 1; call urf_manager_$get_abs_entry (rec, uid, addr (urfe), code); if code ^= error_table_$no_record then if code ^= 0 then do; if code ^= error_table_$bad_index then call com_err_ (code, ME); else if count = 0 then call ioa_ ("No users found with last name of ""^a"".", Name); else call ioa_ ("^d users found with last name of ""^a"".", count, Name); return; end; else if ((substr (urfe.last_name, 1, 1) = "*") & (substr (urfe.last_name, 2) = Name)) | (urfe.last_name = Name) then do; call ioa_ ("User ID for ^a, ^a is ""^a"".", urfe.last_name, urfe.first_name, uid); count = count + 1; end; end; end get_uid_with_lastname;  get_user_.pl1 07/13/88 1112.5r w 07/13/88 0942.4 40293 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* program to return the name and project of each user registered on the Multics system */ /* j m grochow 7/23/70 */ /* upgraded to version II pl1 and modified for new SAT / PDT formats by Janice B. Phillipps, March 1972 */ guinit: proc(dirname, code); dcl ( (satp, /* pointer to the sat */ satep, pdtep, pdtp) ptr, /* pointer to the pdt */ (satsize, /* current size of the sat */ satindex, /* where are we now */ pdtsize, /* current size of the pdt */ pdtindex) fixed bin, /* where are we now */ (projectname char(9), /* save the current projectname */ dirnamepdt char(168)) aligned /* directory name which contains pdt's */ ) internal static; /* all internal static */ dcl ioa_ external entry options(variable), com_err_ external entry options (variable), hcs_$initiate external entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin), hcs_$terminate_noname external entry (ptr, fixed bin); dcl (null, addr, substr, fixed, index) builtin; dcl p ptr, i fixed bin; dcl (person, proj) char(*); dcl dirname char(*) aligned; dcl code fixed bin; %include user_attributes; %include sat; %include pdt; /* ======================================================== */ call hcs_$initiate(dirname, "sat", "", 0, 1, satp, code); if satp = null then do; if code = 0 then code = 1; return; end; if satp -> sat.version ^= SAT_version then do; call com_err_ (0, "get_user_", "SAT version is inconsistent with declarations used by this program."); return; end; satsize = satp->sat.current_size; satindex = 1; dirnamepdt = dirname; substr(dirnamepdt, index(dirnamepdt, " "), 4) = ">pdt"; call initpdt; /* get the first pdt */ return; get_user_: entry(person, proj); beginloop: do i = pdtindex to pdtsize; p = addr(pdtp->pdt.user(i)); if p->user.state = 0 then go to endloop; person = p->user.person_id; /* person's name */ proj = projectname; /* the current project */ pdtindex = i+1; return; endloop: end; /* if we fall through, get another pdt */ call hcs_$terminate_noname (pdtp, code); /* terminate the current pdt */ call initpdt; if projectname = " " then do; /* no more pdt's */ person = " "; proj = " "; call hcs_$terminate_noname (pdtp, code); /* terminate last pdt */ call hcs_$terminate_noname (satp, code); /* terminate sat */ return; end; go to beginloop; /* internal entry to get another pdt */ initpdt: proc; dcl projfile char(32) aligned, /* name of project pdt file */ code fixed bin; /* for error codes */ dcl com_err_ external entry options (variable); dcl (null, addr, substr, fixed) builtin; do i = satindex to satsize; p = addr(satp->sat.project(i)); if p->project.state = 0 then go to endloop1; projfile = substr(p->project.project_id, 1, index(p->project.project_id, " ")-1)||".pdt"; call hcs_$initiate(dirnamepdt, projfile, "", 0, 1, pdtp, code); if pdtp = null then do; call ioa_("The following pdt could not be initiated: ^a>^a", dirnamepdt, projfile); go to endloop1; end; if pdtp -> pdt.version ^= PDT_version then do; call com_err_ (0, "get_user_", "PDT version is inconsistent with the declarations used by this program."); return; end; projectname = p->project.project_id; pdtsize = pdtp->pdt.current_size; pdtindex = 1; satindex = i+1; return; endloop1: end; /* if we fall through, no more pdt's */ projectname = " "; return; end initpdt; end guinit;  get_userid_.pl1 07/13/88 1112.5r w 07/13/88 0938.6 42750 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ get_userid_: proc (procid, pers, proj, type, anon, ecode); /* GET_USERID_ - program to find out who a user is, given process id. */ /* Modified November 1981, E. N. Kittlitz. user_table_entry conversion. */ /****^ HISTORY COMMENTS: 1) change(87-04-26,GDixon), approve(87-07-09,MCR7741), audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1 and user_table_entry.incl.pl1 2) change(87-05-31,GDixon), approve(87-07-09,MCR7719), audit(87-07-13,Hartogs), install(87-08-04,MR12.1-1055): Add $info entrypoint. END HISTORY COMMENTS */ dcl procid bit (36), /* input process id */ pers char (*), /* output person id */ proj char (*), /* output project id */ tag char (*), /* output instance tag */ process_type fixed bin, /* output process type */ abs_queue fixed bin, /* output absentee queue, 0 = fg */ type fixed bin, /* 0 = interactive, -1 daemon, >0 abs queue */ anon fixed bin, /* 1 if anonymous, else 0 */ ecode fixed bin (35); dcl ec fixed bin (35), i fixed bin, info_entry bit(1); dcl (static_ansp, static_autp, static_dutp) ptr int static init(null); dcl sysdir char (64) aligned int static options(constant) init (">system_control_dir"); dcl (addr, null) builtin; dcl hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl error_table_$noentry fixed bin(35) ext static; /* --------------------------------------------- */ info_entry = "0"b; go to JOIN; info: entry (procid, pers, proj, tag, process_type, anon, abs_queue, ecode); info_entry = "1"b; JOIN: ecode = 0; if static_ansp = null then call hcs_$initiate (sysdir, "answer_table", "", 0, 1, static_ansp, ec); if static_autp = null then call hcs_$initiate (sysdir, "absentee_user_table", "", 0, 1, static_autp, ec); if static_dutp = null then call hcs_$initiate (sysdir, "daemon_user_table", "", 0, 1, static_dutp, ec); ansp = static_ansp; autp = static_autp; dutp = static_dutp; if ansp = null & autp = null & dutp = null then do; ecode = ec; return; end; if ansp ^= null then do; do i = 1 to anstbl.current_size; utep = addr (anstbl.entry (i)); if ute.active >= NOW_HAS_PROCESS then do; if ute.proc_id = procid then do; pers = ute.person; proj = ute.project; if info_entry then do; tag = ute.tag; process_type = ute.process_type; abs_queue = 0; end; else type = ute.queue; anon = ute.anonymous; return; end; end; end; end; if autp ^= null then do; /* check access to table */ do i = 1 to autp -> autbl.current_size while (autp -> autbl.n_abs_run > 0); utep = addr (autp -> autbl.entry (i)); if ute.active >= NOW_HAS_PROCESS then do; if ute.proc_id = procid then do; pers = ute.person; proj = ute.project; if info_entry then do; tag = ute.tag; process_type = ute.process_type; abs_queue = ute.queue; end; else type = ute.queue; anon = ute.anonymous; return; end; end; end; end; /* end of autbl search */ if dutp ^= null then do; do i = 1 to dutbl.current_size; utep = addr (dutbl.entry (i)); if ute.active >= NOW_HAS_PROCESS then do; if ute.proc_id = procid then do; pers = ute.person; proj = ute.project; if info_entry then do; tag = ute.tag; process_type = ute.process_type; abs_queue = 0; end; else type = ute.queue; anon = ute.anonymous; return; end; end; end; end; /* end daemon table search */ ecode = error_table_$noentry; %page; %include absentee_user_table; %page; %include answer_table; %page; %include daemon_user_table; %page; %include dialup_values; %page; %include user_attributes; %page; %include user_table_entry; %page; %include user_table_header; end get_userid_;  hash_table.pl1 10/27/83 1614.3rew 10/27/83 1441.9 88920 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ %; /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ hash_table: proc; /* originally coded by k.willis 2/71 */ %include hashst; dcl htp pointer; /* hash table pointer */ dcl buffer char (152), /* input buffer string */ 1 input based (ip), /* input character array-overlays buffer */ 2 line (0: 151) char (1) unaligned, (ip, q, ap) pointer, abuffer char (152) aligned, bit_count fixed bin (24), /* number of bits in hash table */ len fixed bin, /* length of argument from console */ more_needed bit (1), /* switch that indicates expected argument when on */ (val, i, j, count, ec, al, buckets) fixed bin, bc fixed bin init (152), /* number of characters in input line */ hash_$in entry (ptr, char (*) aligned, fixed bin, fixed bin), hash_$out entry (ptr, char (*) aligned, fixed bin, fixed bin), hash_$search entry (ptr, char (*) aligned, fixed bin, fixed bin), hash_$make entry (ptr, fixed bin, fixed bin), ios_$read_ptr entry (ptr, fixed bin (17), fixed bin (17)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), aa fixed bin (35), bchr char (al) based (ap) unaligned, /* character string for command args */ (error_table_$segknown, error_table_$namedup, error_table_$noarg, error_table_$invalid_elsize) ext fixed bin (17), error_table_$full_hashtbl ext fixed bin (17), path char (168) aligned, expand_path_ entry (ptr, fixed bin (17), ptr, ptr, fixed bin (17)), com_err_ entry options (variable), ioa_ entry options (variable), hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin), hcs_$set_bc entry (char (*) aligned, char (*) aligned, fixed bin (24), fixed bin), term_ entry (char (*) aligned, char (*) aligned, fixed bin), cv_dec_ entry (char (*) aligned) returns (fixed bin (35)), dn char (168) aligned, /* directory name */ en char (32) aligned, /* entry name */ chr char (1) aligned, /* request code */ getback label local, (srchname, addname) char (32) aligned; /* entry name and value to be passed to hash_ */ dcl default fixed bin init (995), /* size of hash table if none given */ max fixed bin init (6552); /* max number of buckets that will fit in one segment */ dcl (substr, null, addr) builtin; /* the hash_table command is used to create a hash table and to insert, delete, and search for entries in it. usage: hash_table path -nb- where "path" specifies the name of an existing hash table or the name to be given to the hash table created with "nb" buckets or entries. if "nb" is not specifiedor not within bounds(0 bchr, 1, al)); /* convert the decimal number to binary */ if aa <= 0 then buckets = default; /* check range of buckets */ else if aa>max then do; buckets = max; /* buckets cannot be more than will fit in 1 segment */ call ioa_ ("too many buckets: ^d maximum", max); /* print console message */ end; else buckets = aa; /* change precision of valid number of buckets */ end; bit_count = 36* (buckets*10+8); /* there are 36 bits in each word and 10 words in each bucket with 8 at top */ call hcs_$set_bc (dn, en, bit_count, ec); /* set the bit count of segment created */ if ec ^= 0 then go to err; call hash_$make (q, buckets, ec); /* this entry initializes the created hash table */ if ec ^= 0 then go to err; end; ip = addr (buffer); /* common to existing and new hash tables */ next: call ios_$read_ptr (ip, bc, count); /* get request */ if count = 1 then go to next; /* nl character-try again */ abuffer = buffer; /* align input */ chr = substr (abuffer, 1, 1); /* treat first character as request code */ if chr = "q" then do; /* quit */ call term_ (dn, en, ec); /* remove segment from address space */ if ec ^= 0 then go to err; return; /* return to caller */ end; j = 1; /* the next char examined in input will be the second(input.line(j)) */ more_needed = "1"b; /* 1 argument must be present */ if chr = "s" then do; /* search */ getback = s; /* set return label to s */ go to getarg; /* get first argument */ s: more_needed = "0"b; /* any further arguments are optional */ call hash_$search (q, srchname, val, ec); /* entry point to find val of srchname */ if ec ^= 0 then go to err2; /* could not find it */ call ioa_ ("'^a' has value ^d", srchname, val); /* print the value */ go to getarg; /* repeat the process if more arguments */ end; if chr = "d" then do; /* delete */ getback = d; /* set ruturn label to d */ go to getarg; /* get first argument */ d: more_needed = "0"b; /* any further arguments are optional */ call hash_$out (q, srchname, val, ec); /* entry point to delete srchname */ if ec ^= 0 then go to err2; /* could not find it */ else call ioa_ ("'^a' deleted with value ^d", srchname, val); /* print console message */ go to getarg; /* repeat the process for any remaining arguments */ end; if chr = "a" then do; /* insert */ getback = a; /* set return label to a */ go to getarg; /* get first argument */ a: more_needed = "1"b; /* two arguments are required for "a" and others must be in pairs */ addname = srchname; /* save entry name in addname */ getback = a2; /* set return label to a2 */ go to getarg; /* get value corresponding to addname */ a2: more_needed = "0"b; /* another argument is not required */ aa = cv_dec_ (srchname); /* convert value to binary */ val = aa; /* change the precision */ call hash_$in (q, addname, val, ec); /* entry point to insert the entry and value in hash table */ getback = a; if ec = 0 then go to getarg; /* get any remaining arguments */ go to err2; end; call ioa_ ("'^a' not a hash_table request", chr); /* invalid request */ go to next; /* try again */ getarg: do i = j to count-2 while (ip -> input.line (i) = " "); /* set i to point to first char in name and j to blank after */ end; /* i points to first nonblank character */ if i>count-2 then do; /* no argument existed */ if more_needed then go to err1; /* print error message if argument expected */ else go to next; /* otherwise get next request */ end; else do j = i+1 to count-2 while (ip -> input.line (j) ^= " "); end; /* j now points to blank after name or nl character */ if j-i>32 then do; /* maximum length of name is 32 characters */ call ioa_ ("'^a' truncated to 32 characters", substr (abuffer, i+1, j-i)); /* print message */ len = 32; /* continue the process with 32 characters */ end; else len = j-i; /* assign len the actual length if <32 characters */ srchname = substr (abuffer, i+1, len); /* put name in srchname */ go to getback; /* return to routine to process srchname */ err1: ec = error_table_$noarg; /* expected argument missing */ call com_err_ (ec, "hash_table", ""); /* common error message routine */ go to next; /* get next request */ err2: if ec = error_table_$full_hashtbl then go to err; /* if hash table was full or inefficient */ call com_err_ (ec, "hash_table", ""); /* print message for all other errors */ go to getarg; /* get any remaining arguments for request */ end hash_table;  hunt.pl1 10/27/83 1614.3rew 10/27/83 1441.9 91179 /* ****************************************************** * * * * * Copyright, (C) Honeywell Information Systems * * Inc., 1980. * * * * * ****************************************************** */ hunt: proc; /* HUNT - find a segment in a given subtree. */ /* Modified 780905 by PG to terminate archive segments when finished with them. */ /* Fixed to find secondary names and check for no r on an archive, 05/10/79 S. Herbst */ /* Changed to call sweep_disk_$dir_list 05/29/79 S. Herbst */ /* MCR 4264 fixed to complain about top node 01/07/80 S. Herbst */ /* Implement as active function and fix for multiple archive names 05/14/80 S. Herbst */ /* Fixed to work on the root 01/12/81 S. Herbst */ /* Fixed not to stall when a damaged archive is hit, LA Newcomb, 3Nov1982 */ /* Fixed to look at archive contents before the addmanes, LA Newcomb, 16Nov1982 */ /* format: style4,indattr,ifthenstmt,ifthen,idind33,^indcomtxt */ %include archive_header; %include branch_status; /* static */ dcl total fixed bin int static; dcl R_ACCESS fixed bin (5) int static options (constant) init (01000b); dcl S_ACCESS fixed bin (5) int static options (constant) init (01000b); dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl dir_path char (168); dcl starname char (32); dcl (af_sw, allsw, archive_sw, firstsw, got_dir, got_starname) bit (1) aligned; dcl (arg_ptr, header_ptr, return_ptr, segp) ptr; dcl seg_mode fixed bin (5); dcl (arg_count, arg_len, i, j, return_len) fixed bin; dcl code fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin (35) ext; dcl error_table_$root fixed bin (35) ext; dcl error_table_$seg_busted fixed bin (35) ext; dcl complain entry variable options (variable); dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable); dcl archive_util_$first_element entry (ptr, fixed bin (35)); dcl archive_util_$next_element entry (ptr, fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl get_wdir_ entry returns (char (168)); dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl (ioa_, ioa_$rsnnl) entry options (variable); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl sweep_disk_$dir_list entry (char (168), entry); dcl (addr, fixed, length, null, rtrim, substr) builtin; dcl (seg_fault_error, cleanup) condition; %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = 0 then do; af_sw = "1"b; complain = active_fnc_err_; return_arg = ""; end; else do; af_sw = "0"b; complain = com_err_; end; allsw, firstsw, got_dir, got_starname = "0"b; archive_sw = "1"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) ^= "-" then if got_dir then do; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, "hunt", "Usage: [hunt starname {root_of_tree} {-control_arg}]"); else call com_err_$suppress_name (0, "hunt", "Usage: hunt starname {root_of_tree} {-control_args}"); return; end; else if got_starname then do; call absolute_pathname_ (arg, dir_path, code); if code ^= 0 then do; call complain (code, "hunt", "^a", arg); return; end; got_dir = "1"b; end; else do; starname = arg; call check_star_name_$entry (starname, code); if code ^= 0 & code ^= 1 & code ^= 2 then do; call complain (code, "hunt", "^a", starname); return; end; got_starname = "1"b; end; /* control arg */ else if arg = "-all" | arg = "-a" then allsw = "1"b; else if arg = "-first" | arg = "-ft" then firstsw = "1"b; else if arg = "-archive" | arg = "-ac" then archive_sw = "1"b; else if arg = "-no_archive" | arg = "-nac" then archive_sw = "0"b; else do; call complain (error_table_$badopt, "hunt", "^a", arg); return; end; end; if ^got_starname then go to USAGE; else if ^got_dir then dir_path = get_wdir_ (); call hcs_$status_ (dir_path, "", 1, addr (branch_status), null, code); if code = error_table_$root then do; code = 0; branch_status.mode = "01000"b; end; if code ^= 0 & code ^= error_table_$no_s_permission & code ^= error_table_$incorrect_access then do; call complain (code, "hunt", "^a", dir_path); return; end; if fixed (branch_status.mode, 5) < S_ACCESS then do; call complain (0, "hunt", "No s permission on ^a", dir_path); return; end; total = 0; segp = null (); /* for cleaning up */ on cleanup begin; if segp ^= null () then call hcs_$terminate_noname (segp, code); end; call sweep_disk_$dir_list (dir_path, counter); bust: if ^af_sw then call ioa_ ("Total ^d", total); return; %page; counter: proc (sdn, sen, lvl, een, bptr, nptr); dcl sdn char (168) aligned, /* superior dir name */ sen char (32) aligned, /* dirname */ lvl fixed bin, /* distance from root */ een char (32), /* entry name */ bptr ptr, /* ptr to info structure */ nptr ptr; /* ptr to names structure */ dcl xp char (168), ename char (32), (ni, xi) fixed bin; dcl 1 branch based (bptr) aligned, /* thing returned by star_long */ 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex bit (18) unal, 2 dtm bit (36) unal, 2 dtu bit (36) unal, 2 mode bit (5) unal, 2 pad bit (13) unal, 2 records bit (18) unal; dcl names (99 /* arbitrary */) char (32) aligned based (nptr); dcl ecc fixed bin (35); dcl ( /* constants */ bty char (4) dim (0:3) init ("link", "seg", "dir", "??"), SEG_TYPE fixed bin init (1) ) int static options (constant); call ioa_$rsnnl ("^a^[>^]^a", xp, xi, sdn, sdn ^= ">", sen); if ^allsw then if fixed (branch.type) ^= SEG_TYPE then return; ecc = 1; /* so loops will start */ %page; if archive_sw then /* we are to check archive components */ if fixed (branch.type) = SEG_TYPE then do; /* archive may only be a segment */ on seg_fault_error begin; /* must handle damaged archives */ call complain (error_table_$seg_busted, "hunt", "^a^[>^]^a", xp, xp ^= ">", ename); go to check_storage_sys_name; end; do ni = 1 to fixed (branch.nname) while (ecc ^= 0); ename = names (fixed (branch.nindex) + ni - 1); j = length (rtrim (ename)); if j > 8 then if substr (ename, j - 7, 8) = ".archive" then do; call hcs_$initiate (xp, ename, "", 0b, 0b, segp, ecc); if segp = null then go to check_storage_sys_name; call hcs_$fs_get_mode (segp, seg_mode, ecc); if ecc ^= 0 then go to terminate_archive; if seg_mode < R_ACCESS then go to terminate_archive; header_ptr = segp; call archive_util_$first_element (header_ptr, ecc); do while (ecc = 0); call match_star_name_ ((header_ptr -> archive_header.name), starname, ecc); if ecc = 0 then do; total = total + 1; if af_sw then do; /* append archive_path::component_name */ if return_arg ^= "" then return_arg = return_arg || " "; if xp = ">" then return_arg = return_arg || ">"; else return_arg = return_arg || rtrim (xp) || ">"; return_arg = return_arg || rtrim (ename); return_arg = return_arg || "::"; return_arg = return_arg || rtrim (header_ptr -> archive_header.name); end; else call ioa_ ("^a ^a^[>^]^a contains ^a", bty (fixed (branch.type)), xp, xp ^= ">", ename, header_ptr -> archive_header.name); if firstsw then do; call hcs_$terminate_noname (segp, ecc); segp = null (); /* so cleanuyp doesn't get a crack at it */ go to bust; end; end; call archive_util_$next_element (header_ptr, ecc); end; terminate_archive: call hcs_$terminate_noname (segp, ecc); segp = null (); go to check_storage_sys_name; /* done with the archive components */ end; end; end; %page; check_storage_sys_name: ecc = 1; /* so loop will go */ do ni = 1 to fixed (branch.nname) while (ecc ^= 0); ename = names (fixed (branch.nindex) + ni - 1); call match_star_name_ (ename, starname, ecc); if ecc = 0 then do; total = total + 1; if af_sw then do; if return_arg ^= "" then return_arg = return_arg || " "; if xp ^= ">" then return_arg = return_arg || rtrim (xp); return_arg = return_arg || ">"; return_arg = return_arg || rtrim (ename); end; else call ioa_ ("^a ^a^[>^]^a", bty (fixed (branch.type)), xp, xp ^= ">", ename); if firstsw then go to bust; end; end; return; end counter; end hunt;  list_as_requests.pl1 08/05/87 0803.1r 08/04/87 1540.6 136899 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(84-12-01,Margulies), approve(), audit(), install(): Pre-hcom comments. Written 1984-12, BIM. Modified 1985-02-20, BIM: For daemon and com channel info requests. 2) change(86-11-24,Lippard), approve(86-11-24,PBF7326), audit(86-11-25,GDixon), install(86-11-25,MR12.0-1224): Modified to handle abs_command AS requests. END HISTORY COMMENTS */ /* list_as_requests: lists and interprets all as requests in the message segment */ /* format: style2,idind30 */ list_as_requests: procedure options (variable); /**** This command is a very simple lister. It lists all requests unless the access present is only sufficient for own access. Fancy control args will just have to wait. */ declare ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); declare ssu_$destroy_invocation entry (ptr); declare ssu_$abort_line entry () options (variable); declare ssu_$arg_count entry (ptr, fixed bin); declare ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); declare com_err_ entry () options (variable); declare cu_$arg_list_ptr entry returns (pointer); declare display_access_class_ entry (bit (72) aligned) returns (character (32) aligned); declare get_user_free_area_ entry returns (pointer); declare ioa_ entry () options (variable); declare message_segment_$read_message_index entry (fixed bin, ptr, ptr, fixed bin (35)); declare message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35)); declare message_segment_$close entry (fixed bin, fixed bin (35)); declare message_segment_$get_mode_index entry (fixed bin, bit (36) aligned, fixed bin (35)); declare request_id_ entry (fixed binary (71)) returns (character (19)); declare requote_string_ entry (character (*)) returns (character (*)); declare system_info_$request_chn entry (bit (36) aligned, fixed bin (71), char (*), char (*)); declare expand_pathname_$add_suffix entry (character (*), character (*), character (*), character (*), fixed binary (35)); declare error_table_$noarg fixed bin (35) ext static; declare error_table_$badopt fixed bin (35) ext static; declare argx fixed bin; declare arg_count fixed bin; declare dir_name char (168); declare entryname char (32); declare message_bits bit (mmi.ms_len) based (mmi.ms_ptr) aligned; declare ms_index fixed bin; declare ms_mode bit (36) aligned; declare sci_ptr pointer; declare code fixed bin (35); declare ap pointer; declare al fixed bin (21); declare argument char (al) based (ap); declare 1 mmi aligned like mseg_message_info; declare (addr, currentsize, divide, hbound, lbound, size, substr, unspec) builtin; dir_name = ""; entryname = ""; ms_index = -1; /* for cleanup handler */ call ssu_$standalone_invocation (sci_ptr, "list_as_requests", "", cu_$arg_list_ptr (), SSU_ABORT, code); if code ^= 0 then do; call com_err_ (code, "list_as_requests", "Failed to create ssu_ invocation."); return; end; call ssu_$arg_count (sci_ptr, arg_count); if arg_count > 0 then do argx = 1 to arg_count; call ssu_$arg_ptr (sci_ptr, argx, ap, al); if argument = "-test_ms" then do; if argx = arg_count then call ssu_$abort_line (sci_ptr, error_table_$noarg, "-test_ms must be followed by a message segment pathname."); argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, ap, al); call expand_pathname_$add_suffix (argument, "ms", dir_name, entryname, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Invalid pathname ^a.", argument); end; else call ssu_$abort_line (sci_ptr, error_table_$badopt, "Invalid control argument ^a.", argument); end; if dir_name = "" then call system_info_$request_chn ((""b), (0), dir_name, entryname); call message_segment_$open (dir_name, entryname, ms_index, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Failed to open message segment ^a>^a.", dir_name, entryname); call message_segment_$get_mode_index (ms_index, ms_mode, code); if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Failed to get mode on message segment ^a>^a.", dir_name, entryname); unspec (mmi) = ""b; mmi.version = MSEG_MESSAGE_INFO_V1; mmi.own = ^substr (ms_mode, 3, 1); /* read mode */ mmi.message_code = MSEG_READ_FIRST; code = 0; do while (code = 0); call message_segment_$read_message_index (ms_index, get_user_free_area_ (), addr (mmi), code); if code = 0 then do; call PRINT_MESSAGE; free message_bits; end; mmi.message_code = MSEG_READ_AFTER_SPECIFIED; end; call message_segment_$close (ms_index, (0)); return; PRINT_MESSAGE: procedure; declare request_id char (19); declare ms_id_clock fixed bin (71); declare ms_length_words fixed bin (18); declare 1 header aligned like as_request_header based (mmi.ms_ptr); unspec (ms_id_clock) = mmi.ms_id; request_id = request_id_ (ms_id_clock); call ioa_ ("Message ^a from ^a (^w) in ring ^d", request_id, mmi.sender_id, mmi.sender_process_id, mmi.sender_level); call ioa_ (" Authorization ^a, Maximum authorization ^a", display_access_class_ (mmi.sender_authorization), display_access_class_ (mmi.sender_max_authorization)); ms_length_words = divide (mmi.ms_len, 36, 18, 0); if ms_length_words < size (as_request_header) then do; call ioa_ (" Message length less than minimum."); return; end; if header.version ^= as_request_version_1 then do; call ioa_ (" Message header version ^d, but only version ^d is supported.", header.version, as_request_version_1); return; end; if header.type < ASR_FIRST_TYPE | header.type > ASR_LAST_TYPE then do; call ioa_ (" Message type ^d undefined.", header.type); call ioa_ (" Reply channel ^d.", header.reply_channel); return; end; call ioa_ (" ^a request. Reply channel ^d.", ASR_REQUEST_NAMES (header.type), header.reply_channel); go to TYPE (header.type); TYPE (1): /* dial server */ call PRINT_DIAL_REQUEST; return; TYPE (2): /* dial out */ call PRINT_DIAL_REQUEST; return; TYPE (3): /* fpe causes logout */ TYPE (4): /* fpe causes new process */ return; /* nothing to say */ TYPE (5): /* "buzzard" -- termination notify */ call PRINT_BUZZARD; return; TYPE (6): /* bump */ call PRINT_BUMP; return; TYPE (7): /* command execution */ call PRINT_ADMIN_COMMAND; return; TYPE (8): /* note pnt changes */ call PRINT_NOTE_PNT; return; TYPE (9): /* daemon commands */ call PRINT_DAEMON_COMMAND; return; TYPE (10): /* com_channel_info */ call PRINT_COM_CHANNEL_INFO; return; TYPE (11): /* abs_command */ call PRINT_ABS_COMMAND; return; PRINT_DIAL_REQUEST: procedure; request_ptr = mmi.ms_ptr; if ms_length_words < size (dial_server_request) then do; call ioa_ (" Message too short."); return; end; if dial_server_request.version ^= dial_server_request_version_4 then do; call ioa_ (" Request version ^d, but only ^d is supported.", dial_server_request.version, dial_server_request_version_4); return; end; call ioa_ (" dial_control_channel ^d", dial_server_request.dial_control_channel); call ioa_ (" dial_qualifier ^a", dial_server_request.dial_qualifier); call ioa_ (" channel_name ^a", dial_server_request.channel_name); call ioa_ (" dial_out_destination ^a", dial_server_request.dial_out_destination); call ioa_ (" baud_rate ^d^[ not specified^]", dial_server_request.baud_rate, dial_server_request.baud_rate = -1); if dial_server_request.line_type >= lbound (line_types, 1) & dial_server_request.line_type <= hbound (line_types, 1) then call ioa_ (" line_type ^d (^a)", dial_server_request.line_type, line_types (dial_server_request.line_type)); else call ioa_ (" line_type ^d", dial_server_request.line_type); call ioa_ (" server_type ^a", dial_server_request.server_type); call ioa_ (" flags: ^[^^^]start,^[^^^]stop,^[^^^]privileged_attach,^[^^^]release_channel,", ^dial_server_request.start, ^dial_server_request.stop, ^dial_server_request.privileged_attach, ^dial_server_request.release_channel); call ioa_ (" ^[^^^]registered_server,^[^^^]no_hangup,^[^^^]release_dial_id,^[^^^]tandd_attach,", ^dial_server_request.registered_server, ^dial_server_request.no_hangup, ^dial_server_request.release_dial_id, ^dial_server_request.tandd_attach); call ioa_ (" ^[^^^]privileged_server", ^dial_server_request.privileged_server); call ioa_ (" access_class ^a", display_access_class_ (dial_server_request.access_class)); return; end PRINT_DIAL_REQUEST; PRINT_BUZZARD: procedure; asr_buzzard_infop = mmi.ms_ptr; if ms_length_words < size (asr_buzzard_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_buzzard_info.version ^= asr_buzzard_info_version_1 then do; call ioa_ (" Request version ^a, but only version ^a is supported.", asr_buzzard_info.version, asr_buzzard_info_version_1); return; end; call ioa_ (" info_channel ^d", asr_buzzard_info.info_channel); call ioa_ (" reference_id ^w", asr_buzzard_info.my_reference_id); return; end PRINT_BUZZARD; PRINT_BUMP: procedure; asr_bump_user_info_ptr = mmi.ms_ptr; if ms_length_words < size (asr_bump_user_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_bump_user_info.version ^= asr_bump_user_info_version_1 then do; call ioa_ (" Message version is ^a, but only version ^a is supported.", asr_bump_user_info.version, asr_bump_user_info_version_1); return; end; call ioa_ (" process_id ^w", asr_bump_user_info.process_id); call ioa_ (" message ^a", asr_bump_user_info.message); call ioa_ (" grace_time_in_seconds ^d", asr_bump_user_info.grace_time_in_seconds); call ioa_ (" reference_id ^w", asr_bump_user_info.reply_reference_id); return; end PRINT_BUMP; PRINT_ADMIN_COMMAND: procedure; asr_admin_command_info_ptr = mmi.ms_ptr; if ms_length_words < currentsize (asr_admin_command_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_admin_command_info.version ^= ASR_AC_VERSION_1 then do; call ioa_ (" Request version is ^a, but only version ^a is supported.", asr_admin_command_info.version, ASR_AC_VERSION_1); return; end; call ioa_ (" flags: ^[^^^]send_start_wakeup,^[^^^]send_completion_wakeup,", ^asr_admin_command_info.flags.send_start_wakeup, ^asr_admin_command_info.flags.send_completion_wakeup); call ioa_ (" ^[^^^]send_completion_message,^[^^^]send_completion_mail", ^asr_admin_command_info.flags.send_completion_message, ^asr_admin_command_info.flags.send_completion_mail); call ioa_ (" mail_destination ^a", asr_admin_command_info.mail_destination); call ioa_ (" command ^a", requote_string_ (asr_admin_command_info.command)); return; end PRINT_ADMIN_COMMAND; PRINT_NOTE_PNT: procedure; asr_note_pnt_change_info_ptr = mmi.ms_ptr; if ms_length_words < currentsize (asr_note_pnt_change_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_note_pnt_change_info.version ^= ASR_NPC_INFO_VERSION_1 then do; call ioa_ (" Request version is ^a, but only version ^a is supported.", asr_note_pnt_change_info.version, ASR_NPC_INFO_VERSION_1); return; end; call ioa_ (" person_id ^a", asr_note_pnt_change_info.person_id); return; end PRINT_NOTE_PNT; PRINT_COM_CHANNEL_INFO: procedure; asr_com_channel_info_ptr = mmi.ms_ptr; if ms_length_words < currentsize (asr_com_channel_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_com_channel_info.version ^= ASR_CCI_VERSION_1 then do; call ioa_ (" Request version is ^a, but only version ^a is supported.", asr_com_channel_info.version, ASR_CCI_VERSION_1); return; end; call ioa_ (" channel_name ^a", asr_com_channel_info.channel_name); call ioa_ (" reply_message_handle ^.3b", asr_com_channel_info.reply_message_handle); return; end PRINT_COM_CHANNEL_INFO; PRINT_DAEMON_COMMAND: procedure; asr_daemon_command_info_ptr = mmi.ms_ptr; if ms_length_words < currentsize (asr_daemon_command_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_daemon_command_info.version ^= ASR_DC_INFO_VERSION_1 then do; call ioa_ (" Request version is ^a, but only version ^a is supported.", asr_daemon_command_info.version, ASR_DC_INFO_VERSION_1); return; end; call ioa_ (" action_code ^[login^;logout^;quit^;reply^]", asr_daemon_command_info.action_code); call ioa_ (" user_name ^a", asr_daemon_command_info.user_name); call ioa_ (" project_name ^a", asr_daemon_command_info.project_name); call ioa_ (" source_name ^a", asr_daemon_command_info.source_name); call ioa_ (" command ^a", requote_string_ (asr_daemon_command_info.command)); return; end PRINT_DAEMON_COMMAND; PRINT_ABS_COMMAND: procedure; asr_abs_command_info_ptr = mmi.ms_ptr; if ms_length_words < currentsize (asr_abs_command_info) then do; call ioa_ (" Message length less than minimum."); return; end; if asr_abs_command_info.version ^= ASR_AC_INFO_VERSION_1 then do; call ioa_ (" Request version is ^a, but only version ^a is supported.", asr_abs_command_info.version, ASR_AC_INFO_VERSION_1); return; end; call ioa_ (" action_code ^[login^;cancel^]", asr_abs_command_info.action_code); call ioa_ (" request_id ^a", request_id_ (asr_abs_command_info.request_id)); return; end PRINT_ABS_COMMAND; end PRINT_MESSAGE; SSU_ABORT: procedure; go to ABORT; end SSU_ABORT; ABORT: if ms_index ^= -1 then call message_segment_$close (ms_index, (0)); return; %include mseg_message_info; %include as_request_header; %include as_requests; %include asr_abs_command; %include asr_daemon_command; %include asr_com_channel_info; %include dial_server_request; %include line_types; end list_as_requests;  list_delegated_projects.pl1 07/13/88 1112.5r w 07/13/88 0942.4 41328 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_delegated_projects: proc; dcl (sat_dir, sat_path) char (168) aligned, sel_proj char (32) aligned init (""), sat_name char (32) aligned, datestr char (16) aligned, (i, ii, iii, m, lng, sm, jj, slng, ec) fixed bin, an fixed bin init (2), (argp, satp, satep, pp) pointer, arg char (slng) based (argp), ct fixed bin init (0), ct1 fixed bin init (0); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), com_err_ entry options (variable), idsort_ entry ((*) char (32) aligned, (*) fixed bin, fixed bin); dcl ioa_ entry options (variable), ioa_$rsnnl entry options (variable), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin), hcs_$terminate_noname entry (ptr, fixed bin), clock_ entry () returns (fixed bin (71)), date_time_ entry (fixed bin (71), char (*) aligned); dcl (addr, null, fixed, substr) builtin; /* ================================================ */ %include user_attributes; %include sat; /* ================================================ */ /* INITIALIZATION - LOCATE AND INITIATE SAT */ call cu_$arg_ptr (1, argp, slng, ec); /* 1st argument is path name of sat */ if ec ^= 0 then do; call com_err_ (ec, "list_delegated_projects", ""); return; end; sat_path = arg; if sat_path ^= "sat" then if substr (sat_path, slng-3, 4) ^= ">sat" then if substr (sat_path, slng-3, 4) ^= ".sat" then do; slng = slng + 4; substr (sat_path, slng-3, 4) = ".sat"; end; call expand_path_ (addr (sat_path), slng, addr (sat_dir), addr (sat_name), ec); if ec ^= 0 then do; call com_err_ (ec, "list_delegated_projects", sat_path); return; end; call hcs_$initiate (sat_dir, sat_name, "", 0, 0, satp, ec); if satp = null then do; call com_err_ (ec, "list_delegated_projects", sat_path); return; end; if sat.version ^= SAT_version then do; call com_err_ (0, "list_delegated_projects", "SAT version is inconsistent with declarations used by this program"); go to exit; end; arglp: call cu_$arg_ptr (an, argp, slng, ec); /* get next arg -- a project name */ if ec ^= 0 then go to endarg; /* last arg? */ else do; sel_proj = arg; end; next_arg: an = an + 1; go to arglp; /* loop on args */ endarg: if sel_proj ^= "" then go to quickie; call date_time_ ((clock_ ()), datestr); call ioa_ ("^/List of Delegated Projects as of ^a^/", datestr); call ioa_ ("^/^10xP__r_o_j_e_c_t^4xA__d_m_i_n_i_s_t_r_a_t_o_r^/"); quickie: sm = sat.current_size; /* Set up for sort. */ begin; dcl x (sm) char (32) aligned, /* project sorting array */ y (sm) fixed bin; /* grade array sorted with project id */ do i = 1 to sat.current_size; satep = addr (sat.project (i)); x (i) = project.project_id; y (i) = i; end; if sel_proj = "" then call idsort_ (x, y, sm); do i = 1 to sat.current_size; /* loop thru SAT looking for delegated projects */ satep = addr (sat.project (y (i))); /* get ptr to slide down sat entries */ if project.state = 1 then do; if sel_proj ^= "" then if sel_proj ^= project.project_id then go to endsatloop; ct = ct + 1; /* counter to report undelegated projects */ if project.admin (1).userid = "" then go to endsatloop; ct1 = ct1 + 1; call ioa_ ("^/^10x^9a ^a", project.project_id, project.admin (1).userid); do jj = 2 to 4; /* up to 4 project administrators */ if project.admin (jj).userid ^= "" then call ioa_ ("^21x^a", project.admin (jj).userid); end; end; endsatloop: end; end; if sel_proj ^= "" then if ct = 0 then do; call ioa_ (" Project ^a not found in SAT", sel_proj); end; else if ct1 = 0 then do; call ioa_ ("^a is not currently a delegated project", sel_proj); end; call ioa_ (""); exit: call hcs_$terminate_noname (satp, ec); return; end list_delegated_projects;  list_extra_personids.pl1 09/25/92 1645.7r w 09/25/92 1644.9 63891 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-11-05,Vu), approve(90-11-05,MCR8226), audit(92-09-24,Zimmerman), install(92-09-25,MR12.5-1019): list_extra_personids aborts when it is run more than once within the same process. END HISTORY COMMENTS */ /* format: style4 */ list_extra_personids: procedure; /* Modified May 1982 E. N. Kittlitz. bugfix. */ /* Modified 1984-08-15 by E. Swenson for Version 2 PNTs. */ dcl 1 vrec aligned, /* record in temporary vfile */ 2 pid char (32), 2 in_pnt bit, 2 chain pointer; dcl 1 reference aligned based (refp), 2 next pointer, 2 type char (168); dcl temp_area area based (ai.areap); dcl temp_file internal file keyed record; dcl ME char (32) static options (constant) init ("list_extra_personids"); dcl sysdir char (168) static init (">system_control_dir"); dcl pdtdir char (168) static init (">system_control_dir>pdt"); /* External Static */ dcl error_table_$bad_index fixed bin (35) external static; dcl error_table_$checksum_failure fixed bin (35) external static; dcl error_table_$no_record fixed bin (35) external static; dcl iox_$error_output ptr external static; dcl sys_info$max_seg_size fixed bin (19) external static; /* External Entries */ dcl com_err_ entry options (variable); dcl define_area_ entry (ptr, fixed bin (35)); dcl get_pdir_ entry returns (char (168)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch entry () options (variable); dcl ioa_$rsnnl entry options (variable); dcl pnt_manager_$get_abs_entry entry (fixed bin (35), ptr, fixed bin (35)); dcl release_area_ entry (ptr); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl code fixed bin (35); dcl uid char (32); dcl rec fixed bin (35); dcl 1 pnte aligned like pnt_entry; dcl atd char (168); dcl long bit aligned; dcl (satp, pdtp, pdtep, satep, refp) pointer; dcl (i, j) fixed bin; dcl 1 ai aligned like area_info; /* Builtins */ dcl (addr, index, null, rtrim, string, substr) builtin; /* Conditions */ dcl (cleanup, endfile, key) condition; /* * * * * * * * * * * * * * * * * * * */ long = "0"b; ai.version = area_info_version_1; string (ai.control) = ""b; ai.control.extend = "1"b; ai.control.no_freeing = "1"b; ai.owner = ME; ai.size = sys_info$max_seg_size; ai.areap = null (); on cleanup call clean_up (); call define_area_ (addr (ai), code); if code ^= 0 then do; call com_err_ (code, ME, "Defining temporary area."); return; end; call ioa_$rsnnl ("vfile_ ^a>^a.lxp.temp", atd, (0), get_pdir_ (), unique_chars_ (""b)); open file (temp_file) title (atd) update; call hcs_$initiate (sysdir, "sat", "", 0, 0, satp, code); if satp = null () then do; call com_err_ (code, ME, "Initiating SAT."); call clean_up (); end; do j = 1 to 2; call ref (sat.system_admin (j), "System Administrator"); end; do i = 1 to sat.current_size; satep = addr (sat.project (i)); if project.state = 1 then do; do j = 1 to 4; call ref (project.admin (j).userid, "Project " || rtrim (project.project_id) || " Administrator"); end; call hcs_$initiate (pdtdir, rtrim (project.project_id) || ".pdt", "", 0, 0, pdtp, code); if pdtp = null () then call com_err_ (code, ME, "Initiating ^a.pdt.", project.project_id); else do; do j = 1 to pdt.current_size; pdtep = addr (pdt.user (j)); if user.state = 1 then call ref ((user.person_id), rtrim (project.project_id) || " Project"); end; call hcs_$terminate_noname (pdtp, code); end; end; end; on key (temp_file) begin; read file (temp_file) into (vrec) key (uid); vrec.in_pnt = "1"b; rewrite file (temp_file) from (vrec) key (uid); end; do rec = 1 by 1; call pnt_manager_$get_abs_entry (rec, addr (pnte), code); if code = error_table_$bad_index then goto done_pnt; else if code = error_table_$no_record then ; else if code = error_table_$checksum_failure then call ioa_$ioa_switch (iox_$error_output, "^a: Checksum error reading PNT entry ^d.", ME, rec); else if code ^= 0 then do; call com_err_ (code, ME, "Reading PNT entry ^d.", rec); call clean_up (); end; else do; uid = pnte.user_id; vrec.pid = uid; vrec.chain = null (); vrec.in_pnt = "1"b; write file (temp_file) from (vrec) keyfrom (uid); end; end; done_pnt: revert key (temp_file); close file (temp_file); open file (temp_file) title (atd) sequential input; on endfile (temp_file) begin; call clean_up (); goto exit; end; do while ("1"b); read file (temp_file) into (vrec); if vrec.in_pnt & vrec.chain = null () then do; call ioa_ ("^22a in PNT is not used.", vrec.pid); end; else if long | ^vrec.in_pnt then do; call ioa_ ("^22a^[ is not in the PNT.^]", vrec.pid, ^vrec.in_pnt); do refp = vrec.chain repeat (reference.next) while (refp ^= null ()); call ioa_ (" ^a", reference.type); end; end; end; exit: return; clean_up: procedure (); close file (temp_file); call release_area_ (ai.areap); return; end; /* * * * * * * * * * REF * * * * * * * * * */ ref: procedure (Pid, Type); dcl (Pid, Type) char (*); dcl pid char (32); dcl i fixed bin; i = index (Pid, "."); if i = 0 then pid = Pid; else pid = substr (Pid, 1, i - 1); if pid = "" | pid = "*" then return; allocate reference in (temp_area) set (refp); reference.type = Type; reference.next = null (); vrec.pid = pid; vrec.chain = refp; vrec.in_pnt = "0"b; on key (temp_file) begin; read file (temp_file) into (vrec) key (pid); reference.next = vrec.chain; vrec.chain = refp; rewrite file (temp_file) from (vrec) key (pid); end; write file (temp_file) from (vrec) keyfrom (pid); end; /* ref */ /* * * * * * * * * * TEST * * * * * * * * * */ test: entry (Dirname); dcl Dirname char (*) parameter; sysdir = Dirname; pdtdir = Dirname || ">pdt"; return; %include area_info; %include pdt; %include pnt_entry; %include sat; %include user_attributes; end; /* list_extra_personids */  load_ctl_status.pl1 08/29/88 0949.4rew 08/29/88 0856.3 69831 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ lcs: load_ctl_status: proc; /* print group totals */ /* Modified by T. Casey, July 1975, to print work class information */ /* Modified by T. Casey, September 1977, to count anstbl.extra_units in "all the rest" computation */ /* Modified by G. Dixon, February, 1977 to terminate Answer Table using ansp, to align output columns, to support more than 99 users in a group. */ /* Modified by T. Casey, January 1979 for MR7.0 absentee enhancements */ /* Modified November 1981, E. N. Kittlitz. user_table_entry conversion. */ /****^ HISTORY COMMENTS: 1) change(87-04-26,GDixon), approve(87-05-01,MCR7741), audit(87-05-06,Parisek), install(87-08-04,MR12.1-1055): Upgraded for change to answer_table.incl.pl1. 2) change(87-08-25,GDixon), approve(88-08-15,MCR7969), audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093): Correct ioa_ control string. (Answering_Service 354, phx16706) END HISTORY COMMENTS */ dcl sysdir char (168) aligned int static init (">system_control_dir"), en char (32) aligned, datstr char (16) aligned, wcstr char (10) aligned init (""), an fixed bin, selgp char (8) aligned init (""), selgl fixed bin init (0), (long, prio_sked, totalsw) bit (1) aligned init ("0"b), shift_change_time fixed bin (71), (shift, next_shift) fixed bin, sysi char (8) aligned, inst char (32) aligned, (f1, f2, f3, f4, f5) float bin, (i, k, n) fixed bin, ap ptr, al fixed bin, bchr char (al) unaligned based (ap), first_group fixed bin, ec fixed bin, fudge_flag char (1), extra_units fixed bin, whoptr ptr, mgtp ptr; dcl (addr, null, substr) builtin; dcl clock_ entry () returns (fixed bin (71)), system_info_$installation_id entry (char (*) aligned), system_info_$sysid entry (char (*) aligned), system_info_$next_shift_change entry (fixed bin, fixed bin (71), fixed bin), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), ioa_$nnl entry options (variable), date_time_ entry (fixed bin (71), char (*) aligned), com_err_ entry options (variable); dcl hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin); dcl hcs_$terminate_noname entry (ptr, fixed bin); ansp = null; k = 0; en = "mgt"; try_init: call hcs_$initiate (sysdir, en, "", 0, 1, mgtp, ec); if mgtp = null then do; if en = "mgt" then do; /* TEMPORARY - FOR FIRST RELEASE OF PRIORITY SCHEDULER SYSTEM */ en = "master_group_table"; goto try_init; end; er: call com_err_ (ec, "load_ctl_status", en); return; end; first_group = 1; if mgt.version_indicator = "VERSION " then if mgt.version >= 2 then do; first_group = 17; if mgt.switches.prio_sked_enabled then prio_sked = "1"b; end; en = "whotab"; call hcs_$initiate (sysdir, en, "", 0, 1, whoptr, ec); if whoptr = null then go to er; f1 = whotab.n_units / 1e1; f2 = whotab.mxunits / 1e1; call date_time_ ((clock_ ()), datstr); call system_info_$next_shift_change (shift, shift_change_time, next_shift); an = 1; arglp: call cu_$arg_ptr (an, ap, al, ec); if ec ^= 0 then go to endarg; if al = 0 then ; else if substr (bchr, 1, 1) = "-" then do; if bchr = "-lg" then long = "1"b; else if bchr = "-long" then long = "1"b; else if bchr = "-tt" then totalsw = "1"b; else if bchr = "-total" then totalsw = "1"b; else if bchr = "-totals" then totalsw = "1"b; else do; call com_err_ (0, "load_ctl_status", "invalid argument ^a", bchr); return; end; end; else do; /* must be group id */ selgp = bchr; selgl = al; end; an = an + 1; go to arglp; endarg: if long then do; call system_info_$sysid (sysi); call system_info_$installation_id (inst); call ioa_ ("^/Multics^x^a;^x^a^2x^a^/Load =^x^.1f out of^x^.1f units; users =^x^d absentee = ^d, daemons = ^d", sysi, inst, datstr, f1, f2, whotab.n_users, whotab.abs_users, whotab.n_daemons); call date_time_ (shift_change_time, datstr); call ioa_ ("Shift ^d until ^a", shift, datstr); end; else do; call ioa_ ("^/^16a^x^.1f/^.1f^x^d^x(^d,^d)", datstr, f1, f2, whotab.n_users, whotab.abs_users, whotab.n_daemons); if selgl ^= 0 then go to xlp; end; if prio_sked then do; call ioa_$nnl ("^/Work Classes:"); do i = 1 to 16; if mgt.user_wc_defined (i) then call ioa_$nnl ("^2x^2d", i); end; call ioa_$nnl ("^/Percents:^4x"); do i = 1 to 16; if mgt.user_wc_defined (i) then call ioa_$nnl ("^2x^2d", mgt.user_wc_min_pct (i)); end; if totalsw then goto exit; /* if just totals, exit before printing heading */ call ioa_ ("^2/Group^3xMaxprime^xMaxabs^2xPrime^xSecondary^2xAbs^4xTot / Max^4xPercent^2xIWC^xAWC^/"); end; else if ^totalsw then call ioa_ ("^/Group^3xMaxprime^xMaxabs^2xPrime^xSecondary^2xAbs^4xTot / Max^4xPercent^/"); xlp: if totalsw then goto exit; do i = first_group to mgt.current_size; mgtep = addr (mgt.entry (i)); if selgl ^= 0 then /* only one group wanted? */ if selgp ^= substr (group.group_id, 1, selgl) then go to skip; k = k + 1; fudge_flag = ""; if group.max_prim >= 0 then f1 = group.max_prim / 1e1; else do; /* this group takes "all the rest" */ call hcs_$initiate (sysdir, "answer_table", "", 0, 1, ansp, ec); if ansp ^= null () then extra_units = anstbl.extra_units; else do; extra_units = (whotab.abs_users + whotab.n_daemons) * 10; fudge_flag = "*"; end; f1 = (whotab.mxunits - mgt.total_units - extra_units) / 1e1; end; f2 = group.n_prim / 1e1; f3 = group.n_sec / 1e1; f4 = (group.n_prim + group.n_sec) / 1e1; f5 = f4 * 1e3 / whotab.n_units; if group.absolute_max < 32767 then call ioa_$rsnnl ("^5.1f/^.1f", datstr, n, f4, group.absolute_max / 1e1); else call ioa_$rsnnl ("^5.1f/------", datstr, n, f4); if prio_sked then call ioa_$rsnnl ("^2x^2d^2x^2d", wcstr, n, group.int_wc (shift), group.abs_wc (shift)); call ioa_ ("^8a^3x^5.1f^1a^6d^2x^5.1f^5x^5.1f^5d^3x^12a^3x^5.1f%^a", group.group_id, f1, fudge_flag, group.absentee_limit, f2, f3, group.n_abs, datstr, f5, wcstr); if fudge_flag = "*" then call ioa_ ("^/* This figure might be inaccurate because you lack read access to the answer table."); skip: end; if selgl ^= 0 then if k = 0 then call ioa_ ("group ""^a"" not found", selgp); exit: call hcs_$terminate_noname (mgtp, ec); call hcs_$terminate_noname (whoptr, ec); if ansp ^= null () then call hcs_$terminate_noname (ansp, ec); call ioa_ (""); return; test: entry (a_sysdir); dcl a_sysdir char (*); sysdir = a_sysdir; %page; %include answer_table; %page; %include mgt; %page; %include user_table_header; %page; %include whotab; end load_ctl_status;  monitor_quota.pl1 01/16/85 1309.2rew 01/16/85 1305.0 203319 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ monitor_quota: proc; /* * * * * * * * * * * * * * * * * * * Calculates remaining storage of a directory and will send a warning message at the approach of a record quota overflow condition. Written by R. Holmstedt 07/09/81 * * * * * * * * * * * * * * * * * * */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl all_flag init ("0"b) bit (1); dcl arg char (argl) based (argp); dcl argl fixed bin (21); dcl argp ptr; dcl argno fixed bin; dcl call_flag init ("0"b) bit (1); dcl call_limit fixed bin (21) init (0); dcl command_line char (command_line_length) based (command_line_ptr); /* argument after -call */ dcl command_line_length fixed bin; /* length of command line */ dcl command_line_ptr ptr; /* pointer to command line argument */ dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl code fixed bin (35); dcl console_flag init ("0"b) bit (1); dcl console_warn_limit fixed bin (21) init (0); dcl com_err_ entry () options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin (21), fixed bin (35)); dcl (error_table_$action_not_performed, error_table_$moderr, error_table_$noentry, error_table_$no_dir, error_table_$no_append, error_table_$messages_off, error_table_$inconsistent, error_table_$bad_arg) fixed bin (35) ext static; dcl false init ("0"b) bit (1) internal static options (constant); dcl hcs_$quota_read entry (char (*), fixed bin (18), fixed bin (71), bit (36) aligned, bit (36), fixed bin (1), fixed bin (18), fixed bin (35)); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl i fixed bin; dcl ioa_$rsnnl entry () options (variable); dcl linkage_error condition; dcl print_flag init ("0"b) bit (1); dcl message char (256) varying init (""); dcl message_id (10) char (50) init ((10) (1) ""); dcl monitor_quota$main entry; dcl monitor_quota_init_switch init ("0"b) bit (1) int static; dcl monitor_quota_ptr ptr int static init (null); dcl 01 monitor_list aligned based (monitor_quota_ptr), 02 monitor_count fixed bin, 02 monitor (0 refer (monitor_list.monitor_count)), 03 time fixed bin (71), 03 record_limit fixed bin (21), 03 path_name char (168) varying, 03 call_flag bit (1), 03 call_limit fixed bin (21), 03 console_flag bit (1), 03 console_warn_limit fixed bin (21), 03 warn_flag bit (1), 03 warn_limit fixed bin (21), 03 rpt_time fixed bin (71), 03 rpt_flag bit (1), 03 message_id (10) char (50), 03 command_line_length fixed bin, 03 command_line char (256); dcl nargs fixed bin; dcl off_flag init ("0"b) bit (1); dcl one_big_number fixed bin (71) init (377777777777777777777) internal static options (constant); dcl quota fixed bin (18); dcl record_limit fixed bin (21); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl rpt_flag init ("0"b) bit (1); dcl rpt_time fixed bin (71); dcl path_flag init ("0"b) bit (1); dcl path_name char (168); dcl pathname char (168); dcl percent fixed bin (6, 3); dcl phcs_$ring_0_message entry (char (*)); dcl prog_name char (13) internal static init ("monitor_quota"); dcl send_mail_ entry (char (*), char (*), ptr, fixed bin (35)); dcl send_message_ entry (char (*), char (*), char (*), fixed bin (35)); dcl sons_lvid bit (36); dcl test_entry entry variable; dcl time_now fixed bin (71); dcl timer_manager_$alarm_call entry (fixed bin (71), bit (2), entry); dcl timer_manager_$reset_alarm_call entry (entry); dcl true init ("1"b) bit (1) internal static options (constant); dcl trp fixed bin (71); dcl tup bit (36) aligned; dcl tacc_sw fixed bin (1); dcl used fixed bin (18); dcl warn char (256) varying; dcl warn_flag init ("0"b) bit (1); dcl warn_limit fixed bin (21) init (0); dcl (after, before, convert, null, index, addr, substr, length, rtrim, clock, divide) builtin; dcl conversion condition; /* *********** S T A R T************* */ command_args: /* * * * * * * * * * * * * * * * * * * */ /* */ /* This procedure will define the arguments used for */ /* the command to process. Some checking is done on */ /* arguments passed in as to valid characters */ /* */ /* * * * * * * * * * * * * * * * * * * */ on conversion goto num_error; call cu_$arg_count (nargs); do argno = 1 to nargs; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; arg_scan: if substr (arg, 1, 1) = "-" then do; if arg = "-pathname" | arg = "-pn" then do; /* directory to monitor */ if path_flag then goto dup_arg; path_flag = true; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; if substr (arg, 1, 1) = "-" then goto bad_arg; pathname = rtrim (arg); call absolute_pathname_ (pathname, path_name, code); if code ^= 0 then goto bad_arg; end; else if arg = "-call" then do; /* a command line is to be executed if quota used exceeds limit */ if call_flag then go to dup_arg; call_flag = true; argno = argno + 1; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; if substr (arg, 1, 1) = "-" then goto bad_arg; command_line_length = length (arg); command_line_ptr = addr (arg); command_line = arg; argno = argno + 1; /* see if record count given */ if argno > nargs then goto EOL; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; if substr (arg, 1, 1) = "-" then goto arg_scan; call_limit = convert (call_limit, (arg)); end; else if arg = "-console" then do; /* send warning to system console */ if console_flag then goto dup_arg; console_flag = true; on linkage_error goto test_link_fail; /* this is how to test if the user has access or not, before making the call */ test_entry = phcs_$ring_0_message; revert linkage_error; argno = argno + 1; /* see if record count given */ if argno > nargs then goto EOL; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then return; if substr (arg, 1, 1) = "-" then goto arg_scan; console_warn_limit = convert (console_warn_limit, (arg)); end; else if arg = "-warn" then do; /* send warning to this person */ if warn_flag then goto dup_arg; warn_flag = true; argno = argno + 1; /* get the person_id.proj_id */ call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; if index (arg, ".") = 0 then go to bad_arg; send_mail_info.version = send_mail_info_version_2; send_mail_info.mbz1 = false; send_mail_info.mbz = false; send_mail_info.sent_from = ""; send_mail_info.wakeup = true; send_mail_info.always_add = false; send_mail_info.never_add = true; send_mail_info.notify = false; send_mail_info.acknowledge = false; do i = 1 to 10 while (index (arg, ".") ^= 0); message_id (i) = arg; call send_mail_ (arg, "", addr (send_mail_info), code); if code ^= 0 then do; if code ^= error_table_$messages_off then do; if code = error_table_$noentry | code = error_table_$no_dir then warn = "No mailbox for "||arg; else if code = error_table_$no_append then warn = "Insufficient access to add a message to "||arg||" mailbox"; else warn = "Sending message to "||arg; goto non_fatal_warn; end; end; argno = argno + 1; /* get the person_id.proj_id */ if argno > nargs then goto EOL; call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; end; if substr (arg, 1, 1) = "-" then goto arg_scan; warn_limit = convert (call_limit, (arg)); end; else if arg = "-off" then do; if nargs ^= 1 then do; warn = "-off must not be given with any other arguments."; code = error_table_$inconsistent; goto non_fatal_warn; end; off_flag = true; end; else if arg = "-print" | arg = "-pr" then do; if nargs ^= 1 then do; warn = "-print must not be given with any other arguments."; code = error_table_$inconsistent; goto non_fatal_warn; end; print_flag = true; end; else if arg = "-repeat" | arg = "-rpt" then do; if rpt_flag then goto dup_arg; rpt_flag = true; argno = argno + 1; /* get the repeat time */ call cu_$arg_ptr (argno, argp, argl, code); if code ^= 0 then goto bad_arg; time_now = clock (); if code ^= 0 then goto bad_arg; call convert_date_to_binary_$relative (arg, rpt_time, time_now, code); if code ^= 0 then goto bad_arg; /* now get the difference */ rpt_time = rpt_time - time_now; end; else goto bad_arg; end; else goto bad_arg; end; EOL: /* thats end of line */ revert conversion; call set_up (); goto fini; /* \014 */ set_up: proc; /* * * * * * * * * * * * * * * * * * * This procedure will evaluate the command arguments and provide the defaults where needed. * * * * * * * * * * * * * * * * * * */ dcl date_time_ entry (fixed bin(71), char(*)); dcl get_wdir_ entry () returns (char (168)); dcl ioa_ entry() options(variable); dcl time_to_print char (24); dcl user_info_ entry (char (*), char (*), char (*)); dcl user_name char (22); dcl user_proj char (9); dcl user_acct char (32); if print_flag then do; /* show user information on monitors */ if monitor_quota_init_switch = false then do; /* nothing to monitor */ call ioa_ ("monitor_quota: There are no requests active."); return; end; do i = 1 to monitor_list.monitor_count; /* go thru the list */ call date_time_ (monitor_list.monitor (i).time, time_to_print); call ioa_ ("^/^d) ^a^/next wakeup interval: ^a ^/^[warn limit: ^d^;^s^] ^[console warning limit: ^d^;^s^] ^[call warning limit: ^d^;^s^]", i, monitor_list.monitor (i).path_name, time_to_print, monitor_list.monitor (i).warn_flag, monitor_list.monitor (i).warn_limit, monitor_list.monitor (i).console_flag, monitor_list.monitor (i).console_warn_limit, monitor_list.monitor (i).call_flag, monitor_list.monitor (i).call_limit); end; return; end; if off_flag then do; /* stop all monitoring */ if monitor_quota_init_switch = false then goto fini; else call cleanup; return; end; if ^path_flag then path_name = get_wdir_ (); /* if we don't have a directory get one */ call hcs_$quota_read ((path_name), quota, trp, tup, sons_lvid, tacc_sw, used, code); if code ^= 0 then do; warn = "Error reading quota for " ||rtrim (path_name)||"."; goto non_fatal_warn; end; /* figure out record limit to monitor */ if warn_limit = 0 & console_warn_limit = 0 & quota = 0 & ^call_flag then do; code = error_table_$action_not_performed; warn = "The quota of "||rtrim (path_name)||" is 0, a record limit needs to be specified."; goto non_fatal_warn; end; if call_limit > quota | warn_limit > quota | console_warn_limit > quota then do; warn = "Record limit specified is larger than the quota in " ||rtrim (path_name)||"."; code = error_table_$bad_arg; goto non_fatal_warn; end; if warn_limit = 0 & console_warn_limit = 0 then record_limit = quota * .80; /* set it to 80% of the dir. quota */ else do; if console_warn_limit ^= 0 & warn_limit = 0 then record_limit = console_warn_limit; if warn_limit ^= 0 & console_warn_limit = 0 then record_limit = warn_limit; if console_warn_limit ^= 0 & warn_limit ^= 0 then do; record_limit = console_warn_limit; if warn_limit < record_limit then record_limit = warn_limit; end; end; if call_flag then do; if call_limit = 0 & quota = 0 then do; code = error_table_$action_not_performed; warn = "The quota of "||rtrim (path_name)||" is 0, a record limit needs to be specified."; goto non_fatal_warn; end; if call_limit = 0 then call_limit = quota * .90; /* set it to 90% of the dir. if user didn't set it */ if call_limit < record_limit then record_limit = call_limit; end; if ^rpt_flag then /* figure out a good repeat time */ call repeat_calc (quota, used, rpt_time); if ^warn_flag & ^console_flag & ^call_flag then do; /* need to find somebody to tell */ call user_info_ (user_name, user_proj, user_acct); message_id (1) = rtrim (user_name)||"."||rtrim (user_proj); warn_flag = true; warn_limit = record_limit; end; if monitor_quota_init_switch = false then do; /* set up static area to keep information about quota */ call get_temp_segment_ (prog_name, monitor_quota_ptr, code); if code ^= 0 then do; warn = "Error from get_temp_segments_."; goto bummer; end; monitor_list.monitor_count = 0; monitor_quota_init_switch = true; end; monitor_list.monitor_count = monitor_list.monitor_count + 1; /* add another directory to be monitored */ monitor_list.monitor (monitor_count).record_limit = record_limit; monitor_list.monitor (monitor_count).path_name = rtrim (path_name); monitor_list.monitor (monitor_count).call_flag = call_flag; monitor_list.monitor (monitor_count).call_limit = call_limit; monitor_list.monitor (monitor_count).console_flag = console_flag; monitor_list.monitor (monitor_count).console_warn_limit = console_warn_limit; monitor_list.monitor (monitor_count).rpt_time = rpt_time; monitor_list.monitor (monitor_count).rpt_flag = rpt_flag; monitor_list.monitor (monitor_count).warn_flag = warn_flag; monitor_list.monitor (monitor_count).warn_limit = warn_limit; monitor_list.monitor (monitor_count).time = time_now + monitor_list.monitor (monitor_count).rpt_time; if call_flag then do; monitor_list.monitor (monitor_count).command_line_length = command_line_length; monitor_list.monitor (monitor_count).command_line = command_line; end; else do; monitor_list.monitor (monitor_count).command_line_length = 0; monitor_list.monitor (monitor_count).command_line = ""; end; do i = 1 to 10; monitor_list.monitor (monitor_count).message_id (i) = message_id (i); end; if record_limit < used then /* quota problem already! */ call convert_date_to_binary_ ("", monitor_list.monitor (monitor_count).time, code); /* will look like it matured */ call main (); return; end set_up; /* \014 */ repeat_calc: proc (dir_quota, dir_used, repeat); dcl dir_quota fixed bin (18); dcl dir_used fixed bin (18); dcl repeat fixed bin (71); dcl percent fixed bin (6, 3); dcl time_value char (5) varying; percent = divide ((dir_used * 100), dir_quota, 5, 0) ; if percent < 50 then time_value = "30min"; else if percent < 60 then time_value = "20min"; else if percent < 70 then time_value = "10min"; else if percent < 80 then time_value = "5min"; else if percent > 90 then time_value = "1min"; else time_value = "2min"; time_now = clock (); call convert_date_to_binary_$relative ((time_value), repeat, time_now, code); if code ^= 0 then do; warn = "Error on calculation of repeat value "||time_value||"."; goto bummer; end; /* now get the difference */ repeat = repeat - time_now; return; end repeat_calc; /* \014 */ main: entry; /* * * * * * * * * * * * * * * * * * * This entry scans the monitor_list when the alarm timer calls into this entry. The next alarm time is calculated for all entrys and the smallest time is selected for the next alarm. * * * * * * * * * * * * * * * * * * */ dcl alarm_time fixed bin (71); dcl j fixed bin; alarm_time = one_big_number; /* need a starting point to compair */ call timer_manager_$reset_alarm_call (monitor_quota$main); time_now = clock (); /* get the time now */ do i = 1 to monitor_list.monitor_count; if monitor_list.monitor (i).time < time_now then do; /* time to check */ call hcs_$quota_read ((monitor_list.monitor (i).path_name), quota, trp, tup, sons_lvid, tacc_sw, used, code); if code ^= 0 then do; warn = "Error reading quota for " ||monitor_list.monitor (i).path_name||"."; goto bummer; end; if quota = 0 then do; /* this will check if directory quota was changed to 0*/ if monitor_list.monitor_count > 1 then monitor_list.monitor (i).time = one_big_number; /* this should stop monitoring for this only */ code = error_table_$action_not_performed; warn = "The quota for " ||monitor_list.monitor (i).path_name ||" has been changed to zero."; goto non_fatal_warn; end; if used < monitor_list.monitor (i).record_limit then do; /* nothing to worry about */ if ^monitor_list.monitor (monitor_count).rpt_flag then call repeat_calc (quota, used, monitor_list.monitor (i).rpt_time); monitor_list.monitor (i).time = time_now + monitor_list.monitor (i).rpt_time; if monitor_list.monitor (i).time < alarm_time then alarm_time = monitor_list.monitor (i).time; /* set wakeup time to lowest time needed */ end; else do; /* we used more then the limit */ if monitor_list.monitor (i).console_flag then do; if monitor_list.monitor (i).console_warn_limit <= used then do; percent = divide ((used * 100), quota, 5, 0) ; message = ""; call ioa_$rsnnl ("^a: Storage in ^a is ^d% full.", message, (0), prog_name, (monitor_list.monitor (i).path_name), percent); /* error message */ on linkage_error go to call_1_failed; call phcs_$ring_0_message ((message)); revert linkage_error; /* It worked */ end; end; if monitor_list.monitor (i).warn_flag then do; if monitor_list.monitor (i).warn_limit <= used then do; /* check to be sure, may only have call limit or console limit */ percent = divide ((used * 100), quota, 5, 0) ; message = ""; call ioa_$rsnnl ("^a: Storage in ^a is ^d% full.", message, (0), prog_name, (monitor_list.monitor (i).path_name), percent); do j = 1 to 10 while (monitor_list.monitor (i).message_id (j) ^= ""); call send_message_ ((before (monitor_list.monitor (i).message_id (j), ".")), (after (monitor_list.monitor (i).message_id (j), ".")), (message), code); if code ^= 0 then call com_err_ (code, prog_name, "Error sending warning to ^a ^/Quota limit reached in ^a. Monitoring will continue.", monitor_list.monitor (i).message_id (j), monitor_list.monitor (i).path_name); /* tell someone */ end; end; end; if monitor_list.monitor (i).call_flag then do; if monitor_list.monitor (i).call_limit <= used then do; call cu_$cp (addr (monitor_list.monitor (i).command_line), length (monitor_list.monitor (i).command_line), code); if code ^= 0 then do; warn = "Error calling "||rtrim (monitor_list.monitor (i).command_line)|| "."; goto non_fatal_warn; end; end; end; if ^monitor_list.monitor (monitor_count).rpt_flag then call repeat_calc (quota, used, monitor_list.monitor (i).rpt_time); monitor_list.monitor (i).time = monitor_list.monitor (i).time + monitor_list.monitor (i).rpt_time; if monitor_list.monitor (i).time < alarm_time then alarm_time = monitor_list.monitor (i).time; /* set wakeup time to lowest time needed */ end; /* end of quota problem */ end; else if monitor_list.monitor (i).time < alarm_time then alarm_time = monitor_list.monitor (i).time; end; /* set to the next wake up */ call timer_manager_$alarm_call ((alarm_time), "00"b, monitor_quota$main); return; /* \014 */ test_link_fail: revert linkage_error; code = error_table_$moderr; warn = "Access required to phcs_ to send warning to system console."; goto non_fatal_warn; call_1_failed: revert linkage_error; if monitor_list.monitor_count > 1 then monitor_list.monitor (i).time = one_big_number; /* this should stop monitoring for this only */ code = error_table_$moderr; warn = "Access required to phcs_ to send warning to system console."; goto non_fatal_warn; non_fatal_warn: /* don't delete the other monitor entries */ if monitor_quota_ptr ^= null then do; if monitor_list.monitor_count >1 then do; call com_err_ (code, prog_name, "^/^a", warn); return; end; end; goto bummer; /* cleanup and go away */ num_error: revert conversion; bad_arg: code = error_table_$bad_arg; warn = arg; call com_err_ (code, prog_name, "^a", warn); return; dup_arg: code = error_table_$inconsistent; warn = arg || " appears twice on the command line."; goto non_fatal_warn; bummer: call com_err_ (code, prog_name, "^/^a", warn); call cleanup; return; cleanup: proc; call timer_manager_$reset_alarm_call (monitor_quota$main); if monitor_quota_init_switch ^= false then do; call release_temp_segment_ (prog_name, monitor_quota_ptr, code); monitor_quota_init_switch = false; end; return; end; fini: return; %include send_mail_info; end monitor_quota;  mos_edac_summary.pl1 03/14/85 0810.8r w 03/13/85 1100.2 148626 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* MOS_EDAC_SUMMARY: Command to summarize MOS Memory EDAC errors from the syserr log */ /* Written June 1979 by Larry Johnson */ /* Most of this program was borrowed from the io_error_summary command. */ /* Completed for installation December 1979 by Rich Coppola */ /* Modified July 1983 by Paul Farley to change call to sys_info_$time_delta, which does not exist, to time_data_$time_delta, which also allows for per-process time zone selection (phx15295). */ mos_edac_summary: mes: proc; dcl name char (17) int static options (constant) init ("mos_edac_summary"); /* Name of procedure */ dcl code fixed bin (35); /* Standard system status code */ dcl open_status bit (36) aligned; /* Code from syserr_log_util_$open */ dcl ptr_array (1) ptr; /* An array of pointers as required by get_temp_segment_ */ dcl tab_cnt fixed bin init (0); /* Number of seperate status found */ dcl mask bit (36) aligned init ("0"b); /* Mask of significant bits in status word */ dcl arg_ptr ptr; /* Pointer to an argument */ dcl arg_len fixed bin; /* Length of an argument */ dcl arg char (arg_len) based (arg_ptr); /* A command argument */ dcl arg_count fixed bin; /* The number of arguments */ dcl arg_list_ptr ptr; /* Pointer to commands argument list */ dcl for_ptr ptr; /* Saved pointer to the -for argument */ dcl for_len fixed bin; /* Saved length of -for argument */ dcl for_arg char (for_len) based (for_ptr); /* This is the -for argument */ dcl from_sw bit (1) init ("0"b); /* Set if -from used */ dcl to_sw bit (1) init ("0"b); /* Set if -to used */ dcl for_sw bit (1) init ("0"b); /* Set if -for used */ dcl more_args bit (1); /* Set while there are more arguments to scan */ dcl from_time fixed bin (71); /* Time specified on -from */ dcl to_time fixed bin (71); /* Time specified on -to */ dcl for_time fixed bin (71); /* Time specified on -for */ dcl count_limit fixed bin init (0); /* Results for -limit arg */ dcl day_limit fixed bin init (0); /* Results for -day_limit arg */ dcl workp ptr; /* Pointer to work segment */ dcl arg_no fixed bin init (1); /* For scanning argument list */ dcl errentp ptr; /* Pointer to status table entry */ dcl msg_time fixed bin (71); /* Time of syserr message */ dcl msg_seq fixed bin (35); /* Sequence number */ dcl scu_cnt fixed bin init (0); /* Number of MEMs requested */ dcl err_cnt fixed bin init (0); /* Entries in status table */ dcl segs_allocated bit (1) init ("0"b); /* Set after work segments created */ dcl sort_listp ptr; dcl us_per_day fixed bin (71); /* micro-seconds per day */ dcl 1 work aligned based (workp), /* Declaration of work segment */ 2 scureq (32) char (7) var, /* Table of requested MEMs */ 2 buffer (500) bit (36) aligned, /* Syserr messages are read here */ 2 errentry (err_cnt + 1) like err; /* Entry for each different error */ dcl 1 err aligned based (errentp), /* Entry for each different error syndrome found */ 2 mem char (1) unal, 2 store char (2) unal, 2 count fixed bin (35), 2 ZAC_line bit (6) unal, 2 syndrome bit (8) unal, 2 identification bit (4) unal, 2 day_count fixed bin (18) uns unal, 2 day_list (16) fixed bin (18) uns unal; dcl 1 sort_list aligned based (sort_listp), 2 count fixed bin, 2 errentp (sort_list.count) ptr unal; dcl sort_items_$general entry (ptr, entry); dcl syserr_log_util_$open entry (bit (36) aligned, fixed bin (35)); dcl print_syserr_msg_$open_err entry (bit (36) aligned, char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl get_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl syserr_log_util_$read entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl syserr_log_util_$close entry (fixed bin (35)); dcl release_temp_segments_ entry (char (*), dim (*) ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl cu_$arg_list_ptr entry (ptr); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); dcl edit_mos_rscr_$decode entry (ptr, char (*), char (*)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl convert_date_to_binary_$relative entry (char (*), fixed bin (71), fixed bin (71), fixed bin (35)); dcl time_data_$time_delta ext fixed bin (71); dcl error_table_$end_of_info ext fixed bin (35); dcl error_table_$badopt ext fixed bin (35); dcl (cleanup, conversion) condition; dcl (addr, bin, divide, hbound, index, substr) builtin; /* Initialization */ on cleanup call clean_up; call get_temp_segments_ (name, ptr_array, code); /* Get a work segment */ if code ^= 0 then do; call com_err_ (code, name, "Can't get temp segment"); go to done; end; segs_allocated = "1"b; /* Remember that they are allocated */ workp = ptr_array (1); /* Copy pointer to my segment */ call cu_$arg_list_ptr (arg_list_ptr); /* Need pointer to argument list */ call cu_$arg_count (arg_count); /* And the length */ more_args = (arg_count > 0); /* Set if args to scan */ call scan_args; /* Scan the argument list */ call syserr_log_util_$open (open_status, code); /* Open the syserr log */ if code ^= 0 | substr (open_status, 1, 2) ^= "11"b then do; /* If error */ call print_syserr_msg_$open_err (open_status, name, code); if code ^= 0 then go to done; /* Not recoverable */ end; if ^from_sw then do; /* No -from, so start at beginning */ call syserr_log_util_$search (0, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Can't find first message in log."); go to done; end; from_time = msg_time; /* Official starting time */ end; else do; /* -from used, find right message */ call syserr_log_util_$search (from_time, msg_time, msg_seq, code); if code ^= 0 then do; call com_err_ (code, name, "Locating first message requested."); go to done; end; end; if for_sw then do; /* Now can compute -for limit */ call convert_date_to_binary_$relative (for_arg, to_time, from_time, code); if code ^= 0 then do; call com_err_ (code, name, "-for ^a", for_arg); go to done; end; to_sw = "1"b; /* Now, just as if -to was specified */ end; if ^to_sw then to_time = from_time; /* Initialize last message time */ syserr_msgp = addr (work.buffer); /* Read here */ /* Loop thru the file */ loop: call syserr_log_util_$read (syserr_msgp, hbound (buffer, 1), (0), code); if code ^= 0 then do; if code = error_table_$end_of_info then go to print; call com_err_ (code, name, "Reading syserr log"); go to done; end; if to_sw then do; /* If time limit */ if syserr_msg.time > to_time then go to print; end; else to_time = syserr_msg.time; /* Save last message time */ if syserr_msg.data_code = SB_mos_err & syserr_msg.data_size > 0 then call count_it; go to loop; /* End of log reached */ print: call sort_it; /* Sort the table */ call print_it; /* Print results */ /* End of command */ done: call clean_up; return; /* Procedure to scan the argument list */ scan_args: proc; do while (more_args); /* Do while thins to look at */ call get_arg; if arg = "-from" | arg = "-fm" then do; /* Start time */ from_sw = "1"b; call time_arg (from_time); end; else if arg = "-to" then do; /* Ending time */ to_sw = "1"b; call time_arg (to_time); end; else if arg = "-for" then do; /* Time limit */ for_sw = "1"b; call time_arg (for_time); /* For syntax checking only */ for_len = arg_len; /* Save pointer to this argument */ for_ptr = arg_ptr; end; else if arg = "-limit" then count_limit = decimal_arg (); else if arg = "-day_limit" then do; day_limit = decimal_arg (); if day_limit > 16 then do; call com_err_ (0, name, "Maximum value for -day_limit is 16."); go to done; end; us_per_day = 24*60*60*1000000; end; else if arg = "-mem" then do; /* List of MEMs */ if ^more_args then do; /* Need more args */ no_scu: call com_err_ (0, name, "Argument missing after -MEM"); go to done; end; call get_arg; if substr (arg, 1, 1) = "-" then go to no_scu; /* Shouldn't be control arg */ new_scu: if (length (arg) > 1) | (index ("abcdefgh", arg) = 0) then do; call com_err_ (0, name, "Invalid mem specified ""^a""", arg); go to done; end; scu_cnt = scu_cnt + 1; /* Count MEM found */ work.scureq (scu_cnt) = arg; /* Save name */ if more_args then do; /* If more to scan */ call get_arg; if substr (arg, 1, 1) ^= "-" then do; /* Found another MEM */ if scu_cnt < hbound (work.scureq, 1) then go to new_scu; else do; /* Too many */ call com_err_ (0, name, "There were more than ^d MEMs specified.", hbound (work.scureq, 1)); go to done; end; end; else call put_arg; /* Went too far, back up 1 */ end; end; else do; /* Bad arg */ call com_err_ (error_table_$badopt, name, "^a", arg); go to done; end; end; if to_sw & for_sw then do; /* Conflict */ call com_err_ (0, name, "Conflicting arguments: -to and -for"); go to done; end; return; end scan_args; /* Procedure to return the next argument from command line */ get_arg: proc; call cu_$arg_ptr_rel (arg_no, arg_ptr, arg_len, code, arg_list_ptr); if code ^= 0 then do; /* Should never happen */ call com_err_ (code, name, "Arg ^d", arg_no); go to done; end; arg_no = arg_no + 1; /* For next call */ more_args = (arg_no <= arg_count); return; put_arg: entry; /* Entry to return argument after scanning too far */ arg_no = arg_no - 1; more_args = (arg_no <= arg_count); return; end get_arg; /* Procedure to convert a time argument */ time_arg: proc (t); dcl t fixed bin (71); /* The time to ouput */ dcl arg_copy char (10) var; /* Save copy of arg here */ arg_copy = arg; if ^more_args then do; /* Must be more */ call com_err_ (0, name, "Argument required after ^a.", arg_copy); go to done; end; call get_arg; call convert_date_to_binary_ (arg, t, code); if code ^= 0 then do; call com_err_ (code, name, "^a ^a", arg_copy, arg); go to done; end; return; end time_arg; /* Procedure to convert a decimal argument */ decimal_arg: proc returns (fixed bin); dcl arg_copy char (10) var; arg_copy = arg; if ^more_args then do; call com_err_ (0, name, "Argument required after ^a.", arg_copy); go to done; end; call get_arg; on conversion go to bad_dec_arg; return (bin (arg)); bad_dec_arg: call com_err_ (0, name, "Invalid ^a: ^a", arg_copy, arg); go to done; end decimal_arg; /* Procedure to count an EDAC */ count_it: proc; dcl (i, j) fixed bin; dcl found bit (1); dcl mem char (1); dcl store char (2); dcl day_no fixed bin; found = "0"b; scrp = addr (syserr_msg.data); i = index (syserr_msg.text, " mem "); if i = 0 then do; unparsable: call com_err_ (0, name, "Unparsable syserr message. Text: ^a", syserr_msg.text); return; end; mem = substr (syserr_msg.text, i + 5, 1); if scu_cnt > 0 then do j = 1 to scu_cnt while (found = "0"b); if mem = work.scureq (j) then found = "1"b; end; if scu_cnt > 0 then if ^found then return; /* don't count this one */ else; i = index (syserr_msg.text, " store "); if i = 0 then go to unparsable; store = substr (syserr_msg.text, i+7, 2); if substr (store, 2, 1) = "." then substr (store, 2, 1) = " "; do i = 1 to err_cnt; errentp = addr (work.errentry (i)); if err.mem = mem & err.store = store & err.ZAC_line = scr_su.ZAC_line & err.syndrome = scr_su.syndrome & err.identification = scr_su.identification then do; err.count = err.count + 1; go to check_day; end; end; err_cnt = err_cnt + 1; errentp = addr (work.errentry (err_cnt)); err.mem = mem; err.store = store; err.count = 1; err.day_count = 0; err.ZAC_line = scr_su.ZAC_line; err.syndrome = scr_su.syndrome; err.identification = scr_su.identification; check_day: if day_limit <= 0 then return; day_no = divide (syserr_msg.time - time_data_$time_delta, us_per_day, 17, 0); do i = 1 to err.day_count; if err.day_list (i) = day_no then return; end; if err.day_count = hbound (err.day_list, 1) then return; err.day_count = err.day_count + 1; err.day_list (err.day_count) = day_no; return; end count_it; /* Procedure to sort the table */ sort_it: proc; dcl i fixed bin; dcl sort_count fixed bin; sort_listp = addr (work.errentry (err_cnt + 1)); /* Use next available word */ sort_list.count = err_cnt; /* TEMP FIX */ sort_count = 0; do i = 1 to err_cnt; errentp = addr (work.errentry (i)); if err.count >= count_limit & err.day_count >= day_limit then do; sort_count = sort_count+1; sort_list.errentp (sort_count) = addr (work.errentry (i)); end; end; sort_list.count = sort_count; if sort_count < 2 then return; call sort_items_$general (sort_listp, compare_error); return; end sort_it; compare_error: proc (p1, p2) returns (fixed bin (1)); dcl (p1, p2) ptr unal; if p1 -> err.mem < p2 -> err.mem then return (-1); if p1 -> err.mem > p2 -> err.mem then return (+1); if p1 -> err.store < p2 -> err.store then return (-1); if p1 -> err.store > p2 -> err.store then return (+1); if p1 -> err.count < p2 -> err.count then return (+1); if p1 -> err.count > p2 -> err.count then return (-1); return (0); end compare_error; /* Procedure to print results */ print_it: proc; dcl (tm1, tm2) char (24); /* For editing times */ dcl work bit (72) aligned; dcl mem_type char (32); dcl error char (32); dcl i fixed bin; dcl prev_mem char (1); dcl print_mem char (1); dcl prev_store char (2); dcl print_store char (2); dcl prev_type char (32); dcl print_type char (32); call date_time_ (from_time, tm1); call date_time_ (to_time, tm2); call ioa_ ("Summary from ^a to ^a^/^/MEM STORE CNT TYPE SYNDROME DECODE", tm1, tm2); prev_mem, prev_store, prev_type = ""; scrp = addr (work); do i = 1 to sort_list.count; errentp = sort_list.errentp (i); work = "0"b; scr_su.ZAC_line = err.ZAC_line; scr_su.syndrome = err.syndrome; scr_su.identification = err.identification; call edit_mos_rscr_$decode (scrp, mem_type, error); if err.mem = prev_mem then do; print_mem = ""; if err.store = prev_store then do; print_store = ""; if mem_type = prev_type then print_type = ""; else print_type = mem_type; end; else do; print_store = err.store; print_type = mem_type; end; end; else do; call ioa_ (""); print_mem = err.mem; print_store = err.store; print_type = mem_type; end; prev_type = mem_type; prev_mem = err.mem; prev_store = err.store; call ioa_ (" ^1a ^2a^6d ^20a ^a", print_mem, print_store, err.count, print_type, error); end; return; end print_it; /* Cleanup handler */ clean_up: proc; call syserr_log_util_$close (code); if segs_allocated then do; segs_allocated = "0"b; call release_temp_segments_ (name, ptr_array, code); end; return; end clean_up; %include syserr_message; %include scr; %include syserr_binary_def; end mos_edac_summary;  print_projfile.pl1 08/29/88 0949.4rew 08/29/88 0858.6 42426 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_projfile: proc; /* Print out "projfile" */ /* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA) Modified June 1981 by E. N. Kittlitz for UNCA rate structures. Modified 1984-08-27 BIM for projfile version, unaligned strings. */ /****^ HISTORY COMMENTS: 1) change(87-08-11,GDixon), approve(88-08-15,MCR7969), audit(88-08-04,Lippard), install(88-08-29,MR12.2-1093): Set ec error code when only rate structure 0 is used. (phx14422) END HISTORY COMMENTS */ dcl ap ptr, al fixed bin (21), bchr char (al) based (ap), dn char (168), (dt1, dt2) char (8), x (0:7) float bin, disk_price (0:9) float bin, dcost float bin, (co, dp) char (64) aligned, en char (32), (i, np) fixed; dcl pp ptr; dcl ec fixed bin (35); dcl rs_number fixed bin; /* rate structure index */ dcl max_rs_number fixed bin; dcl com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), get_wdir_ entry () returns (char (168)), cv_$mwvf entry (float bin) returns (char (15)), date_time_ entry (fixed bin (71), char (*)), system_info_$titles entry options (variable), system_info_$max_rs_number entry (fixed bin), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), ioa_ entry options (variable); dcl search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35)); dcl search_sat_$clean_up entry; dcl system_info_$prices_rs entry (fixed bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin); dcl error_table_$noentry external fixed bin (35); dcl null builtin; %include projfile; /* - - - - */ call system_info_$max_rs_number (max_rs_number); call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then do; dn = get_wdir_ (); en = "projfile"; end; else do; call expand_pathname_ (bchr, dn, en, ec); if ec ^= 0 then go to er; end; call hcs_$initiate (dn, en, "", 0, 1, pp, ec); if pp = null then do; er: call com_err_ (ec, "print_projfile", ""); return; end; np = pp -> projfile.nproj; call system_info_$titles (co, dp); call ioa_ ("^|^a^/^/^-^a^/^/Project file listing: ^d entries^/^/", co, dp, np); if projfile.version ^= PROJFILE_VERSION then call com_err_ (0, "print_projfile", "Warning, projfile version is ^d, not current version ^d.", projfile.version, PROJFILE_VERSION); do rs_number = 0 to max_rs_number; /* get all rates */ call system_info_$prices_rs (rs_number, x, x, x, x, disk_price (rs_number), x (1)); end; do i = 1 to np; call date_time_ (on (i), dt1); if off (i) = 0 then dt2 = ""; else call date_time_ (off (i), dt2); if max_rs_number = 0 then ec, rs_number = 0; else call search_sat_$rs_number ((id (i)), rs_number, ec); /* get rate index */ if ^(ec = error_table_$noentry & disk_psec (i) = 0) then do; if ec ^= 0 then call com_err_ (ec, "print_projfile", "Trying to locate project ""^a"" in the sat. Default rates will be used.", id (i)); end; dcost = disk_psec (i) * disk_price (rs_number); call ioa_ ("^9a^3x^52a ^8a ^8a", id (i), title (i), dt1, dt2); call ioa_ ("^12xInvestigator: ^32a ^32a", inv (i), inv_addr (i)); call ioa_ ("^12xSupervisor:^3x^32a ^32a ^16a", sup (i), sup_addr (i), sup_phone (i)); call ioa_ ("^12xDisk charge: ^15a ^d/^d directory ^d/^d", cv_$mwvf (dcost), disk_quota (i), disk_use (i), dir_disk_quota (i), dir_disk_use (i)); if misc_charges (i) ^= 0e0 then call ioa_ ("^12xMisc charges: ^15a ^d", cv_$mwvf (misc_charges (i)), n_misc (i)); call ioa_ (""); end; call hcs_$terminate_noname (pp, ec); call search_sat_$clean_up; /* tidy up */ end;  print_reqfile.pl1 12/11/99 1833.0re 12/11/99 1808.4 27648 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(99-06-23,Haggett): Y2K END HISTORY COMMENTS */ /**** Modified Jan 1, 2000 to print cutoff date using 4-digit year. */ print_reqfile: proc; /* print reqfile */ dcl dn char (168) aligned, ap ptr, al fixed bin, bchr char (al) based (ap), en char (32) aligned, i fixed bin, nq fixed bin, ec fixed bin (35), qp ptr, (co, dp) char (64) aligned, dt1 char (20), (dt2, dt3) char (8) aligned, facev char (15) aligned; dcl cv_$mwvf ext entry (float bin) returns (char (15)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), get_wdir_ entry () returns (char (168)), system_info_$titles entry options (variable), date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns (char(250) var), date_time_ entry (fixed bin (71), char (*) aligned), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), ioa_ entry options (variable), com_err_ entry options (variable); dcl null builtin; %include reqfile; call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then do; dn = get_wdir_ (); en = "reqfile"; end; else do; call expand_path_ (ap, al, addr (dn), addr (en), ec); end; call hcs_$initiate (dn, en, "", 0, 1, qp, ec); if qp = null then do; er: call com_err_ (ec, "print_reqfile", ""); return; end; nq = qp -> reqfile.nacts; call system_info_$titles (co, dp); call ioa_ ("^|^a^/^/^-^a^/^/Requisition file listing: ^d accounts.^/^/", co, dp, nq); call ioa_ ("Acct ID^5xAcct no^6xRequisition^5x Cutoff^3xReq. Amount^11xSpent^6xThis Month^8xOn^7xOff^/"); do i = 1 to nq; dt1 = date_time_$format ("^9999yc-^my-^dm", cutoff (i), "", ""); call date_time_ (qdn (i), dt2); if qdf (i) ^= 0 then call date_time_ (qdf (i), dt3); else dt3 = ""; facev = cv_$mwvf ((req_amt (i))); if facev = "" then facev = " open"; call ioa_ ("^9a^3x^12a ^12a ^8a ^15a ^15a ^15a ^8a ^8a", acctid (i), mitacct (i), reqno (i), dt1, facev, cv_$mwvf (chg_tr (i) + chg_mo (i)), cv_$mwvf ((chg_mo (i))), dt2, dt3); call ioa_ ("^25x^32a^8x^32a^/", billing_name (i), billing_addr (i)); end; call hcs_$terminate_noname (qp, ec); end;  print_sat.pl1 07/13/88 1112.5r w 07/13/88 0942.4 86913 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* PRINT_SAT - procedure to print the binary System Administrator's Table coded by Eleanor Stone January 1970 */ /* modified on 04/13/70 12:59 */ /* modified for new SAT format by Janice B. Phillipps, March 12, 1972 */ /* Modified 741107 by PG for authorizations & audit */ /* Modified by T. Casey, June 1975, for per-user load control groups */ /* Modified May 1976 by T. Casey to print project cutoff limits */ /* Modified May 1978 by T. Casey to print pdir_quota */ /* Modified January 1979 by T. Casey to print max_foreground, max_background, and abs_foreground_cpu_limit. */ /* Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures (UNCA). */ /* Modified June 1981 by E. N. Kittlitz for UNCA rate structures */ /* Modified 1984-07-05 BIM for min and max authorizations. */ /* Modified 1984-12-14 by EJ Sharpe for new audit flags */ print_sat: procedure; /* automatic */ dcl 1 temp aligned like project.at; dcl 1 global_attr aligned like project.at; dcl sat_dir char (168); dcl rs_number fixed bin; /* rate structure index */ dcl rs_name (0:9) char (32); dcl char_string char (256); dcl datestr char (24); dcl sel_proj char (32) init (""); dcl sat_name char (32); dcl (i, jj) fixed bin; dcl code fixed bin (35); dcl (argp, satp, satep) pointer; dcl slng fixed bin (21); dcl attr char (512) varying; dcl max_rs_number fixed bin; /* DECLARATION OF BASED STRUCTURES */ dcl arg char (slng) based (argp); /* entries */ dcl convert_access_audit_flags_$to_string entry (bit (36) aligned, char (*), fixed bin (35)); dcl convert_access_class_$to_string_range_short entry ((2) bit (72) aligned, char (*), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl com_err_ entry options (variable); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_path_ entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35)); dcl format_attributes_ entry (ptr, char (*) var); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl ioa_ entry options (variable); dcl system_info_$max_rs_number entry (fixed bin); dcl system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)); /* builtin functions */ dcl (addr, char, clock, hbound, length, ltrim, null, reverse, string, substr, verify) builtin; /* internal static */ dcl my_name char (9) internal static initial ("print_sat"); /* include files */ /* ================================================ */ %include sat; %include user_attributes; /* ================================================ */ /* INITIALIZATION - LOCATE AND INITIATE SAT */ call system_info_$max_rs_number (max_rs_number); do i = 0 to hbound (rs_name, 1); rs_name = " rate structure " || ltrim (char (i)); end; call cu_$arg_ptr (1, argp, slng, code); if code ^= 0 then do; call com_err_ (code, my_name, ""); return; end; call expand_path_ (argp, slng, addr (sat_dir), addr (sat_name), code); if code ^= 0 then do; call com_err_ (code, my_name, arg); return; end; i = length (sat_name) - verify (reverse (sat_name), " ") + 1; if i > length (".sat") then if substr (sat_name, i - 3, 4) ^= ".sat" then substr (sat_name, i + 1, 4) = ".sat"; else; else if sat_name ^= "sat" then substr (sat_name, i + 1, 4) = ".sat"; call hcs_$initiate (sat_dir, sat_name, "", 0, 0, satp, code); if satp = null then do; call com_err_ (code, my_name, "^a>^a", sat_dir, sat_name); return; end; if satp -> sat.version ^= SAT_version then do; call com_err_ (0, my_name, "SAT version ^d is inconsistent with declarations used by this program (version ^d).", satp -> sat.version, SAT_version); return; end; call cu_$arg_ptr (2, argp, slng, code); if code = 0 then do; sel_proj = arg; go to plp; end; call date_time_ ((clock ()), datestr); call ioa_ ("^//* ^a>^a ^a */^/", sat_dir, sat_name, datestr); call ioa_ ("/* author.process_group_id:^6x^a; */", satp -> sat.author.proc_group_id); call ioa_ ("/* author.w_dir:^17x^a; */", satp -> sat.author.w_dir); call ioa_ ("/* max_size:^18x^4d; */", sat.max_size); call ioa_ ("/* current_size:^14x^4d; */", sat.current_size); call ioa_ ("/* version:^22x^d; */", sat.version); call ioa_ ("/* freep:^21x^4d; */", sat.freep); call ioa_ ("/* n_projects:^16x^4d; */", sat.n_projects); call ioa_ (" Maxunits:^16x^6d;", sat.max_units); if satp -> sat.uwt_size ^= 0 then do; call ioa_ ("/* uwt_size:^20x^2d; */", sat.uwt_size); do i = 1 to satp -> sat.uwt_size; call ioa_ ("^3xUwt:^2-^a, ^d;", sat.uwt (i).initproc, sat.uwt (i).units); end; end; do jj = 1 to 2; if sat.system_admin (jj) ^= "" then call ioa_ ("^3xAdministrator:^-^a;", sat.system_admin (jj)); end; /* Compute Global attribute bits */ string (global_attr) = (36)"1"b; /* initially assume all are ON */ do i = 1 to sat.current_size; /* turn off all non-global attrs */ satep = addr (sat.project (i)); if project.state ^= 0 then do; string (temp) = string (project.at); /* copy attributes */ temp.sb_ok = ^(temp.sb_ok); /* normalize inverted attrs */ temp.pm_ok = ^(temp.pm_ok); /* (names are opposite of bits) */ temp.eo_ok = ^(temp.eo_ok); /* .. */ string (global_attr) = string (global_attr) & string (temp); end; end; string (temp) = string (global_attr); /* leave global alone, make copy */ temp.sb_ok = ^(temp.sb_ok); temp.pm_ok = ^(temp.pm_ok); temp.eo_ok = ^(temp.eo_ok); call format_attributes_ (addr (temp), attr); call ioa_ (" Attributes:^6x^a", attr); /* NOW PRINT OUT ALL PROJECT ENTRIES */ plp: do rs_number = 0 to max_rs_number; /* get all the rate structure names */ call system_info_$rs_name (rs_number, rs_name (rs_number), code); end; do i = 1 to sat.current_size; satep = addr (satp -> sat.project (i)); if project.state ^= 0 then do; if sel_proj ^= "" then if sel_proj ^= project.project_id then go to skip; call ioa_ ("^/^3xprojectid:^-^a;", project.project_id); call ioa_ ("/* state:^2-^d; */", project.state); call ioa_ ("^3xprojectdir:^-^a;", project.project_dir); if project.pdt_ptr ^= null then call ioa_ ("/* pdt_ptr:^-^p; */", project.pdt_ptr); call ioa_ ("^3xmaxprim:^-^d;", project.max_users); call ioa_ ("/* n_users:^-^d; */", project.n_users); string (temp) = string (project.at); temp.nopreempt = "0"b; /* only used in PDT */ if sel_proj = "" then do; /* if printing whole SAT */ temp.sb_ok = ^(temp.sb_ok); temp.pm_ok = ^(temp.pm_ok); temp.eo_ok = ^(temp.eo_ok); string (temp) = string (temp) & ^string (global_attr); /* turn OFF bits that are global */ temp.sb_ok = ^(temp.sb_ok); temp.pm_ok = ^(temp.pm_ok); temp.eo_ok = ^(temp.eo_ok); end; call format_attributes_ (addr (temp), attr); call ioa_ ("^3xattributes:^-^a", attr); if project.audit ^= ""b then do; call convert_access_audit_flags_$to_string (project.audit, char_string, code); if code ^= 0 then call com_err_ (code, my_name, "Could not convert audit flags."); if char_string ^= "" then call ioa_ ("^3xaudit:^2-""^a"";", char_string); end; call convert_access_class_$to_string_range_short (project.project_authorization, char_string, code); if code ^= 0 then call com_err_ (code, my_name, "Could not convert authorization."); if char_string ^= "" then call ioa_ ("^3xauthorization:^-""^a"";", char_string); if max_rs_number > 0 then call ioa_ ("/* rate_structure:^-^a (^d); */", rs_name (project.rs_number), project.rs_number); if project.cutoff ^= " " then call ioa_ ("^3xcutoff:^-^-^a;", project.cutoff); call ioa_ ("/* days_to_cutoff:^-^d; */", project.days_to_cutoff); call ioa_ ("/* pct_balance:^-^d%; */", project.pct_balance); call ioa_ ("/* dollars_to_cutoff: $^.2f; */", project.dollars_to_cutoff); call ioa_ ("^3xring:^-^-^d,^d;", project.min_ring, project.max_ring); if project.alias ^= "" then call ioa_ ("^3xalias:^-^-^a;", project.alias); call ioa_ ("^3xgroup:^-^-^a;", project.group); if project.at.igroup then do; if project.groups (1) ^= "" then do; /* if any authorized groups */ if project.groups (2) ^= "" then /* if two of them */ call ioa_ ("^3xgroups:^-^a, ^a;", project.groups (1), project.groups (2)); else call ioa_ ("^3xgroups:^-^a;", project.groups (1)); end; end; call ioa_ ("^3xgrace:^2-^d;", project.grace_max); call ioa_ ("^3xpdir_quota:^-^d;", project.pdir_quota); call ioa_ ("^3xmax_foreground:^-^d;", project.max_foreground); call ioa_ ("^3xmax_background:^-^d;", project.max_background); call ioa_ ("^3xabs_foreground_cpu_limit:^x^d;", project.abs_foreground_cpu_limit); do jj = 1 to 4; if project.admin (jj).userid ^= "" then call ioa_ ("^3xadministrator:^-^a;", project.admin (jj).userid); end; end; skip: end; call ioa_ (""); if sel_proj = "" then call ioa_ ("end;^/"); call hcs_$terminate_noname (satp, code); return; end print_sat;  print_syserr_msg_.pl1 03/14/85 0810.8r w 03/13/85 1100.2 209277 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Procedure to print a syserr message */ /* Coded November 1975 by Larry Johnson */ /* Modified January 1976 by Larry Johnson */ /* Modified October 1976 by Larry Johnson for new hardware fault messages. */ /* Modified November 1979 by Larry Johnson for detailed device status */ /* Modified June 1982 by E. N. Kittlitz to handle (i.e. do nothing for) config deck. */ /* Modified May 1983 by E. N. Kittlitz to print config decks nicely. (There! that wasn't so hard, was it?) */ /* format: style4 */ print_syserr_msg_: proc (argp, code); dcl code fixed bin (35); /* Status code */ dcl (ctp, ptp) ptr; /* Pointers to times */ dcl cur_time char (24); /* Current time from date_time_ */ dcl seq_edit picture "zzzzzzzzzzz9"; /* To edit sequence number field */ dcl seq_sz fixed bin; /* Number of chars in sequence number */ dcl tpos fixed bin; /* Current position while scanning text */ dcl (i, j) fixed bin; dcl tlen fixed bin; /* Length of portion of text being checked */ dcl room fixed bin; /* Number of characters on line available for text */ dcl start fixed bin; /* Starting position for characters */ dcl line_length fixed bin; /* Length of line */ dcl moved fixed bin (21); /* Number of characters moved into line */ dcl fl bit (1) init ("1"b); /* Set while 1st line is edited */ dcl line char (1024); /* Print line is built here */ dcl aline (1024) char (1) based (addr (line)); /* Another way of addressing line */ dcl next fixed bin; /* Next character position available on line */ dcl restl fixed bin; /* Length of rest of line */ dcl restp ptr; /* Pointer to rest of line */ dcl rest char (restl) based (restp); /* Rest of the line */ dcl arrayl fixed bin; /* Length of portion of array */ dcl arrayp ptr; /* Pointer to portion of array */ dcl based_array (arrayl) bit (36) aligned based (arrayp); /* Portion of array */ dcl work char (1024) var; /* A temp string */ dcl work2 char (128) var; /* Another */ dcl code_edit picture "zzz9"; /* To edit the action code */ dcl bin_mode bit (1) init ("0"b); /* Set while editing the binary part of message */ dcl first_bin bit (1) init ("0"b); /* Set until 1st line of binary data printed */ dcl hold_moved fixed bin; /* Used during binary editing to save text length */ dcl nwords fixed bin; /* Number of words of binary data */ dcl wordp ptr; /* Pointer to binary data */ dcl words (nwords) based (wordp); dcl 1 tm based, /* Structure that overlays time from date_time_ */ 2 date char (8) unal, /* MM/DD/YY */ 2 fill1 char (2) unal, 2 time char (6) unal, /* HHMM.T */ 2 fill2 char (1) unal, 2 zone char (3) unal, /* ZZZ - time zone */ 2 fill3 char (1) unal, 2 day char (3) unal; /* DDD - day of week */ dcl 1 dtl, /* Date line printed when day changes */ 2 nl1 char (1) unal, /* A newline */ 2 day char (3) unal, /* The day of the week */ 2 bl1 char (2) unal, /* " " */ 2 date char (8) unal, /* MM/DD/YY */ 2 bl2 char (2) unal, /* " (" */ 2 zone char (3) unal, /* The time zone */ 2 bl3 char (1) unal, /* ")" */ 2 nl2 char (1) unal; /* A newline */ dcl newline char (1) int static init (" "); /* A new line character */ %include print_syserr_msg_args; dcl text_data char (parg.textl) based (parg.textp); /* Text from param list */ dcl print_data char (parg.printl) based (parg.printp); dcl date_time_ entry (fixed bin (71), char (*)); dcl ioa_$rsnpnnl entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl syserr_log_util_$search entry (fixed bin (71), fixed bin (71), fixed bin (35), fixed bin (35)); dcl com_err_ entry options (variable); dcl error_table_$smallarg ext fixed bin (35); dcl (addr, addrel, bin, divide, index, hbound, length, max, min, reverse, rtrim, string, substr, verify) builtin; %include syserr_message; %include mc; /* Get time of message */ syserr_msgp = parg.msgp; /* Get pointer to message */ call date_time_ ((syserr_msg.time), cur_time); ctp = addr (cur_time); /* Get pointers to time structures */ ptp = addr (parg.prev_time); if ctp -> tm.date ^= ptp -> tm.date then do; /* If date change */ dtl.nl1, dtl.nl2 = newline; /* Fill in line to print */ dtl.day = ctp -> tm.day; dtl.bl1 = " "; dtl.date = ctp -> tm.date; dtl.bl2 = " ("; dtl.zone = ctp -> tm.zone; dtl.bl3 = ")"; call iox_$put_chars (iocbp, addr (dtl), length (string (dtl)), code); if code ^= 0 then return; /* If put_chars error */ end; parg.prev_time = cur_time; /* Remember for next call */ /* Determine how much space is on line for text */ line = ""; /* Clear line */ moved = 0; /* No characters in it */ seq_edit = syserr_msg.seq_num; /* Edit the sequence number */ seq_sz = max (6, 13 - verify (seq_edit, " ")); /* Characters in edited number with leading spaces removed */ start = seq_sz + 12; /* Starting column for text */ line_length = min (parg.linelen, length (line) - 1); room = line_length - start + 1; /* Characters available in text portion of line */ if room <= 25 then do; /* If too small */ code = error_table_$smallarg; return; end; tpos = 1; /* Start with first character */ /* This routine edits the line. If it is too long, or contains newline, it will be broken into several lines */ top: if tpos > length (print_data) then go to done; /* Done if finished line */ i = index (substr (print_data, tpos), newline); /* Check for newline */ if i = 0 then /* No newline in remaining text */ tlen = length (print_data) - tpos + 1; /* Length to consider is rest of line */ else if i = 1 then do; /* If newline is first */ tpos = tpos + 1; /* Skip over it */ go to top; end; else tlen = i - 1; /* Consider just stuff before newline */ i = verify (substr (print_data, tpos, tlen), " ");/* Count leading blanks */ if i = 0 then do; /* Line is all blank */ tpos = tpos + tlen; /* Skip it all */ go to top; end; if i > 1 then do; /* Some leading blanks */ tpos = tpos + i - 1; /* Skip them */ tlen = tlen - i + 1; /* Adjust count */ end; if moved ^= 0 then call put; /* If stuff already on line, dump it */ if tlen <= room then do; /* If it all fits */ substr (line, start, tlen) = substr (print_data, tpos, tlen); /* Copy it all */ moved = tlen; /* Remember how much */ tpos = tpos + tlen; end; else do; i = index (reverse (substr (print_data, tpos + room - 20, 20)), " "); /* Check last 20 characters that fit for a blank */ if i = 0 then do; /* If no blank, break is arbitrary */ substr (line, start, room) = substr (print_data, tpos, room); /* Fill line */ moved = room; /* Remember how much */ tpos = tpos + room; /* Skip over what moved */ end; else do; /* Be neat and break on blank */ tlen = room - i; /* Length to copy */ substr (line, start, tlen) = substr (print_data, tpos, tlen); /* Do it */ moved = tlen; /* Remember how much */ tpos = tpos + tlen + 1; /* Skip over stuff copied, + blank */ end; end; go to top; /* Back for more */ done: if parg.bin_sw then if syserr_msg.data_size > 0 then call edit_binary; if fl | moved ^= 0 then call put; /* Write last line */ code = 0; finish: return; /* Procedure to print 1 line */ put: proc; if fl then do; /* If first line */ substr (line, 1, 6) = ctp -> tm.time; /* Move in time */ substr (line, 8, seq_sz) = substr (seq_edit, 13 - seq_sz); /* And sequence number */ code_edit = syserr_msg.code; /* Edit the action code */ substr (line, seq_sz + 8, 3) = substr (code_edit, 2, 3); /* Move into line */ fl = "0"b; /* Only do this once */ end; if first_bin then do; /* If first line of binary data */ first_bin = "0"b; if (hold_moved > 0) & (hold_moved ^= moved) then moved = moved + 2; /* This accounts for the 2 spaces between text and data when they both appear on the same line */ end; moved = moved + start; /* Total length */ substr (line, moved, 1) = newline; /* Put new line at end */ call iox_$put_chars (iocbp, addr (line), moved, code); if code ^= 0 then go to finish; line = ""; /* Initialize for next line */ moved = 0; if bin_mode then do; /* Binary editors need extra stuff */ restp = addr (aline (start)); restl = room; end; return; end put; /* Procedure to edit binary data */ edit_binary: proc; dcl s fixed bin; dcl i fixed bin; dcl tbuf char (260); %include syserr_binary_def; dcl binary_segmsg_util_ entry (ptr) returns (char (250)); dcl binary_segmsg_util_$interpret_pvname entry (ptr) returns (char (32)); dcl special_chars (15) char (32) var int static options (constant) init (/* Table of special messages */ "ioi_interrupt: I/O error.", "op-not-complete fault by ", "startup fault by ", "shutdown fault by ", "parity fault by ", "mos_memory_check: EDAC error", "cache dir parity fault on", "cache store parity fault on", "cache store thru parity fault on", "cache load parity fault on", "parity fault on", "startup fault on", "shutdown fault on", "op_not_complete fault on", "command fault on"); if moved = 0 then next = start; /* Line empty */ else next = start + moved + 2; /* Next available column */ hold_moved = moved; /* Save text length */ bin_mode = "1"b; /* In binary mode now */ first_bin = "1"b; /* Editing first line */ restp = addr (aline (next)); /* Address of rest of line */ restl = line_length - next + 1; /* Length of rest of line */ if octal_sw then do; /* Do simple dump */ call edit_std; return; end; if syserr_msg.data_code ^= 0 then do; s = syserr_msg.data_code; if s = SB_mos_err then call edit_mos_memory; else if s = SB_io_err then call edit_ioi; else if s = SB_io_err_detail then call edit_ioi_detail; else if s = SB_ocdcm_err then call edit_ioi; else if s = SB_hw_fault then go to scan; else if s = SB_verify_lock then call edit_fault; else if s = SB_config_deck then call edit_config; else if s < 0 | s > SB_end_of_table then ; else if substr (syserr_binary_seg_damage_mask, s, 1) then do; tbuf = "Segment: " || binary_segmsg_util_ (addr (syserr_msg.data)); go to out_tbuf; end; else if substr (syserr_binary_vol_damage_mask, s, 1) then do; tbuf = "Volume: " || binary_segmsg_util_$interpret_pvname (addr (syserr_msg.data)); out_tbuf: i = length (rtrim (tbuf)); if i > restl then call put; moved = min (i, length (line)); rest = tbuf; call put; return; end; else call edit_std; return; end; scan: do i = 1 to hbound (special_chars, 1); /* Scan table of names */ if length (text_data) >= length (special_chars (i)) then if index (text_data, special_chars (i)) ^= 0 then go to make_call; end; call edit_std; /* Use a standard routine */ return; make_call: go to c (i); /* Branch to appropriate call */ c (1): call edit_ioi; /* Ioi error */ return; c (2): call edit_old_onc; /* Op-not-complete fault */ return; c (3): call edit_old_startup; /* Startup fault */ return; c (4): call edit_old_startup; /* Shutdown fault */ return; c (5): call edit_old_parity; /* Parity fault */ return; c (6): call edit_mos_memory; /* Mos memory EDAC error */ return; c (7): /* Cache dir parity fault */ c (8): /* Cache store parity fault */ c (9): /* Cache store thru parity fault */ c (10): /* Cache load parity fault */ c (11): /* Parity fault */ c (12): /* Startup fault */ c (13): /* Shutdown fault */ c (14): /* Op not complete fault */ c (15): /* Command fault */ call edit_fault; return; end edit_binary; /* Procedure to edit unidentified binary data */ edit_std: proc; nwords = syserr_msg.data_size; wordp = addr (syserr_msg.data); call edit_words; return; end edit_std; /* Procedure that edits any random words */ /* It will be put on the current line if it fits, otherwise on succeeding lines with some power of 2 words per line */ edit_words: proc; i = 13 * nwords - 1; /* Space needed for all words */ if i <= restl then do; /* It fits */ all_fits: call ioa_$rsnpnnl ("^(^w ^)", rest, (0), words); /* Edit it */ moved = moved + i; call put; return; end; if moved > 0 then call put; /* Dump current line */ if i <= restl then go to all_fits; /* Fits on one line now */ /* Determine number of words to print per line */ i, j = 1; do while (j <= room); i = 2 * i; /* A power of 2 */ j = 13 * i - 1; /* Space for that many words */ end; i = divide (i, 2, 17, 0); /* Last power of two that fit */ do j = 1 by i while (j <= nwords); /* Loop to print the lines */ arrayp = addr (words (j)); /* Addr of current piece */ arrayl = min (i, nwords - j + 1); call ioa_$rsnpnnl ("^(^w ^)", rest, moved, based_array); call put; end; return; end edit_words; /* Procedure to edit a config deck fragment */ edit_config: proc; dcl data_left fixed bin; dcl field_no fixed bin; dcl config_card_field_in_ascii char (4) based; %include config_deck; data_left = syserr_msg.data_size; cardp = addr (syserr_msg.data); do while (data_left > 0); call ioa_$rsnpnnl ("^a", work, (0), config_card.word); do field_no = 1 to config_card.type_word.n_fields by 1; if config_card.type_word.field_type (field_no) = CONFIG_STRING_TYPE then call ioa_$rsnpnnl ("^a ^a", work, (0), work, addr (config_card.data_field (field_no)) -> config_card_field_in_ascii); else if config_card.type_word.field_type (field_no) = CONFIG_OCTAL_TYPE then call ioa_$rsnpnnl ("^a ^o", work, (0), work, fixed (config_card.data_field (field_no))); else if config_card.type_word.field_type (field_no) = CONFIG_DECIMAL_TYPE then call ioa_$rsnpnnl ("^a ^d.", work, (0), work, fixed (config_card.data_field (field_no))); else if config_card.type_word.field_type (field_no) = CONFIG_SINGLE_CHAR_TYPE then call ioa_$rsnpnnl ("^a ^a", work, (0), work, substr ("abcdefgh", fixed (config_card.data_field (field_no)), 1)); else ; end; call put; substr (rest, 1, length (work)) = work; moved = moved + length (work); data_left = data_left - size (config_card); cardp = addrel (cardp, size (config_card)); end; call put; end edit_config; /* Procedure to edit an ioi syserr message */ edit_ioi: proc; dcl edit_detail bit (1) init ("0"b); dcl detailed_status_length fixed bin; dcl i fixed bin; dcl dtstat (detailed_status_length) bit (8) unal based (addr (io_msg.detailed_status)); %include io_syserr_msg; edit_ioi_join: io_msgp = addr (syserr_msg.data); call ioa_$rsnpnnl ("channel=^a device=^2.3b", work, (0), io_msg.channel, io_msg.device); if io_msg.time_out then work = work || " timeout"; else do; call ioa_$rsnpnnl (" status=^w", work2, (0), io_msg.status); work = work || work2; end; if io_msg.count ^= "0"b then do; call ioa_$rsnpnnl (" (^d times)", work2, (0), bin (io_msg.count, 6) + 1); work = work || work2; end; if room < length (work) then do; /* If terminal too short for this message */ call edit_std; return; end; if length (work) > restl then /* If it won't fit on current line */ call put; /* Dump line */ substr (rest, 1, length (work)) = work; /* Copy line */ moved = moved + length (work); if edit_detail then do; call put; detailed_status_length = 27; do i = detailed_status_length to 1 by -1 while (dtstat (i) = "0"b); end; detailed_status_length = max (i, 1); call ioa_$rsnpnnl ("Detailed status:^( ^.4b^)", work, (0), dtstat); substr (rest, 1, length (work)) = work; /* Copy line */ moved = moved + length (work); end; return; edit_ioi_detail: entry; edit_detail = "1"b; go to edit_ioi_join; end edit_ioi; /* Edit message from a fault */ edit_fault: proc; dcl fault_msgp ptr; dcl 1 fault_msg aligned based (fault_msgp), 2 mcx like mc aligned, 2 hist_reg (128) bit (36) aligned; fault_msgp = addr (syserr_msg.data); scup = addr (mcx.scu); call edit_text ("Pointer Registers:"); wordp = addr (fault_msg.prs); nwords = 16; call edit_words; call ioa_$rsnpnnl ("x0-7:^( ^.3b^)", rest, moved, fault_msg.x); call put; call ioa_$rsnpnnl ("a: ^.3b q: ^.3b e: ^.3b t: ^.3b ralr: ^.3b", rest, moved, fault_msg.a, fault_msg.q, "0"b || fault_msg.e, fault_msg.t, fault_msg.ralr); call put; call edit_scu (addr (fault_msg.scu)); call ioa_$rsnpnnl ("Fault Register: ^.3b", rest, moved, fault_msg.fault_reg); call put; call edit_text ("EIS Info:"); nwords = 8; wordp = addr (fault_msg.eis_info); call edit_words; call edit_hist (addr (fault_msg.hist_reg), (scu.pad2)); return; end edit_fault; edit_scu: proc (p); dcl p ptr; call edit_text ("SCU data:"); nwords = 8; wordp = p; call edit_words; return; end edit_scu; edit_hist: proc (p, cpu_type); dcl p ptr; dcl cpu_type bit (9); if cpu_type = "0"b then call edit_text ("OU History Reg Data:"); else call edit_text ("DU/OU History Reg Data:"); nwords = 32; wordp = p; call edit_words; call edit_text ("CU History Reg Data:"); wordp = addrel (p, 32); call edit_words; if cpu_type = "0"b then call edit_text ("DU History Reg Data:"); else call edit_text ("APU#2 History Reg Data:"); wordp = addrel (p, 64); call edit_words; if cpu_type = "0"b then call edit_text ("APU History Reg Data:"); else call edit_text ("APU#1 History Reg Data:"); wordp = addrel (p, 96); call edit_words; return; end edit_hist; edit_text: proc (msg); dcl msg char (*); if moved > 0 then call put; substr (rest, 1, length (msg)) = msg; moved = length (msg); call put; return; end edit_text; /* Edit old style parity message */ edit_old_parity: proc; dcl parity_msgp ptr; dcl 1 parity_msg aligned based (parity_msgp), 2 scu (8) bit (36) aligned, 2 inst_addr fixed bin (18), 2 inst (3) bit (36) aligned, 2 abs_tsr_valid bit (1) unal, 2 tsr_repeat bit (1) unal, 2 fill1 bit (9) unal, 2 tsr_loc fixed bin (24) unal, 2 tsr_data bit (36) unal, 2 abs_psr_valid bit (1) unal, 2 psr_repeat bit (1) unal, 2 fill2 bit (9) unal, 2 psr_loc fixed bin (24) unal, 2 psr_data bit (36) aligned; parity_msgp = addr (syserr_msg.data); if moved > 0 then call put; call ioa_$rsnpnnl ("inst at ^o: ^w ^w ^w", rest, moved, parity_msg.inst_addr, parity_msg.inst); call put; call edit_scu (addr (parity_msg.scu)); call ioa_$rsnpnnl ("PSR: ^o", work, 0, parity_msg.psr_loc); if parity_msg.abs_psr_valid then do; call ioa_$rsnpnnl (" (^w)", work2, 0, parity_msg.psr_data); work = work || work2; work = work || " Retry "; if parity_msg.psr_repeat then work = work || "succeeded."; else work = work || "failed."; end; else work = work || " invalid absaddr."; rest = work; moved = length (work); call put; call ioa_$rsnpnnl ("TSR: ^o", work, 0, parity_msg.tsr_loc); if parity_msg.abs_tsr_valid then do; call ioa_$rsnpnnl (" (^w)", work2, 0, parity_msg.tsr_data); work = work || work2; work = work || " Retry "; if parity_msg.tsr_repeat then work = work || "succeeded."; else work = work || "failed."; end; else work = work || " invalid absaddr."; rest = work; moved = length (work); call put; return; end edit_old_parity; /* Edit old style op-not-complete fault */ edit_old_onc: proc; dcl onc_msgp ptr; dcl cpu_type bit (9); dcl 1 onc_msg aligned based (onc_msgp), 2 scu (8) bit (36), 2 inst_addr fixed bin (18), 2 inst (3) bit (36) aligned, 2 hist_reg (128) bit (36) aligned; onc_msgp = addr (syserr_msg.data); cpu_type = substr (scu (3), 19, 9); if moved > 0 then call put; call ioa_$rsnpnnl ("inst at ^o: ^w ^w ^w", rest, moved, onc_msg.inst_addr, onc_msg.inst); call put; call edit_scu (addr (onc_msg.scu)); call edit_hist (addr (onc_msg.hist_reg), cpu_type); return; end edit_old_onc; /* Edit old style startup and shutdown faults */ edit_old_startup: proc; dcl startup_msgp ptr; dcl 1 startup_msg aligned based (startup_msgp), 2 scu (8) bit (36) aligned; startup_msgp = addr (syserr_msg.data); call edit_scu (addr (startup_msg.scu)); return; end edit_old_startup; /* Edit message from mos memory EDAC error */ edit_mos_memory: proc; dcl edit_mos_rscr_ entry (ptr, char (*) var); call edit_mos_rscr_ (addr (syserr_msg.data), work); if room < length (work) then do; call edit_std; return; end; if length (work) > restl then call put; substr (rest, 1, length (work)) = work; moved = moved + length (work); return; end edit_mos_memory; /* Procedure called to print errors by interpreting status from syserr_log_util_$open */ open_err: entry (open_status, caller, code); dcl open_status bit (36) aligned; /* Set by syserr_log_util_$open */ dcl caller char (*); /* Name of caller for com_err_ */ dcl msg_time fixed bin (71); /* Time of a syserr message */ dcl msg_seq fixed bin (35); /* Sequence number */ dcl sw fixed bin; dcl code2 fixed bin (35); if substr (open_status, 1, 2) = "11"b then do; /* If all access needed is present */ code = 0; /* No error */ return; end; if substr (open_status, 1, 2) = "00"b then do; /* If no access */ call com_err_ (code, caller, "Unable to open syserr_log"); return; end; sw = 0; /* An ioa_ switch */ if substr (open_status, 1, 2) = "01"b then do; /* No access to current log */ call syserr_log_util_$search (-1, msg_time, msg_seq, code2); /* Get time of last message */ if code2 = 0 then do; /* It workd */ sw = 1; call date_time_ (msg_time, cur_time); end; call com_err_ (code, caller, "Current log not available. ^v(Permanent log ends ^a.^)", sw, cur_time); code = 0; return; end; else do; /* No access to permanent log */ call syserr_log_util_$search (0, msg_time, msg_seq, code2); /* Read oldest message */ if code2 = 0 then do; sw = 1; call date_time_ (msg_time, cur_time); end; call com_err_ (code, caller, "Permanent log not available. ^v(Current log starts ^a.^)", sw, cur_time); code = 0; return; end; end print_syserr_msg_;  print_urf.pl1 10/27/83 1614.3rew 10/27/83 1442.0 18468 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_urf: procedure options (variable); %include urf_entry; dcl argument char (al) based (ap); dcl (error_table_$bad_index, error_table_$no_record) fixed bin (35) external; dcl (ioa_, com_err_) entry options (variable); dcl cu_$arg_count entry returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl urf_manager_$get_abs_entry entry (fixed bin (35), char (*), ptr, fixed bin (35)); dcl urf_manager_$get_entry entry (char (*), ptr, fixed bin (35)); dcl 1 urfe aligned like urf_entry; dcl rec fixed bin (35); dcl i fixed bin; dcl ap ptr; dcl al fixed bin (21); dcl code fixed bin (35); dcl uid char (32); if cu_$arg_count () = 0 then do rec = 1 by 1; call urf_manager_$get_abs_entry (rec, uid, addr (urfe), code); if code = error_table_$bad_index then return; if code = 0 then call print_entry; else if code ^= error_table_$no_record then do; call com_err_ (code, "print_urf"); return; end; end; else do i = 1 by 1; call cu_$arg_ptr (i, ap, al, code); if code ^= 0 then return; uid = argument; call urf_manager_$get_entry (uid, addr (urfe), code); if code = 0 then call print_entry; else call com_err_ (code, "print_urf", "Getting entry for ^a.", uid); end; return; print_entry: procedure; call ioa_ ("^20a ^9a ^a ^a, ^[^a: ^;^s^]^a; ^a; ^a", uid, urfe.project, urfe.prog_number, urfe.last_name, (urfe.title ^= ""), urfe.title, urfe.first_name, urfe.address, urfe.notes); end; end;  remove_user.pl1 11/01/83 1112.9r w 11/01/83 1039.6 23400 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Modified July 1983 by B. Margolin to delete the corresponding Mail Table entry */ remove_user: procedure options (variable); declare iox_$user_input pointer external; declare pnt_manager_$remove_entry entry (character (*), fixed bin (35)), urf_manager_$remove_entry entry (character (*), fixed bin (35)), mail_table_priv_$delete entry (char (*) varying, bit (1), fixed bin (35)), cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)), cu_$arg_count entry returns (fixed bin), iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)), (com_err_, ioa_) entry options (variable); declare ME char (32) init ("remove_user") static options (constant); declare arg char (al) based (ap); declare al fixed bin (21), ap pointer, (nargs, i) fixed bin, uid character (32), code fixed bin (35); declare (addr, length, substr) builtin; nargs = cu_$arg_count (); if nargs = 0 then do; call ioa_ ("User ID:"); call iox_$get_line (iox_$user_input, addr (uid), length (uid), al, code); if code ^= 0 then do; call com_err_ (code, ME, "Reading user ID."); return; end; substr (uid, al) = ""; /* blank out rest of string */ call process (uid); end; else do i = 1 to nargs; call cu_$arg_ptr (i, ap, al, code); if code ^= 0 then do; call com_err_ (code, ME, "Getting argument ^d.", i); return; end; call process (arg); end; return; process: procedure (User); declare User char (*) parameter; declare code fixed bin (35); call pnt_manager_$remove_entry (User, code); if code ^= 0 then call com_err_ (code, ME, "Deleting PNT entry for ""^a"".", User); call urf_manager_$remove_entry (User, code); if code ^= 0 then call com_err_ (code, ME, "Deleting URF entry for ""^a"".", User); call mail_table_priv_$delete (rtrim (User), "1"b, code); if code ^= 0 then call com_err_ (code, ME, "Deleting Mail Table entry for ""^a"".", User); end process; end;  reset_cdt_meters.pl1 07/20/88 1249.0r w 07/19/88 1536.1 25245 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* RESET_CDT_METERS - Program to reset the meters kept by dialup_ in the header of the Channel Definition Table, and in each CDTE. Written 750818 by PG cleanup handler added by F.W. Martinson June 1982 */ reset_cdt_meters: procedure; /* entries */ dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)), com_err_ entry options (variable), expand_path_ entry (ptr, fixed bin (21), ptr, ptr, fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)); /* automatic */ dcl arg_len fixed bin (21), arg_ptr ptr, cdtex fixed bin, code fixed bin (35), dname char (168), ename char (32), now fixed bin (71); /* internal static initial */ dcl my_name char (16) internal static initial ("reset_cdt_meters"); /* based */ dcl arg_string char (arg_len) based (arg_ptr); /* builtins */ dcl (addr, clock, null) builtin; /* conditions */ dcl cleanup condition; /* include files */ %include author_dcl; %include cdt; %include dialup_values; /* program */ cdtp = null; on cleanup call clean_up; dname = ">system_control_1"; ename = "cdt"; call cu_$arg_ptr (1, arg_ptr, arg_len, code); if code = 0 then do; call expand_path_ (arg_ptr, arg_len, addr (dname), addr (ename), code); if code ^= 0 then do; call com_err_ (code, my_name, "^a", arg_string); return; end; end; call hcs_$initiate (dname, ename, "", 0, 1, cdtp, code); if cdtp = null then do; call com_err_ (code, my_name, "^a>^a", dname, ename); return; end; cdt.realtime_in_dialup = 0; cdt.cpu_in_dialup = 0; cdt.pf_in_dialup = 0; cdt.pp_in_dialup = 0; cdt.entries_to_dialup = 0; now = clock (); cdt.meters_last_reset = now; do cdtex = 1 to cdt.current_size; cdtep = addr (cdt.cdt_entry (cdtex)); cdte.n_dialups = 0; cdte.n_logins = 0; cdte.dialed_up_time = 0; if cdte.in_use < NOW_DIALED then cdte.dialup_time = 0; else cdte.dialup_time = now; end; call clean_up; return; clean_up: proc; if cdtp ^= null then call hcs_$terminate_noname (cdtp, code); return; end clean_up; end reset_cdt_meters;  restore_pdt_access.pl1 07/13/88 1112.5r w 07/13/88 0942.4 47682 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ restore_pdt_access: proc; /* RESTORE_PDT_ACCESS - This program can be run after a crash to regenerate the ACL's of the PDT's in >sc1>pdt, and also the ACL of >sc1>update. (Access control lists seem to be expecially vulnerable to crashes.) THVV 1/74 */ /* Modified March 1982 by E. N. Kittlitz to eliminate proj_admin_seg */ dcl pdtdir char (168) aligned int static init (">system_control_1>pdt"), pdtname char (32) aligned, sc1 char (168) aligned int static init (">system_control_1"), nacl fixed bin, sel_proj char (32) aligned init (""), sat_name char (32) aligned, datestr char (16) aligned, (i, ii, iii, m, lng, sm, slng, j, k) fixed bin, ec fixed bin (35), an fixed bin init (1), (argp, satp, satep) pointer, arg char (slng) based (argp), strn1 char (28) aligned init (""), ct fixed bin init (0), ct1 fixed bin init (0); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), com_err_ entry options (variable), ioa_ entry options (variable), ioa_$rsnnl entry options (variable), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), clock_ entry () returns (fixed bin (71)), date_time_ entry (fixed bin (71), char (*) aligned); dcl hcs_$add_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)); dcl 1 acls (6) aligned, 2 name char (32), 2 modes bit (36), 2 mbz bit (36), 2 erc fixed bin (35); dcl 1 dacls (6) aligned, 2 name char (32), 2 modes bit (36), 2 erc fixed bin (35); dcl (addr, null, fixed, substr) builtin; /* ================================================ */ %include sat; %include user_attributes; /* ================================================ */ /* INITIALIZATION - LOCATE AND INITIATE SAT */ do j = 1 to 6; /* Set up acl structures. */ acls.mbz (j) = "0"b; acls.modes (j) = "100"b; /* "R" access for pdt */ dacls.modes (j) = "001"b; /* "A" access for dir update */ end; acls.name (1) = "*.SysDaemon.*"; acls.name (2) = "*.SysAdmin.*"; acls.modes (1), acls.modes (2) = "101"b; /* These guys get RW. */ call hcs_$initiate (sc1, "sat", "", 0, 0, satp, ec); if satp = null then do; call com_err_ (ec, "restore_pdt_access", "sat"); return; end; if sat.version ^= SAT_version then do; call com_err_ (0, "restore_pdt_access", "SAT version is inconsistent with declarations used by this program"); go to exit; end; arglp: call cu_$arg_ptr (an, argp, slng, ec); /* get next arg -- a project name */ if ec ^= 0 then go to endarg; /* last arg? */ else do; sel_proj = arg; end; next_arg: an = an + 1; go to arglp; /* loop on args */ endarg: if sel_proj ^= "" then go to quickie; quickie: do i = 1 to sat.current_size; /* loop thru SAT looking for delegated projects */ satep = addr (sat.project (i)); /* get ptr to slide down sat entries */ if project.state = 1 then do; if sel_proj ^= "" then if sel_proj ^= project.project_id then go to endsatloop; ct = ct + 1; /* Count all valid projects found. */ call ioa_$rsnnl ("^a.pdt", pdtname, k, project.project_id); if project.admin (1).userid = "" then do; call hcs_$add_acl_entries (pdtdir, pdtname, addr (acls), 2, ec); if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot set ACL of ^a", pdtname); end; else do; ct1 = ct1 + 1; nacl = 0; /* Found pdt to be fixed. */ do j = 1 to 4; /* Make up acls. */ acls.name (j+2) = project.admin.userid (j); if acls.name (j+2) = "" then go to setit; k = index (acls.name (j+2), " "); substr (acls.name (j+2), k, 2) = ".*"; dacls.name (j) = acls.name (j+2); nacl = nacl + 1; end; setit: call hcs_$add_acl_entries (pdtdir, pdtname, addr (acls), nacl+2, ec); if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot restore ACL of ^a", pdtname); call hcs_$add_dir_acl_entries (sc1, "update", addr (dacls), nacl, ec); if ec ^= 0 then call com_err_ (ec, "restore_pdt_access", "Cannot add ACL to update: ^a", project.project_id); end; end; endsatloop: end; if sel_proj ^= "" then if ct = 0 then do; call ioa_ (" Project ^a not found in SAT", sel_proj); end; else if ct1 = 0 then do; call ioa_ ("^a is not currently a delegated project", sel_proj); end; exit: call hcs_$terminate_noname (satp, ec); return; end restore_pdt_access;  search_sat_.pl1 07/13/88 1112.5r w 07/13/88 0942.4 52659 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style4 */ /* Written Feb 1980 by M. B. Armstrong to implement multiple rate structures. (UNCA) Modified June 1981 by E. N. Kittlitz to implement UNCA rate structures. Modified June 1982 by E. N. Kittlitz to return initiate error code correctly. */ search_sat_: proc; /* this entry should not be called */ return; /* This procedure locates the named project in the sat and returns project information Current entry points are: search_sat_$rs_number (P_project, P_rs_number, error_code) return the rate_structure index search_sat_$sequential (P_first, P_project, P_rs_number, error_code) get the next entry in sat - first if P_first = "1"b search_sat_$clean_up reset internal static variables */ /* Parameters */ dcl P_code fixed bin (35); dcl P_project_name char (*); dcl P_first bit (1) aligned; dcl P_rs_number fixed bin; /* Automatic */ dcl satep ptr; dcl code fixed bin (35); /* Internal static */ dcl static_satx fixed bin internal static; /* index into sat projects */ dcl satp internal static ptr init (null); /* pointer to SAT */ dcl shtp internal static ptr init (null); /* pointer to SAT hash table */ dcl no_hash bit (1) aligned internal static init ("0"b); /* on if we couldn't find the sat.ht */ dcl no_sat bit (1) aligned internal static init ("0"b); /* on if we couldn't find the sat */ /* External entries */ dcl hash_$search entry (ptr, char (*), fixed bin, fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); /* file system */ /* External static */ dcl ( error_table_$noentry, error_table_$end_of_info ) external fixed bin (35); /* builtins and conditions */ dcl no_write_permission condition; dcl (addr, null) builtin; %page; /* =================================================== */ rs_number: entry (P_project_name, P_rs_number, P_code); /* This entry returns the rate index for the named project */ if ^setup () then do; P_rs_number = 0; go to error_return; end; satep = find_project (P_project_name); if satep = null then do; P_rs_number = 0; P_code = error_table_$noentry; end; else do; P_rs_number = project.rs_number; P_code = 0; end; return; /* =================================================== */ sequential: entry (P_first, P_project_name, P_rs_number, P_code); /* This entry will search the sat sequentially */ if ^setup () then do; P_project_name = ""; P_rs_number = 0; go to error_return; end; if P_first then static_satx = 0; /* start at the beginning */ next: static_satx = static_satx + 1; if static_satx > sat.current_size then do; /* all finished? */ P_project_name = ""; P_rs_number = 0; P_code = error_table_$end_of_info; return; end; satep = addr (sat.project (static_satx)); /* point to the project */ if project.state = 0 then goto next; /* not a valid entry */ P_project_name = project.project_id; P_rs_number = project.rs_number; P_code = 0; return; /* =================================================== */ clean_up: entry; /* This entry allows a process to clean up its KST */ call hcs_$terminate_noname (satp, code); /* clean up */ call hcs_$terminate_noname (shtp, code); /* clean up */ satp, shtp = null; /* reset internal static */ no_hash, no_sat = "0"b; static_satx = 0; return; error_return: if code ^= 0 then P_code = code; else P_code = error_table_$noentry; return; %page; find_project: proc (P_proj) returns (ptr); /* internal procedure to locate a project in the sat */ dcl P_proj char (*); dcl satx fixed bin; if ^no_hash then do; /* i.e. there is a hash table */ on no_write_permission begin; revert no_write_permission; no_hash = "1"b; goto sequential_search; /* too bad but them's the breaks */ end; call hash_$search (shtp, P_proj, satx, code);/* search the SAT hash table for project */ revert no_write_permission; if code = 0 then /* don't believe everything you're told */ if addr (sat.project (satx)) -> project.state ^= 0 & addr (sat.project (satx)) -> project.project_id = P_proj then return (addr (sat.project (satx))); end; sequential_search: do satx = 1 to sat.current_size; satep = addr (sat.project (satx)); /* point to a project */ if project.state ^= 0 then /* is it not a hole? */ if project.project_id = P_proj then return (addr (sat.project (satx))); end; return (null); /* couldn't find the project anywhere */ end find_project; setup: proc returns (bit (1) aligned); /* initiates the sat and the sat hash table */ code = 0; if no_sat then return ("0"b); if satp ^= null then return ("1"b); call hcs_$initiate (">system_control_dir", "sat", "", 0, 0, satp, code); if satp = null then do; no_hash = "1"b; no_sat = "1"b; return ("0"b); end; call hcs_$initiate (">system_control_dir", "sat.ht", "", 0, 0, shtp, code); if shtp = null then no_hash = "1"b; /* must search whole sat */ return ("1"b); end setup; %page; %include sat; %page; %include user_attributes; end search_sat_;  set_special_password.pl1 10/19/92 1615.2rew 10/19/92 1612.2 58752 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1989 * * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ /* set_special_password: Manipulates non-alias non-mte PNTE's */ /* format: style2 */ set_special_password: procedure options (variable); /* BIM 1984-10-08 */ /****^ HISTORY COMMENTS: 1) change(89-05-23,Beattie), approve(89-09-29,MCR8113), audit(89-10-02,Farley), install(89-10-03,MR12.3-1082): Display an appropriate error message if the add or update to the PNT operation returns a non-zero error code. 2) change(90-11-22,Vu), approve(90-11-22,MCR8230), audit(92-09-30,WAAnderson), install(92-10-19,MR12.5-1029): Query the user twice for the password by default. END HISTORY COMMENTS */ call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, ME); return; end; if arg_count = 0 then do; call com_err_$suppress_name (0, ME, USAGE_LINE); return; end; user_name = ""; user_index = 0; none_flag = "0"b; prompt_flag = "1"b; password_flag = "0"b; password = ""; do argx = 1 to arg_count; call cu_$arg_ptr (argx, ap, al, (0)); if index (argument, "-") ^= 1 then do; if user_name ^= "" then do; call com_err_ (0, ME, "More than one user name supplied."); return; end; user_name = argument; end; else if argument = "-none" then do; none_flag = "1"b; prompt_flag = "0"b; password = ""; end; else if argument = "-prompt" then do; prompt_flag = "1"b; none_flag = "0"b; password = ""; end; else if argument = "-password" then do; prompt_flag = "0"b; none_flag = "0"b; if argx = arg_count then do; call com_err_ (error_table_$noarg, ME, "A password must be given after -password"); return; end; argx = argx + 1; call cu_$arg_ptr (argx, ap, al, (0)); password = argument; end; else do; call com_err_ (error_table_$badopt, ME, USAGE_LINE); return; end; end; if user_name = "" then do; call com_err_ (error_table_$noarg, ME, USAGE_LINE); return; end; do user_index = 1 to hbound (SPECIAL_USER_NAME_ARRAY, 1); if user_name = SPECIAL_USER_NAME_ARRAY (user_index).command_line_name then go to HAVE_USER_INDEX; end; call com_err_ (0, ME, "The name ""^a"" is not a special person name.", user_name); return; HAVE_USER_INDEX: if prompt_flag then do; call read_password_ ("Password", password); save_password = password; password = " "; call read_password_ ("Password Again", password); if password ^= save_password then do; call com_err_$suppress_name (0, ME, "Password typed incorrectly second time."); call com_err_$suppress_name (0, ME, "Password has not been changed."); password = " "; save_password = " "; return; end; save_password = " "; end; if ^none_flag then password = scramble_ (password); else password = ""; pnt_entry_name = SPECIAL_USER_NAME_ARRAY (user_index).pnte_entry_name; unspec (PNTE) = ""b; call pnt_manager_$admin_get_entry (pnt_entry_name, addr (PNTE), code); if code = 0 then update = "1"b; else if code = error_table_$id_not_found then do; update = "0"b; unspec (PNTE) = ""b; PNTE.version = PNT_ENTRY_VERSION_2; PNTE.user_id = pnt_entry_name; end; else do; call com_err_ (code, ME, "Looking in PNT for ^a", pnt_entry_name); return; end; PNTE.private.pw_flags.short_pw = "1"b; PNTE.password = password; PNTE.alias = ""; PNTE.default_project = ""; PNTE.flags = "0"b; PNTE.flags.trap, PNTE.flags.lock = "1"b; PNTE.flags.has_password = (password ^= ""); if update then call pnt_manager_$update_entry (addr (PNTE), "1"b, "0"b, code); /* set password, leave network PW alone */ else call pnt_manager_$add_entry (pnt_entry_name, addr (PNTE), code); if code ^= 0 then call com_err_ (code, ME, "Error encountered while ^[updating^;adding to^] the PNT.", update); return; %page; declare com_err_ entry () options (variable); declare com_err_$suppress_name entry () options (variable); declare cu_$arg_count entry (fixed bin, fixed bin (35)); declare cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); declare pnt_manager_$admin_get_entry entry (char (*), pointer, fixed bin (35)); declare pnt_manager_$update_entry entry (pointer, bit (1) aligned, bit (1) aligned, fixed bin (35)); declare pnt_manager_$add_entry entry (char (*), pointer, fixed bin (35)); declare read_password_ entry (character (*), character (*)); declare scramble_ entry (character (8)) returns (character (8)); declare error_table_$badopt fixed bin (35) ext static; declare error_table_$id_not_found fixed bin (35) ext static; declare error_table_$noarg fixed bin (35) ext static; declare arg_count fixed bin; declare argx fixed bin; declare ap pointer; declare al fixed bin (21); declare argument char (al) based (ap); declare code fixed bin (35); declare ME char (20) int static options (constant) init ("set_special_password"); declare none_flag bit (1) aligned; declare prompt_flag bit (1) aligned; declare password_flag bit (1) aligned; declare password char (8); declare pnt_entry_name char (32); declare save_password char (8); declare USAGE_LINE char (80) int static options (constant) init ( "Usage: set_special_password special_person_name -prompt|-none|-password PASSWORD" ); declare user_index fixed bin; declare user_name char (32); declare update bit (1) aligned; declare 1 PNTE aligned like pnt_entry; declare addr builtin; declare hbound builtin; declare index builtin; declare unspec builtin; %page; %include pnt_entry; %page; %include special_person_names; end set_special_password;  set_system_console.pl1 03/25/86 0848.0r 03/25/86 0847.6 117468 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: off */ set_system_console: ssc: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Purpose: */ /* */ /* This module implements the set_system_console operator console reconfiguration command. Its */ /* sole charter in life is to manipulate operator's consoles. */ /* */ /* Syntax: */ /* */ /* set_system_console {console_name} {-control_arg} */ /* */ /* Arguments: */ /* */ /* console_name - Is the name of the console to be affected by the call. If ommitted */ /* the bootload console is assumed. */ /* */ /* Control arguments: */ /* */ /* -crash specifies that the system is to crash if all attempts at console */ /* recovery fail. */ /* */ /* -reset resets the bootload console. The given console_name is ignored. */ /* */ /* -run specifies that the system should continue to run as long as possible */ /* without a configured console should all attempts at recovery fail. */ /* */ /* -state specifies that the state of the console should be changed to the */ /* given state. The state may have any of the following values: */ /* */ /* on makes the specified console the bootload console. The current */ /* bootload console becomes an I/O device. */ /* */ /* alt makes the specified console an alternate console, available for use */ /* by console recovery. */ /* */ /* io makes the specified console an I/O device, available to IOI. */ /* */ /* inop makes the specified console an I/O device, available to IOI. */ /* */ /* The following control arguments are undocumented and are provided for system debug purposes: */ /* */ /* -enable enables the previously disabled console service. */ /* */ /* -disable */ /* -suspend both of these arguments can be used to disable / suspend console */ /* service. If the service is suspended the actions of the system will */ /* be subject to the current crash / run state. If the system is setup */ /* to crash on console recovery, it will. */ /* */ /* Note: Access to hphcs_ is required to utilize this command. */ /* */ /* Initial Coding: 830820 */ /* */ /* Author: E. A. Ranzenbach (Ranzenbach.Multics@M) */ /* Location: System-M. */ /* Release: MR10.2 */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Modifications: */ /* */ /* Date: Author Reason */ /* */ /* 840420 Edward A. Ranzenbach Added -prompt control argument. */ /* */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call process_arguments (); /* get command options... */ if setting_prompt then do; call hphcs_$ocdcm_set_prompt (prompt_string); return; end; if reconfiguring then do; if reconfig_option = RESET_CONSOLE then console_name = ""; /* can only reset the bootload console..*/ call hphcs_$ocdcm_reconfigure (console_name, reconfig_option, code); /* and let's do it... */ if code ^= 0 then call err (exit, code, "Operation failed."); end; return; /* done... */ process_arguments: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Internal procedure to obtain the argument count, check it for high and low bounds, and last but */ /* not least process the command arguments... */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ min_arg_count = 1; max_arg_count = 5; command_name = "set_system_console"; call cu_$af_arg_count (arg_count, code); if code = 0 then do; call err (exit, error_table_$active_function, command_name); /* can't be invoked as an AF... */ end; else if code ^= error_table_$not_act_fnc then do; call err (exit, code, command_name); end; else code = 0; if (arg_count < min_arg_count | arg_count > max_arg_count) then do; USAGE: call ioa_$rs ("Usage:^-^a {console_name} {-control_args}", err_msg, 0, command_name); call err (exit, code, err_msg); end; do idx = 1 to arg_count; good_arg = false; call cu_$arg_ptr (idx, arg_ptr, arg_leng, code); if code ^= 0 then call err (exit, code, "Unable to obtain arg_ptr"); if arg_leng = 0 then call err (exit, error_table_$badopt, "Null input arguments are not allowed."); if substr (arg, 1, 1) = "-" then do; /* must be a control argument... */ if arg = "-crash" then do; /* -crash control argument... */ reconfiguring = true; reconfig_option = CRASH_ON_CRF; /* setup reconfiguration option... */ end; else if arg = "-run" then do; /* -run control argument... */ reconfig_option = RUN_ON_CRF; /* setup reconfiguration option... */ reconfiguring = true; end; else if arg = "-enable" then do; /* -enable control argument... */ reconfig_option = ENABLE_CONSOLE_SERVICE; /* setup reconfiguration option... */ reconfiguring = true; end; else if arg = "-suspend" | arg = "-disable" then do; /* -suspend | -disable control arg... */ reconfig_option = SUSPEND_CONSOLE_SERVICE; /* setup reconfiguration option... */ reconfiguring = true; end; else if arg = "-reset" then do; /* -reset control argument... */ reconfig_option = RESET_CONSOLE; /* setup reconfiguration option... */ reconfiguring = true; end; else if arg = "-state" then do; /* -state control argument... */ reconfiguring = true; idx = idx + 1; /* get the requested state... */ if idx > arg_count then call err (exit, error_table_$wrong_no_of_args, "A state must be supplied."); call cu_$arg_ptr (idx, arg_ptr, arg_leng, code); if code ^= 0 then call err (exit, code, "Unable to get state."); if arg = "on" then do; /* ON state... */ reconfig_option = MAKE_BOOTLOAD_CONSOLE; /* setup reconfiguration option... */ end; else if arg = "alt" then do; /* ALT state... */ reconfig_option = MAKE_ALTERNATE_CONSOLE; /* setup reconfiguration option... */ end; else if arg = "io" then do; /* IO state... */ reconfig_option = MAKE_IO_DEVICE; /* setup reconfiguration option... */ end; else if arg = "inop" then do; /* INOP state... */ reconfig_option = MAKE_INOP_DEVICE; /* setup reconfiguration option... */ end; else if arg = "off" then do; /* OFF state... */ reconfig_option = MAKE_UNAVAILABLE; /* setup reconfiguration option... */ end; else do; /* BAD state... */ call ioa_$rs ("^a is not a legal console state.", err_msg, 0, arg); call err (exit, 0, err_msg); /* and let them know... */ end; end; else if arg = "-prompt" then do; /* setting_prompt = true; UNCOMMENT FOR -prompt FEATURE */ idx = idx + 1; /* get the requested prompt... */ if idx <= arg_count then do; /* get specified prompt... */ call cu_$arg_ptr (idx, arg_ptr, arg_leng, code); if code ^= 0 then call err (exit, code, "Unable to get prompt string."); prompt_string = arg; end; end; else do; code = error_table_$badopt; /* setup the proper error... */ call err (exit, code, arg); /* and let them know... */ end; end; else do; /* must be the console_name... */ if arg_leng = 4 then do; /* console names are that long... */ if substr (arg, 1, 3) = "opc" then do; /* do some preliminary checking... */ if search (substr (arg, 4, 1), "abcdefgh") = 1 then do;/* must have "opcx" type name... */ console_name = arg; /* console name looks OK... */ good_arg = true; end; end; end; if ^good_arg then do; /* BAD console name... */ call ioa_$rs ("^a is not a legal console name.", err_msg, 0, arg); call err (exit, 0, err_msg); /* let them know... */ end; end; end; return; end process_arguments; err: proc (exit_sw, err_code, ctl_str); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Internal procedure that reports errors to the user and optionally exits then main procedure. */ /* This last function is dependant upon the value of exit_sw. If found to be on a non-local go to */ /* is made to the "EXIT" label in the main procedure. If off this procedure returns to its caller. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* parameters... (I) = Input, (O) = Output */ dcl exit_sw bit (1) parameter; /* to exit or not to exit... (I) */ dcl err_code fixed bin (35) parameter; /* passed to com_err_... (I) */ dcl ctl_str char (*) parameter; /* optional com_err_ ctl string... (I) */ /* entries... */ dcl com_err_ entry() options(variable); dcl requote_string_ entry (char(*)) returns(char(*)); /* miscellaneous... */ dcl requoted_ctl_str char (256) init (""); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if index (ctl_str, """") > 0 then do; requoted_ctl_str = requote_string_ (ctl_str); call com_err_ (err_code, command_name, requoted_ctl_str); end; else do; call com_err_ (err_code, command_name, ctl_str); end; if exit_sw then go to EXIT; return; end err; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Declarations... */ /* format: off */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* entries... */ dcl cu_$af_arg_count entry (fixed bin, fixed bin(35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl hphcs_$ocdcm_reconfigure entry (char (4), fixed bin (17), fixed bin (35)); dcl ioa_$rs entry() options(variable); dcl hphcs_$ocdcm_set_prompt entry (char (6)); /* builtins... */ dcl index builtin; dcl null builtin; dcl search builtin; dcl substr builtin; /* pointers... */ dcl arg_ptr ptr init (null); /* -> argument... */ /* switches... */ dcl true bit (1) init ("1"b) internal static options (constant); dcl false bit (1) init ("0"b) internal static options (constant); dcl exit bit (1) init ("1"b) /* exit -> fatal error... */ internal static options (constant); dcl good_arg bit (1) init ("0"b); /* ON => valid argument... */ dcl reconfiguring bit (1) init ("0"b); /* ON => were reconfiguring consoles... */ dcl setting_prompt bit (1) init ("0"b); /* ON => were changing prompt... */ /* error_table_... */ dcl error_table_$active_function fixed bin (35) external static; dcl error_table_$badopt fixed bin (35) external static; dcl error_table_$not_act_fnc fixed bin (35) external static; dcl error_table_$wrong_no_of_args fixed bin (35) external static; /* miscellaneous... */ dcl arg char (arg_leng) /* argument... */ based (arg_ptr); dcl arg_count fixed bin (17) init (0); /* number of arguments... */ dcl arg_leng fixed bin (21) init (0); /* length, (in bytes), of argument... */ dcl command_name char (32) init (""); dcl console_name char (4) init (""); /* name of the console to be affected...*/ dcl code fixed bin (35) init (0); /* standard Multics error code... */ dcl err_msg char (80) init (""); /* to report errors... */ dcl idx fixed bin (17) init (0); /* miscellaneous working index... */ dcl min_arg_count fixed bin (17) init (0); /* minimum number of arguments... */ dcl max_arg_count fixed bin (17) init (0); /* maximum number of arguments... */ dcl prompt_string char (6) init (""); dcl reconfig_option fixed bin (17) init (0); /* action to take... */ /* includes... */ %include opc_reconfig_options; EXIT: return; end set_system_console;  sweep_disk_.pl1 10/27/83 1614.3rew 10/27/83 1442.0 66879 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ sweep_disk_: proc (path, counter); /* SWEEP_DISK_ - driver for statistics programs. This program is called with a pathname, the root node of a tree to sweep, and a function, which will be called for each directory entry. The program recursively walks down the directory tree and calls the user function for each entry found. This version of the program will try to give itself access if it doesn't have it THVV Modified on 9 September 1976 by R. G. Bratt to not terminate and to use (get release)_temp_segments_. Modified on 5 June 1975 by J. C. Whitmore to attempt to set system privileges. sweep_disk_$dir_list entry point added to call hcs_$star_dir_list_ 05/29/79 S. Herbst */ dcl path char (168) aligned, /* path name to sweep */ counter entry (char (168) aligned, char (32) aligned, fixed bin, char (32) aligned, ptr, ptr); dcl areap ptr, /* ptr to area segment. */ one_ptr (1) ptr init (null), myname char (11) init ("sweep_disk_") static options (constant), ec fixed bin (35); /* err code */ dcl bfsw bit (1) int static init ("1"b); /* default will suppress non fatal errors */ dcl dir_list_sw bit (1); /* ON: sweep_disk_$dir_list */ dcl priv_set bit (1); /* flag to tell that system privileges are off */ dcl priv fixed bin (35); /* this will be zero if we set system privileges */ dcl sys_info$max_seg_size fixed bin (35) ext; dcl 1 acla (1) aligned, 2 userid char (32), 2 modes bit (36), 2 erc fixed bin (35); dcl 1 delacla (1) aligned, 2 userid char (32), 2 erc fixed bin (35); dcl com_err_ entry options (variable), get_group_id_ entry () returns (char (32) aligned), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), area_ entry (fixed bin (35), ptr); dcl error_table_$ai_restricted fixed bin (35) ext; dcl system_privilege_$dir_priv_on entry (fixed bin (35)); dcl system_privilege_$dir_priv_off entry (fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_dir_acl_entries entry (char (*) aligned, char (*) aligned, ptr, fixed bin, fixed bin (35)); dcl (hcs_$star_list_, hcs_$star_dir_list_) entry (char (*) aligned, char (*) aligned, fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl (cleanup, linkage_error) condition; dcl (addr, fixed, index, null, substr) builtin; /* - - - - */ dir_list_sw = "0"b; /* sweep_disk_ entry */ go to COMMON; dir_list: entry (path, counter); dir_list_sw = "1"b; COMMON: call get_temp_segments_ (myname, one_ptr, ec); areap = one_ptr (1); call area_ (sys_info$max_seg_size, areap); acla (1).userid = get_group_id_ (); delacla (1).userid = acla (1).userid; acla (1).modes = "111"b; priv_set = "0"b; priv = 1; on cleanup call clean_up; /* so we can undo what we did */ call process (path, 0, dir_list_sw); /* start recursion */ call clean_up; return; /* Done. */ /* - - - - - - - - - - - - - - */ process: proc (apth, lvl, asw); /* internal doit procedure */ dcl apth char (168) aligned, /* path of tree to process */ lvl fixed bin, /* recursion level */ asw bit (1); /* ON: star_dir_list_; OFF: star_list_ */ dcl npth char (168) aligned, /* new path for recursion */ dstar char (32) aligned init ("**") internal static, /* for star, gets all. */ ddn char (168) aligned, /* ... for expand */ een char (32) aligned, /* ... */ c32 char (32) aligned, error_table_$nomatch fixed bin ext, ifail fixed bin (35), (eptr, nptr) ptr init (null), /* for star */ ecc fixed bin (35), (t, bcount, lc, ii, nix) fixed bin; /* indices */ dcl names (100) char (32) aligned based (nptr); /* Structure returned by star_ */ dcl 1 branches (100) aligned based (eptr), /* ... */ 2 type bit (2) unaligned, /* 10b is directory */ 2 nnam bit (16) unaligned, /* number of names this seg */ 2 nindex bit (18) unaligned, /* index in names structure */ 2 padx bit (108) unaligned; on cleanup begin; if eptr ^= null then free eptr -> branches; if nptr ^= null then free nptr -> names; if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc); end; t = index (apth, " ") - 1; call expand_path_ (addr (apth), t, addr (ddn), addr (een), ecc); if ecc ^= 0 then do; call com_err_ (ecc, myname, apth); return; end; RETRY: call hcs_$add_dir_acl_entries (ddn, een, addr (acla), 1, ifail); if ifail ^= 0 then if ifail = error_table_$ai_restricted & ^priv_set then do; on linkage_error go to REVERT_HANDLER; call system_privilege_$dir_priv_on (priv); priv_set = "1"b; REVERT_HANDLER: revert linkage_error; if ^priv_set then do; /* linkage_error */ if ^bfsw then call com_err_ (0, myname, "Unable to set directory privilege. Cannot reference AIM-restricted directory."); priv = 1; end; priv_set = "1"b; /* try only once to set priv */ go to RETRY; end; if asw then call hcs_$star_dir_list_ (apth, dstar, 111b, areap, bcount, lc, eptr, nptr, ecc); else call hcs_$star_list_ (apth, dstar, 111b, areap, bcount, lc, eptr, nptr, ecc); if ecc = error_table_$nomatch then go to pexit; /* Get all names. If none, go. */ if ecc ^= 0 then do; /* If any other error from star, name it. */ if ^bfsw then call com_err_ (ecc, myname, "Error listing contents of ^a", apth); go to pexit; end; inloop: do ii = 1 to bcount + lc; /* Now do all branches, look for sub-dirs. */ nix = fixed (eptr -> branches (ii).nindex); c32 = nptr -> names (nix); call counter (ddn, een, lvl, c32, addr (eptr -> branches (ii)), nptr); if eptr -> branches (ii).type = "10"b then do; if t > 1 then /* Fabricate path name. */ npth = substr (apth, 1, t) || ">" || c32; else do; /* The root is special. */ npth = ">" || c32; if npth = ">process_dir_dir" then go to nopdir; if npth = ">pdd" then go to nopdir; if npth = ">PDD" then go to nopdir; end; call process (npth, lvl+1, asw); /* recursion here */ nopdir: end; end inloop; free eptr -> branches; /* Clean up area. */ free nptr -> names; /* ... */ pexit: if ifail = 0 then call hcs_$delete_dir_acl_entries (ddn, een, addr (delacla), 1, ecc); end process; /* Whew. */ loud: entry; /* entry to print more error messages */ bfsw = "0"b; return; clean_up: proc; if priv = 0 then call system_privilege_$dir_priv_off (priv); if one_ptr (1) ^= null () then call release_temp_segments_ (myname, one_ptr, ec); return; end clean_up; end;  syserr_log_util_.pl1 03/14/85 0810.8r w 03/13/85 1100.2 88047 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1984 * * * *********************************************************** */ syserr_log_util_: procedure (); /* * SYSERR_LOG_UTIL_ * * Interim version of syserr interface to new logging software, to be used * until all relevant programs have been converted to use log_read_ instead. * * 84-09-30, W. Olin Sibert: Initial coding * 1985-01-21, BIM, EJ Sharpe: reverse-convert new data classes. */ declare P_pathname char (*) parameter; declare P_access bit (36) aligned parameter; declare P_buffer_ptr pointer parameter; declare P_buffer_lth fixed bin parameter; declare P_message_lth fixed bin parameter; declare P_search_time fixed bin (71) parameter; declare P_position fixed bin (35) parameter; declare P_message_time fixed bin (71) parameter; declare P_message_sequence fixed bin (35) parameter; declare P_status_ptr pointer parameter; declare P_code fixed bin (35) parameter; declare binary_present bit (1) aligned; declare data_idx fixed bin; declare log_dname char (168); declare log_ename char (32); declare new_binary bit (1) aligned; declare old_data_class fixed bin (35); declare position_idx fixed bin (35); declare temp_code fixed bin (35); declare this_lth fixed bin; declare static_read_data_ptr pointer internal static init (null ()); declare static_message_ptr pointer internal static init (null ()); declare static_open_count fixed bin internal static init (0); declare error_table_$end_of_info fixed bin (35) external static; declare error_table_$long_record fixed bin (35) external static; declare error_table_$no_log_message fixed bin (35) external static; declare error_table_$not_open fixed bin (35) external static; declare error_table_$unsupported_operation fixed bin (35) external static; declare log_data_$syserr_log_dir char (168) external static; declare log_data_$syserr_log_name char (32) external static; declare com_err_ entry options (variable); declare expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); declare log_read_$close entry (pointer, fixed bin (35)); declare log_read_$next_message entry (pointer, pointer, fixed bin (35)); declare log_read_$open entry (char (*), char (*), pointer, fixed bin (35)); declare log_read_$position_time entry (pointer, fixed bin (71), bit (1) aligned, pointer, fixed bin (35)); declare log_read_$prev_message entry (pointer, pointer, fixed bin (35)); declare (abs, binary, currentsize, dimension, divide, hbound, length, max, null, size) builtin; /* */ syserr_log_util_$open: entry (P_access, P_code); log_dname = log_data_$syserr_log_dir; log_ename = log_data_$syserr_log_name; goto OPEN_COMMON; syserr_log_util_$open_path: entry (P_pathname, P_access, P_code); if (P_pathname = "") then do; log_dname = log_data_$syserr_log_dir; log_ename = log_data_$syserr_log_name; end; else do; call expand_pathname_ (P_pathname, log_dname, log_ename, P_code); if (P_code ^= 0) then return; end; OPEN_COMMON: if (static_read_data_ptr = null ()) then do; call log_read_$open (log_dname, log_ename, static_read_data_ptr, P_code); if (P_code ^= 0) then /* Open failed */ return; end; static_open_count = static_open_count + 1; /* Once open, position to the first message in the log */ call log_read_$position_time (static_read_data_ptr, 0, "1"b, static_message_ptr, P_code); P_access = "11"b; return; /* */ syserr_log_util_$close: entry (P_code); if (static_read_data_ptr ^= null ()) then do; call log_read_$close (static_read_data_ptr, (0)); static_open_count = static_open_count - 1; static_message_ptr = null (); end; P_code = 0; return; /* */ syserr_log_util_$read: entry (P_buffer_ptr, P_buffer_lth, P_message_lth, P_code); /* This entry converts from old format to new format */ if (static_read_data_ptr = null ()) then do; P_code = error_table_$not_open; return; end; if (static_message_ptr = null ()) then do; P_code = error_table_$end_of_info; /* Let our caller know we're done */ return; end; log_message_ptr = static_message_ptr; /* New format (input) */ syserr_msgp = P_buffer_ptr; /* Old format (output) */ P_message_lth = 0; /**** Investigate the data class, if any */ if dimension (log_message.data, 1) = 0 then binary_present = "0"b; else do; binary_present = "1"b; if log_message.data_class = "syserr" then new_binary = "0"b; /* old data class is tucked into first word of binary */ /* this was a compatability feature used across several implementation phases of the new logger */ else do; new_binary = "1"b; /* old data class not in message */ call convert_data_class (old_data_class); if old_data_class = -1 /* unrecognized? */ then binary_present = "0"b; /* ignore it */ end; end; this_lth = size (syserr_msg); /* Evaluate WITHOUT refer extents, to get header size only */ this_lth = this_lth + divide ((3 + length (log_message.text)), 4, 17, 0); if binary_present then if new_binary then this_lth = this_lth + dimension (log_message.data, 1); /* binary is already the right length */ else this_lth = this_lth + max (0, dimension (log_message.data, 1) - 1); /* in old case, remove the word with the data class */ if (this_lth > P_buffer_lth) then do; P_code = error_table_$long_record; return; end; syserr_msg.seq_num = log_message.sequence; syserr_msg.time = log_message.time; syserr_msg.code = log_message.severity; syserr_msg.text_len = length (log_message.text); syserr_msg.text = log_message.text; syserr_msg.pad = ""b; if binary_present then do; if ^new_binary then do; syserr_msg.data_code = binary (log_message.data (1)); syserr_msg.data_size = dimension (log_message.data, 1) - 1; do data_idx = 2 to dimension (log_message.data, 1); syserr_msg.data (data_idx - 1) = log_message.data (data_idx); end; end; else do; syserr_msg.data_code = old_data_class; syserr_msg.data_size = dimension (log_message.data, 1); syserr_msg.data (*) = log_message.data (*); end; end; else do; syserr_msg.data_code = 0; syserr_msg.data_size = 0; end; call log_read_$next_message (static_read_data_ptr, static_message_ptr, temp_code); if (temp_code = error_table_$no_log_message) then /* Prevent reading at the next call */ static_message_ptr = null (); P_message_lth = currentsize (syserr_msg); P_code = 0; return; /* */ syserr_log_util_$search: entry (P_search_time, P_message_time, P_message_sequence, P_code); if (static_read_data_ptr = null ()) then do; P_code = error_table_$not_open; return; end; if (P_search_time >= 0) then call log_read_$position_time (static_read_data_ptr, P_search_time, "1"b, static_message_ptr, P_code); else call log_read_$position_time (static_read_data_ptr, 1f70b, "0"b, static_message_ptr, P_code); if (P_code ^= 0) then return; P_message_time = static_message_ptr -> log_message.time; P_message_sequence = static_message_ptr -> log_message.sequence; P_code = 0; return; /* */ syserr_log_util_$position: entry (P_position, P_message_time, P_message_sequence, P_code); if (static_read_data_ptr = null ()) then do; P_code = error_table_$not_open; return; end; do position_idx = 1 to abs (P_position); if (P_position > 0) then call log_read_$next_message (static_read_data_ptr, static_message_ptr, P_code); else call log_read_$prev_message (static_read_data_ptr, static_message_ptr, P_code); if (P_code ^= 0) then return; end; P_message_time = static_message_ptr -> log_message.time; P_message_sequence = static_message_ptr -> log_message.sequence; P_code = 0; return; /* */ /* Some unsupported or useless entrypoints */ syserr_log_util_$debug: entry (); return; syserr_log_util_$trim: entry (P_search_time, P_code); goto TRIM_COMMON; syserr_log_util_$trim_path: entry (P_pathname, P_search_time, P_code); TRIM_COMMON: call com_err_ (0, "syserr_log_util_", "New format logs can only be trimmed with date_deleter."); P_code = error_table_$unsupported_operation; return; syserr_log_util_$status: entry (P_status_ptr, P_code);; declare 1 so_called_syserr_log_status aligned based, 2 version fixed bin; P_status_ptr -> so_called_syserr_log_status.version = 1; P_code = 0; return; convert_data_class: procedure (data_class); declare data_class fixed bin (35); declare i fixed bin; /**** This converts character string data classes back into fixed bin ones. Note that some data is lost --- e.g. there is no distinguishing "disk_err" and "ioi" messages, they are both of new class io_status. */ data_class = -1; do i = 1 to hbound(SB_char_data_classes, 1) while (data_class = -1); if log_message.data_class = SB_char_data_classes(i) then data_class = i; /* pick up index of first match */ end; if data_class = -1 then return; /* didn't find a match */ /* we can make a better guess on the io_status data */ if log_message.data_class = "io_status" then if dimension (log_message.data, 1) > size (io_msg) then data_class = SB_io_err_detail; else data_class = SB_io_err; return; end convert_data_class; %page; %include log_message; %page; %include syserr_message; %page; %include syserr_binary_def; %page; %include io_syserr_msg; end syserr_log_util_;  unlock_oc.pl1 10/27/83 1614.3rew 10/27/83 1442.0 8685 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ /* Command to unlock the operator's console when it appears to be "dead" */ /* Modified: 19 March 1979 by D. Spector: created Modified: 830821 to obsolete the command... -E. A. Ranzenbach */ /* Requires access to gate hphcs_ */ unlock_oc: procedure; declare com_err_ entry options (variable); START_unlock_oc: call com_err_ (0, "unlock_oc", "This command is obsolete.^/To reset the console type ""set_system_console -reset""."); end unlock_oc; /* unlock_oc */  terminal_report.pl1 07/13/88 1112.5r w 07/13/88 0942.4 295938 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1986 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-11-12,Parisek), approve(86-12-18,MCR7588), audit(87-07-17,Johnson), install(87-08-07,MR12.1-1070): Initially coded to scan the system answering service logs for login and logout messages, and build a list of used terminal types based on this information. END HISTORY COMMENTS */ terminal_report: proc; log_read_ptr, log_message_ptr, vptr, sci_ptr, vptr_ansb, vptr_two, temp_ptr, temp_two_ptr, ttp_tot_ptr, temp_as_ptr = null (); on cleanup begin; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); end; call ssu_$standalone_invocation (sci_ptr, "terminal_report", "1.0", cu_$arg_list_ptr (), ssu_abort, code); if code ^= 0 then do; call com_err_ (code, "terminal_report", "Failed to create ssu_ invocation."); return; end; /* Using ssu_ entries because calls to log subroutines require the sci_ptr */ call initialize_options (); on condition (cleanup) call clean_up (); call log_match_$add_match (opt.lmd_ptr, "LOGIN"); /* scan the logs for LOGIN messages only */ call process_arguments (); /* validate arguments */ if ttpsw & usersw then do; call ssu_$abort_line (sci_ptr, error_table_$inconsistent, "-user and -ttp"); call clean_up; end; if output_file ^= "" then do; /* not default */ call iox_$attach_name ("terminal_report_output", opt.iocb, "vfile_ " || output_file, null, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Could not attach to ^a", output_file); call clean_up (); end; attached = "1"b; /* output file is attached */ call iox_$open (opt.iocb, 2, ""b, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Could not open file ^a", output_file); call iox_$detach_iocb (opt.iocb, code); call clean_up (); end; opened = "1"b; /* output file is opened */ end; if opt.reader_procedure = "" then do; call log_read_$open (">sc1>as_logs", "log", log_read_ptr, code); end; /* get ptr to log segment */ if code ^= 0 then call ssu_$abort_line (sci_ptr, code, "Cannot open log"); call log_limit_scan_ (sci_ptr, addr(opt.limit), "0"b, log_read_ptr); /* determine where to start & stop in log scanning */ log_message_ptr = opt.first_msg; first_msg_count, ansb_msg_count, index_count = 0; /* initialize */ call get_temp_segments_ ("terminal_report", temp_ptrs, code); if code ^= 0 then do; call com_err_ (code, "terminal_report", "Error opening temporary segment."); call clean_up (); end; temp_ptr = temp_ptrs (1); temp_as_ptr = temp_ptrs (2); temp_two_ptr = temp_ptrs (3); ttp = temp_ptrs (4); ttp_tot_ptr = temp_ptrs (5); on condition (out_of_bounds) call oob (); /* it's possible we will fill a temp segment past 255K */ call system_info_$titles (coxx, dpxx, cods, dpds); /* Report banner stuff */ call ioa_$ioa_switch (opt.iocb, "^a^/^a^/", cods, dpds); if opt.first_msg = null () then call ioa_$ioa_switch (opt.iocb, "Terminal report to ^a^3/", log_format_time_ ((opt.last_msg -> log_message.time))); else if opt.last_msg = null () then call ioa_$ioa_switch (opt.iocb, "Terminal report from ^a^3/", log_format_time_ ((opt.first_msg -> log_message.time))); else call ioa_$ioa_switch (opt.iocb, "Terminal report from ^a to ^a^3/", log_format_time_ ((opt.first_msg -> log_message.time)), log_format_time_ ((opt.last_msg -> log_message.time))); scan_log: do while (log_message_ptr ^= null ()); if log_match_$test (opt.lmd_ptr, log_message_ptr, "") then do; /* find log message containing info we want, based on match data */ audit_record_ptr = addr (log_message.data (1)); audit_record_size = dimension (log_message.data, 1); info_ptr = audit_record_ptr; info_size = audit_record_size; info_size = info_size - size (audit_record_header); info_ptr = addrel (info_ptr, size (audit_record_header)); /* ptr to expanded data */ if info_size > 0 & audit_record_header.subject.tag = "a" & audit_record_header.subject.process_id = ""b then do; /* interactive only */ if looking_for ^= "" then do; if usersw then do; if audit_record_header.subject.person ^= choosen_name then goto Next; end; else do; if rtrim(info_ptr -> as_ia_audit_record_.terminal_type) ^= rtrim(looking_for) then goto Next; end; /* skip message if TTP match not found when -match was given */ end; first_msg_count = first_msg_count + 1; /* increment valid message count */ temp.ttp (first_msg_count) = info_ptr -> as_ia_audit_record_.terminal_type; temp.name (first_msg_count) = audit_record_header.subject.person; temp.chn (first_msg_count) = info_ptr -> as_ia_audit_record_.channel; temp.ansb (first_msg_count) = info_ptr -> as_ia_audit_record_.answerback; temp_as.ansb (first_msg_count) = info_ptr -> as_ia_audit_record_.answerback; temp.time (first_msg_count) = log_message.time; temp.cpu (first_msg_count), temp.connect (first_msg_count) = ""; /* fill in temp array data */ if index (log_message.text, "DENIED") ^= 0 then do; /* if this is a "LOGIN DENIED" message */ temp.failed (first_msg_count) = "1"b; failsw = "1"b; call add_ttp_data (); failsw = ""b; first_msg_count = first_msg_count - 1; goto Next; end; else do; temp.failed (first_msg_count) = ""b; call add_ttp_data (); end; temp.logins (first_msg_count) = 1; if ^mtsw then do; call check_for_dups (MCH); if MCH then first_msg_count = first_msg_count - 1; goto Next; end; NAME = rtrim(temp.name (first_msg_count)); CHN = rtrim(temp.chn (first_msg_count)); TIME = temp.time (first_msg_count); auto_log_read_ptr = log_read_ptr; auto_log_message_ptr = log_message_ptr; call scan_LOGOUTS (NAME, CHN, TIME); /* called only for looking up cpu & connect data */ log_message_ptr = auto_log_message_ptr; log_read_ptr = auto_log_read_ptr; end; end; Next: call log_read_$next_message (log_read_ptr, log_message_ptr, code); if code = error_table_$no_log_message then log_message_ptr = null (); /* find next log message */ if log_message_ptr = opt.last_msg then goto sort_em; else goto scan_log; end; sort_em: /* sort items */ vptr = pointer (temp_ptr, currentsize (temp)); vptr_ansb = pointer (temp_as_ptr, currentsize (temp_as)); vptr_two = pointer (ttp_tot_ptr, currentsize (ttp_tot)); V.n = first_msg_count; V_thr.n_thr = first_msg_count; do inx = 1 to V.n; V.vector (inx) = addr (temp_ptr -> temp.data (inx)); end; do inx = 1 to V_thr.n_thr; V_thr.vector_thr (inx) = addr (temp_as_ptr -> temp_as.ansbs (inx)); end; V_two.n_two = ttx; do inx = 1 to V_two.n_two; V_two.vector_two (inx) = addr (ttp_tot_ptr -> ttp_tot.tot_data (inx)); end; if V.n > 1 then call sort_items_$varying_char (vptr); if V_two.n_two > 1 then call sort_items_$varying_char (vptr_two); if V_thr.n_thr > 1 then call sort_items_$varying_char (vptr_ansb); if mtsw then call ioa_$ioa_switch (opt.iocb, "Terminal usage sorted by type:^50t(*) = Still active^2/"); else call ioa_$ioa_switch (opt.iocb, "Terminal usage sorted by type:^2/"); if mtsw then call ioa_$ioa_switch (opt.iocb, "Type^36tLogins^50tNologins^62tCpu^70tConnect^/"); else call ioa_$ioa_switch (opt.iocb, "Type^36tLogins^50tNologins^/"); if mtsw then do; ttp_meters, final_tab = "1"b; end; do inx = 1 to ttx; tot_logi, tot_logo = 0; tot_cpu, tot_connect = ""; do inxx = 1 to V_two.vector_two (inx) -> ttp_tot_data.ascnt; tot_logi = tot_logi + V_two.vector_two (inx) -> ttp_tot_data.ansbks.login (inxx); tot_logo = tot_logo + V_two.vector_two (inx) -> ttp_tot_data.ansbks.fails (inxx); if mtsw then do; add_cpus = "1"b; if tot_cpu = "" then tot_cpu = "000:00"; call add_common_times (); add_cpus = ""b; if tot_connect = "" then tot_connect = "00000:00"; call add_common_times (); end; end; /* add up number of logins and failed logins */ if mtsw then call ioa_$ioa_switch (opt.iocb, "^a^36t^5d^50t^5d^60t^a^70t^a", V_two.vector_two (inx) -> ttp_tot_data.type, tot_logi, tot_logo, tot_cpu, tot_connect); else call ioa_$ioa_switch (opt.iocb, "^a^36t^5d^50t^5d", V_two.vector_two (inx) -> ttp_tot_data.type, tot_logi, tot_logo); end; if ttp_meters then ttp_meters, final_tab = ""b; if mtsw then call ioa_$ioa_switch (opt.iocb, "^3/Terminal usage sorted by Answerback:^50t(*) = Still active^2/"); else call ioa_$ioa_switch (opt.iocb, "^3/Terminal usage sorted by Answerback:^2/"); if mtsw then call ioa_$ioa_switch (opt.iocb, "Ansbk^8tType^38tLogins^52tNologins^64tCpu^72tConnect"); else call ioa_$ioa_switch (opt.iocb, "Ansbk^8tType^38tLogins^52tNologins"); call ioa_$ioa_switch (opt.iocb, "^10tUser"); call output_data (); call clean_up; return; /* procedure for determining cpu times */ get_cpu_time: proc (); datax = index (temp_two.text (1), "$") - 7; cpu_data = substr (temp_two.text (1), datax, 6); temp.cpu (first_msg_count) = cpu_data; call get_connect_time (); ttp_meters = "1"b; call add_ttp_data (); ttp_meters = ""b; return; end get_cpu_time; check_for_dups: /* procedure to add cpu times up if user & ttp are listed in our temp array more than once */ proc (match_made); dcl match_made bit (1) aligned parameter; if first_msg_count < 2 then return; match_made = ""b; do inx = 1 to first_msg_count-1; if rtrim(temp.ttp (inx)) = rtrim(temp.ttp (first_msg_count)) & rtrim(temp.name (inx)) = rtrim(temp.name (first_msg_count)) & rtrim(temp.ansb (inx)) = rtrim(temp.ansb (first_msg_count)) then do; temp.logins (inx) = temp.logins (inx) + 1; if ^mtsw then do; match_made = "1"b; return; end; if index (temp.cpu (inx), ":") ^= 0 & rtrim(temp.cpu (first_msg_count)) = "" then temp.cpu (inx) = rtrim(temp.cpu (inx)) || " (*)"; else if index (temp.cpu (first_msg_count), ":") ^= 0 & rtrim(temp.cpu (inx)) = "" then temp.cpu (inx) = rtrim(temp.cpu (first_msg_count)) || " (*)"; else if index (temp.cpu (inx), ":") ^= 0 then do; add_cpus = "1"b; call add_common_times (); add_cpus = ""b; call add_common_times (); end; match_made = "1"b; /* match was found */ return; end; end; return; end check_for_dups; get_connect_time: /* procedure to determine connect times */ proc (); dcl date_time_$from_clock_interval entry (fixed bin(71), fixed bin(71), ptr, fixed bin(35)); dcl 1 to aligned like time_offset; dcl 1 toa aligned like time_offset_array; dcl (time_one, time_two) fixed bin (71); dcl (ihour, imin, isec) fixed bin; dcl connect_time char (8); to.version, toa.version = Vtime_offset_2; toa.flag (1) = UNUSED; toa.flag (2) = UNUSED; toa.flag (3) = UNUSED; toa.flag (4) = UNUSED; toa.flag (5) = INTEGER; toa.flag (6) = INTEGER; toa.flag (7) = INTEGER; toa.flag (8) = UNUSED; time_one = temp_two.time (1); time_two = temp.time (first_msg_count); call date_time_$from_clock_interval (time_two, time_one, addr(toa), code); ihour = toa.val (5) + .0; imin = toa.val (6) + .0; isec = toa.val (7) + .0; imin = imin + ihour*60; call ioa_$rsnnl ("^5d:^2d", connect_time, len, imin, isec); temp.connect (first_msg_count) = connect_time; return; end get_connect_time; add_common_times: /* procedure to add cpu/connect times for common ttps/users */ proc (); dcl (common_temp, common_tempx) char (8); dcl (sub_one_one, sub_one_two, sub_two_one, sub_two_two, common_min_char, common_sec_char) char (5); dcl (common_one_one, common_one_two, common_two_one, common_two_two, common_min, common_sec) fixed bin; if ttp_meters then do; if add_cpus then do; if final_tab then do; common_temp = rtrim(V_two.vector_two (inx) -> ttp_tot_data.ansbks.cpu (inxx)); common_tempx = rtrim(tot_cpu); end; else do; common_temp = rtrim(temp.cpu (first_msg_count)); common_tempx = rtrim(tot_cpu); end; end; else do; if final_tab then do; common_temp = rtrim(V_two.vector_two (inx) -> ttp_tot_data.ansbks.connect (inxx)); common_tempx = rtrim(tot_connect); end; else do; common_temp = rtrim(temp.connect (first_msg_count)); common_tempx = rtrim(tot_connect); end; end; end; else do; if add_cpus then do; common_temp = rtrim(temp.cpu (inx)); common_tempx = rtrim(temp.cpu (first_msg_count)); end; else do; common_temp = rtrim(temp.connect (inx)); common_tempx = rtrim(temp.connect (first_msg_count)); end; end; if add_cpus then do; sub_one_one = substr (common_temp, 1, 3); sub_one_two = substr (common_temp, 5, 2); sub_two_one = substr (common_tempx, 1, 3); sub_two_two = substr (common_tempx, 5, 2); end; else do; sub_one_one = substr (common_temp, 1, 5); sub_one_two = substr (common_temp, 7, 2); sub_two_one = substr (common_tempx, 1, 5); sub_two_two = substr (common_tempx, 7, 2); end; common_one_one = cv_dec_check_ (rtrim(ltrim(sub_one_one)), code); common_one_two = cv_dec_check_ (rtrim(sub_one_two), code); common_two_one = cv_dec_check_ (rtrim(ltrim(sub_two_one)), code); common_two_two = cv_dec_check_ (rtrim(sub_two_two), code); common_min = common_one_one + common_two_one; common_sec = common_one_two + common_two_two; if common_sec > 59 then do; common_min = common_min + 1; common_sec = common_sec - 60; end; if add_cpus then call ioa_$rsnnl ("^3d", common_min_char, len, common_min); else call ioa_$rsnnl ("^5d", common_min_char, len, common_min); call ioa_$rsnnl ("^2d", common_sec_char, len, common_sec); if ttp_meters then do; if add_cpus then tot_cpu = rtrim(common_min_char) || ":" || rtrim(common_sec_char); else tot_connect = rtrim(common_min_char) || ":" || rtrim(common_sec_char); return; end; if add_cpus then temp.cpu (inx) = rtrim(common_min_char) || ":" || rtrim(common_sec_char); else temp.connect (inx) = rtrim(common_min_char) || ":" || rtrim(common_sec_char); return; end add_common_times; scan_LOGOUTS: proc (login_name, chan_name, login_time); /* procedure that scans the logs finding "LOGOUT" messages that correspond to "LOGIN" messages for determining cpu & connect time usage */ dcl login_name char(22) parameter; dcl chan_name char(32) parameter; dcl login_time fixed bin (71) parameter; dcl msg_count fixed bin (35); msg_count = 0; log_message_ptr = opt.first_msg; /* start with first message again */ call log_match_$clear_text_strings (opt.lmd_ptr); call log_match_$add_match (opt.lmd_ptr, "LOGOUT"); /* change the match string from LOGIN to LOGOUT */ do while (log_message_ptr ^= null ()); if log_match_$test (opt.lmd_ptr, log_message_ptr, "") then do; msg_count = msg_count + 1; audit_record_ptr = addr (log_message.data (1)); audit_record_size = dimension (log_message.data, 1); info_ptr = audit_record_ptr; info_size = audit_record_size; info_size = info_size - size (audit_record_header); info_ptr = addrel (info_ptr, size (audit_record_header)); if index (log_message.text, "disconnect") = 0 then do; if index (log_message.text, rtrim(login_name)) ^= 0 & index (log_message.text, rtrim(chan_name)) ^= 0 & log_message.time > login_time then do; if index_count > 0 then do inx = 1 to index_count; if msg_count = temp_thr.index (inx) then goto skip_msg_count; end; temp_two.text (1) = log_message.text; temp_two.time (1) = log_message.time; index_count = index_count + 1; temp_thr.index (index_count) = msg_count; call get_cpu_time (); goto setup; end; end; end; skip_msg_count: call log_read_$next_message (log_read_ptr, log_message_ptr, code); /* goto next log message */ if log_message_ptr = opt.last_msg then do; temp.cpu (first_msg_count) = ""; temp.connect (first_msg_count) = ""; goto setup; end; if code = error_table_$no_log_message then log_message_ptr = null (); end; setup: call check_for_dups (MCH); if MCH then first_msg_count = first_msg_count - 1; call log_match_$clear_text_strings (opt.lmd_ptr); call log_match_$add_match (opt.lmd_ptr, "LOGIN"); /* change the match string back to LOGIN before returning to original log scan */ return; end scan_LOGOUTS; add_ttp_data: proc (); /* procedure for adding up & sorting different answerbacks per different ttps */ if ttx = 0 then do; ttx = ttx + 1; ttp_tot.type (ttx) = temp.ttp (first_msg_count); ttp_tot.ascnt (ttx) = 1; ttp_tot.ansbks (ttx).ansbk (1) = temp.ansb (first_msg_count); if failsw then ttp_tot.ansbks (ttx).fails (1) = 1; else ttp_tot.ansbks (ttx).login (1) = 1; ttp_tot.ansbks (ttx).cpu (1) = " 0: 0"; ttp_tot.ansbks (ttx).connect (1) = " 0: 0"; end; else do; do inx = 1 to ttx; if temp.ttp (first_msg_count) = ttp_tot.type (inx) then do; do ttxx = 1 to ttp_tot.ascnt (inx); if ttp_tot.ansbks (inx).ansbk (ttxx) = temp.ansb (first_msg_count) then do; if ttp_meters then do; add_cpus = "1"b; if tot_cpu = "" then tot_cpu = "000:00"; else tot_cpu = ttp_tot.ansbks (inx).cpu (ttxx); call add_common_times (); add_cpus = ""b; ttp_tot.ansbks (inx).cpu (ttxx) = tot_cpu; if tot_connect = "" then tot_connect = "00000:00"; else tot_connect = ttp_tot.ansbks (inx).connect (ttxx); call add_common_times (); ttp_tot.ansbks (inx).connect (ttxx) = tot_connect; end; else if failsw then ttp_tot.ansbks (inx).fails (ttxx) = ttp_tot.ansbks (inx).fails (ttxx) + 1; else ttp_tot.ansbks (inx).login (ttxx) = ttp_tot.ansbks (inx).login (ttxx) + 1; return; end; end; ttp_tot.ascnt (inx) = ttp_tot.ascnt (inx) + 1; ttp_tot.ansbks (inx).ansbk (ttp_tot.ascnt (inx)) = temp.ansb (first_msg_count); ttp_tot.ansbks (inx).cpu (ttp_tot.ascnt (inx)) = " 0: 0"; ttp_tot.ansbks (inx).connect (ttp_tot.ascnt (inx)) = " 0: 0"; if failsw then ttp_tot.ansbks (inx).fails (ttp_tot.ascnt (inx)) = ttp_tot.ansbks (inx).fails (ttp_tot.ascnt (inx)) + 1; else ttp_tot.ansbks (inx).login (ttp_tot.ascnt (inx)) = ttp_tot.ansbks (inx).login (ttp_tot.ascnt (inx)) + 1; return; end; end; ttx = ttx + 1; ttp_tot.ascnt (ttx) = 1; ttp_tot.type (ttx) = temp.ttp (first_msg_count); ttp_tot.ansbks (ttx).ansbk (ttp_tot.ascnt (ttx)) = temp.ansb (first_msg_count); ttp_tot.ansbks (ttx).cpu (ttp_tot.ascnt (ttx)) = " 0: 0"; ttp_tot.ansbks (ttx).connect (ttp_tot.ascnt (ttx)) = " 0: 0"; if failsw then ttp_tot.ansbks (ttx).fails (ttp_tot.ascnt (ttx)) = 1; else ttp_tot.ansbks (ttx).login (ttp_tot.ascnt (ttx)) = 1; end; return; end add_ttp_data; output_data: proc (); /* display results to user_output or output file */ dcl (inxxx, inxxxx) fixed bin; dcl atype char (36) varying; ttype, atype = ""; do inx = 1 to V_thr.n_thr; if V_thr.vector_thr (inx) -> temporary_ansb.ansb ^= atype then do; atype = V_thr.vector_thr (inx) -> temporary_ansb.ansb; end; else goto skip_call; do inxx = 1 to V_two.n_two; do inxxx = 1 to V.n; if V.vector (inxxx) -> temporary.ttp = V_two.vector_two (inxx) -> ttp_tot_data.type & V.vector (inxxx) -> temporary.ansb = V_thr.vector_thr (inx) -> temporary_ansb.ansb then do; if ttype ^= V_thr.vector_thr (inx) -> temporary_ansb.ansb || " " || V_two.vector_two (inxx) -> ttp_tot_data.type then do; ttype = V_thr.vector_thr (inx) -> temporary_ansb.ansb || " " || V_two.vector_two (inxx) -> ttp_tot_data.type; tot_logi, tot_logo = 0; do inxxxx = 1 to V_two.vector_two (inxx) -> ttp_tot_data.ascnt; if V_two.vector_two (inxx) -> ttp_tot_data.ansbk (inxxxx) = V_thr.vector_thr (inx) -> temporary_ansb.ansb then do; tot_logi = tot_logi + V_two.vector_two (inxx) -> ttp_tot_data.ansbks.login (inxxxx); tot_logo = tot_logo + V_two.vector_two (inxx) -> ttp_tot_data.ansbks.fails (inxxxx); if mtsw then do; tot_cpu = V_two.vector_two (inxx) -> ttp_tot_data.ansbks.cpu (inxxxx); tot_connect = V_two.vector_two (inxx) -> ttp_tot_data.ansbks.connect (inxxxx); end; end; end; if mtsw then call ioa_$ioa_switch (opt.iocb, "^/^a^38t^5d^52t^5d^62t^a^72t^a", ttype, tot_logi, tot_logo, tot_cpu, tot_connect); else call ioa_$ioa_switch (opt.iocb, "^/^a^38t^5d^52t^5d", ttype, tot_logi, tot_logo); end; if mtsw then do; if index (V.vector (inxxx) -> temporary.cpu, ":") = 0 then V.vector (inxxx) -> temporary.cpu = " (*)"; call ioa_$ioa_switch (opt.iocb, "^10t^a^38t^5d^62t^a^72t^a", V.vector (inxxx) -> temporary.name, V.vector (inxxx) -> temporary.logins, V.vector (inxxx) -> temporary.cpu, V.vector (inxxx) -> temporary.connect); end; else do; call ioa_$ioa_switch (opt.iocb, "^10t^a^38t^5d", V.vector (inxxx) -> temporary.name, V.vector (inxxx) -> temporary.logins); end; end; end; end; skip_call: end; return; end output_data; oob: proc (); call ioa_$ioa_switch (opt.iocb, "Cannot continue... Out_of_bounds condition detected."); call clean_up (); end oob; clean_up: proc (); if log_read_ptr ^= null () then call log_read_$close (log_read_ptr, (0)); if opt.lmd_ptr ^= null () then call log_match_$free (opt.lmd_ptr); if temp_ptrs (1) ^= null () then call release_temp_segments_ ("terminal_report", temp_ptrs, code); if opened then do; call iox_$close (opt.iocb, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Could not close file ^a", output_file); end; opened = ""b; end; if attached then do; call iox_$detach_iocb (opt.iocb, code); if code ^= 0 then do; call ssu_$abort_line (sci_ptr, code, "Could not detach file ^a", output_file); end; attached = ""b; end; if sci_ptr ^= null () then call ssu_$destroy_invocation (sci_ptr); goto exit; end clean_up; exit: return; process_arguments: proc (); /* validate arguments */ dcl arg char (argl) based (argp); dcl (argn, nargs) fixed bin; dcl argl fixed bin (21); dcl argp ptr; dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); call ssu_$arg_count (sci_ptr, nargs); looking_for = ""; do argn = 1 to nargs; call ssu_$arg_ptr (sci_ptr, argn, argp, argl); if arg = "-from" | arg = "-fm" then call get_next_arg (opt.limit.from_opt); else if arg = "-to" then call get_next_arg (opt.limit.to_opt); else if arg = "-for" then call get_next_arg (opt.limit.for_opt); else if arg = "-last" | arg = "-lt" then call get_next_arg (opt.limit.last_opt); else if arg = "-output_file" | arg = "-of" then do; call get_next_arg (output_file); if code ^= 0 then output_file = "terminal_report_output"; else output_file = arg; end; else if arg = "-no_output_file" | arg = "-nof" then output_file = ""; else if arg = "-terminal_type" | arg = "-ttp" then do; call get_next_arg (looking_for); call process_looking_for (); ttpsw = "1"b; end; else if arg = "-all_terminal_types" | arg = "-att" then do; looking_for = ""; ttpsw = "0"b; end; else if arg = "-user" then do; call get_next_arg (looking_for); call process_looking_for (); choosen_name = looking_for; usersw = "1"b; end; else if arg = "-all_users" | arg = "-au" then do; looking_for = ""; usersw = "0"b; end; else if arg = "-meters" | arg = "-mt" then mtsw = "1"b; else if arg = "-nometers" | arg = "-nmt" then mtsw = ""b; else if substr (arg, 1, 1) = "-" then do; call ssu_$abort_line (sci_ptr, error_table_$badopt, "^a", arg); call clean_up (); end; else call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "^a", arg); end; call check_options (); return; process_looking_for: proc (); /* procedure for validating -match or -ttp strings */ if substr (arg, 1, 1) = "/" & substr (arg, argl, 1) ^= "/" then do; INVALID_ERROR: call ssu_$abort_line (sci_ptr, error_table_$bad_arg, "Invalid regular expression ""^a""", arg); call clean_up (); end; else if substr (arg, argl, 1) = "/" & substr (arg, 1, 1) ^= "/" then goto INVALID_ERROR; else if arg = "/" then goto INVALID_ERROR; return; end process_looking_for; get_next_arg: proc (option); dcl option char (*) varying parameter; argn = argn + 1; call cu_$arg_ptr (argn, argp, argl, code); option = arg; return; end get_next_arg; check_options: proc (); /* procedure for determining what date/time to start & stop log scanning */ dcl temp_number fixed bin; dcl (from_time, to_time) fixed bin(71); dcl exchange_opt char (50) varying; if opt.limit.from_opt ^= "" & opt.limit.to_opt ^= "" then do; temp_number = cv_dec_check_ ((opt.limit.from_opt), code); if code ^= 0 then do; temp_number = cv_dec_check_ ((opt.limit.to_opt), code); if code ^= 0 then do; call convert_date_to_binary_ ((opt.limit.from_opt), from_time, 0); call convert_date_to_binary_ ((opt.limit.to_opt), to_time, 0); if from_time > to_time then do; exchange_opt = opt.limit.from_opt; opt.limit.from_opt = opt.limit.to_opt; opt.limit.to_opt = exchange_opt; end; end; end; end; return; end check_options; end process_arguments; ssu_abort: proc (); call clean_up (); return; end ssu_abort; initialize_options: proc (); unspec (opt) = ""b; opt.pointers = null (); opt.lmd_ptr = null (); opt.limit.version = LOG_LIMIT_INFO_VERSION_1; opt.limit.to_opt = ""; opt.limit.from_opt = ""; opt.limit.for_opt = ""; opt.log_pathname = ""; opt.iocb = iox_$user_output; opt.reader_procedure = ""; /* unspec (log_message) = ""b;*/ output_file, tot_cpu, tot_connect = ""; attached, opened, mtsw, failsw, ttp_meters, final_tab, usersw, ttpsw = ""b; ttx = 0; unspec (ttp_tot) = ""b; return; end initialize_options; %include log_limit_info; %include as_audit_structures; %include log_message; %include user_attributes; %include access_audit_bin_header; %include time_offset; /* Builtins */ dcl (index, substr, addr, addrel, currentsize, ltrim, rtrim, null, pointer, unspec, dimension, size) builtin; /* Automatic */ dcl 1 opt automatic, /* structure required by the system log subroutines */ 2 log_pathname char (168), 2 pointers, 3 expand_select_ptr ptr, 3 lmd_ptr ptr, 2 limit aligned like log_limit_info, 2 reader_procedure char (32) varying, 2 iocb ptr, 2 flags aligned, 3 debug_sw bit (1), 3 dm_system_log_sw bit (1), 3 reverse_sw bit (1), 3 from_sw bit (1), 3 to_sw bit (1), 3 for_sw bit (1), 3 last_sw bit (1), 3 expand_sw bit (1), 3 octal_sw bit (1), 3 interpret_sw bit (1), 3 log_path_sw bit (1), 3 no_header_sw bit (1), 3 limit_sw bit (1), 3 process_id_sw bit (1), 3 data_class_sw bit (1); dcl 1 ttp_tot (ttx) aligned based (ttp_tot_ptr), 2 tot_data like ttp_tot_data; /* ttp & ansback data */ dcl 1 ttp_tot_data aligned based, /* above data sorted */ 2 type char(32) varying, 2 ascnt fixed bin, 2 ansbks (1000), 3 ansbk char(4), 3 login fixed bin(35), 3 fails fixed bin(35), 3 connect char(8), 3 cpu char(6); dcl 1 temp_as (first_msg_count) aligned based (temp_as_ptr), 2 ansbs like temporary_ansb; /* ansback data */ dcl 1 temporary_ansb aligned based, 2 ansb char (4) varying; /* above data sorted */ dcl 1 temporary aligned based, /* terminal data */ 2 name char (22) varying, 2 ttp char(32), 2 ansb char(4), 2 chn char(32), 2 time fixed bin(71), 2 logins fixed bin(35), 2 failed bit (1) aligned, 2 connect char(8), 2 cpu char(10); dcl 1 temp (first_msg_count) aligned based (temp_ptr), 2 data like temporary; /* above data sorted */ dcl 1 temp_two (1) aligned based (temp_two_ptr), 2 text char(128) varying, /* LOGOUT data */ 2 time fixed bin(71); dcl 1 temp_thr (index_count) aligned based (ttp), 2 index fixed bin (35); /* array of LOGOUT messages already seen and matched */ dcl 1 V aligned based (vptr), 2 n fixed bin(18), 2 vector (n) ptr unaligned; dcl 1 V_two aligned based (vptr_two), 2 n_two fixed bin(18), 2 vector_two (n_two) ptr unaligned; dcl 1 V_thr aligned based (vptr_ansb), 2 n_thr fixed bin(18), 2 vector_thr (n_thr) ptr unaligned; dcl (info_size, audit_record_size, ttx, ttxx, inx, inxx, datax, tot_logi, tot_logo) fixed bin; dcl tot_connect char (8); dcl tot_cpu char (6); dcl choosen_name char (22) varying; dcl looking_for char (32) varying; dcl CHN char (32); dcl NAME char (22); dcl (cods, dpds) char (120) aligned; dcl (coxx, dpxx) char (4) aligned; dcl cpu_data char (9); dcl output_file char (168) varying; dcl ttype char (32); dcl (code, index_count) fixed bin (35); dcl (attached, opened, add_cpus) bit (1); dcl (failsw, ttp_meters, final_tab, MCH, mtsw, usersw, ttpsw) bit (1) aligned; dcl TIME fixed bin (71); dcl len fixed bin (21); dcl (first_msg_count, ansb_msg_count) fixed bin (35); /* External entries */ dcl log_read_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl log_read_$close entry (ptr, fixed bin (35)); dcl log_read_$next_message entry (ptr, ptr, fixed bin (35)); dcl log_match_$add_match entry (ptr, char (*)); dcl log_match_$free entry (ptr); dcl log_match_$test entry (ptr, ptr, char (*) varying) returns (bit (1) aligned); dcl log_match_$clear_text_strings entry (ptr); dcl log_limit_scan_ entry (ptr, ptr, bit (1) aligned, ptr); dcl log_format_time_ entry (fixed bin (71)) returns (char (32) varying); dcl (ioa_$ioa_switch, ioa_$rsnnl, com_err_) entry options (variable); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl system_info_$titles entry (char (*) aligned, char (*) aligned, char (*) aligned, char (*) aligned); dcl sort_items_$varying_char entry (ptr); dcl (get_temp_segments_, release_temp_segments_) entry (char (*), (*) ptr, fixed bin (35)); dcl ssu_$standalone_invocation entry (ptr, char (*), char (*), ptr, entry, fixed bin (35)); dcl ssu_$destroy_invocation entry (ptr); dcl ssu_$abort_line entry options (variable); dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21)); dcl ssu_$arg_list_ptr entry returns (ptr); dcl ssu_$arg_count entry (ptr, fixed bin); dcl cu_$arg_list_ptr entry returns (ptr); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (*), fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); /* Pointers */ dcl (log_read_ptr, temp_as_ptr, temp_ptrs (5), auto_log_read_ptr, auto_log_message_ptr, sci_ptr, temp_ptr, temp_two_ptr, ttp_tot_ptr, ttp, vptr, vptr_two, vptr_ansb, info_ptr) ptr; dcl iox_$user_output ptr ext static; /* conditions */ dcl (out_of_bounds, cleanup) condition; /* error messages */ dcl (error_table_$no_log_message, error_table_$badopt, error_table_$bad_arg, error_table_$inconsistent) fixed bin (35) ext static; end; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved