This Multics source file was rescued from the messed-up source archive at MIT.
This is an exmaple of an archive of Multics source programs, a small part of the Multics Standard Service System commands. These programs were compiled and their individual object files bound into a single object segment. The individual components and their descriptions are:
- check_info_segs (cis)
-
This command and active function checks to see if any system information segments have changed since the user last looked. The command prints out the names of changed segments; the active function returns their pathnames. Control arguments allow the command invocation to specify another command to be called on each changed segment. Each user has a personal "value segment" used to store various bits of information, and check_info_segs stores the date and time last looked in the value segment.
Original implementation by Tom Van Vleck. It occurs to me, about 30 years after I wrote this command, that it's only useful at a site where info seg updates happen more or less continuously. Customers at Multics sites who got yearly releases would see nothing from this command for a year, and then a huge list of changes once. So, like the who command, this command assumes something about the online community that uses it.
- help
-
The help command prints out system information files. It is similar to the Unix "man" command.
Multics system information segments ("info segments") for standard commands are created by processing the system manual source and extracting the help information: thus, the manuals and the help have a single source, but there is more information in the manual than in the help segments, and the help segments have indexing and structural items added so that help can display summaries, skip sections, and provide better interaction.
help is a wrapper for the help_ subroutine below. The wrapper/guts structure is used in many commands. The wrapper handles the business of being a command, error printing, and so on. The guts does the internals of the processing and may be used by the wrapper and by other subsystems.
Original implementation by Tom Van Vleck.
- help_
-
This subroutine is the guts of the help command.
- list_help (lh)
-
This command and active function lists system information segments that are relevant to a particular topic. (The Unix "man" command has a similar control argument.)
- list_ref_names (lrn)
-
This command lists the reference names by which a segment is initiated.
- print_motd (pmotd)
-
This command prints those lines in the "message of the day" system information segment, motd.info, which have the user has not seen. This command also stores its information in the user's value segment.
- resource_usage (ru)
-
This command prints a table that shows the user's resource limits and usage against these limits.
Original implementation by Tom Van Vleck and Janice Phillipps.
- ring0_get_
-
This subroutine reads information from the supervisor. Only specific values are available to normal user programs.
- system_info_
-
This subroutine reads information about the system.
Original implementation by Tom Van Vleck.
- user_info_
-
This subroutine returns information about the particular logged-in user process.
Original implementation by Tom Van Vleck.
- where (wh)
-
This command and active function uses the system search rules to find a sgment, and prints out its file system pathname.
- who, how_many_users (hmu)
-
This command prints a list of logged in users. The source also implements a related command, "how_many_users (hmu)" that prints out the total number of users currently logged in. These commands merely format and display data placed in a public data segment by the answering service.
See also the writeup of the Who Command, containing a copy of the info seg and a sample of the output.
This command is descended from the WHO command on CTSS. Some versions of Unix have a similar command of the same name.
Original Multics implementation by Tom Van Vleck.
Back to Multics Source index.
\014
check_info_segs.pl1 02/04/82 1425.6rew 02/04/82 1420.7 179946
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
/* Check directories for new info segments.
This command remarks about any file in a directory in the "info_segments"
search list or in user-supplied directories with the dtem greater than the
last_time_looked. The last_time_looked is kept in the user's default
value segment.
The active function returns the selected info seg names separated by spaces
Rewritten 24-Oct-78 by Monte Davidoff.
Modified February 1979 by Michael R. Jordan for unsigned changes to star_structures.incl.pl1. */
/* No_s bug obtaining dtcm's fixed 12/12/79 S. Herbst */
/* Implement [cis], -absolute_pathname, and fix bugs 06/11/80 S. Herbst */
/* Implement -time_checked Sept 1980 Marshall Presser */
/* Implement discarding of duplicates when same segment identified twice 81/02/11 Paul Benjamin */
/* Modified: 14 January 1982 by G. Palter to convert to using the default value segment */
/* format: style4,delnl,insnl,ifthenstmt,ifthen */
check_info_segs:
cis:
procedure () options (variable);
dcl arg_count fixed binary;
dcl arg_length fixed binary (21);
dcl arg_ptr pointer;
dcl argx fixed binary;
dcl call_str_length fixed binary (21);
dcl call_str_ptr pointer;
dcl change_sw bit (1);
dcl code fixed binary (35);
dcl complain entry variable options (variable);
dcl dir_name char (168);
dcl duplicate bit (1);
dcl entryname char (32);
dcl last_time_looked fixed binary (71);
dcl return_len fixed binary;
dcl return_ptr pointer;
dcl uid_list_count fixed binary;
dcl uid_list_index fixed binary;
dcl uid_list_ptr ptr;
dcl 1 sw,
2 absp bit (1),
2 af bit (1),
2 brief bit (1),
2 call bit (1),
2 long bit (1),
2 pathname bit (1),
2 update bit (1),
2 check_time bit (1);
dcl time_checked char (24);
dcl update_time fixed binary (71);
dcl arg_string char (arg_length) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr);
dcl uid_list (uid_list_count) bit (36) based (uid_list_ptr);
dcl (addr, binary, clock, currentsize, divide, empty, hbound, index, length, null, rtrim) builtin;
dcl (cleanup, program_interrupt) condition;
dcl DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);
dcl CIS_VALUE_NAME character (17) static options (constant) initial ("check_info_segs._");
dcl command char (32) internal static options (constant) initial ("check_info_segs");
dcl error_table_$badopt fixed binary (35) external static;
dcl error_table_$no_dir fixed binary (35) external static;
dcl error_table_$no_s_permission fixed binary (35) external static;
dcl error_table_$noentry fixed binary (35) external static;
dcl error_table_$nomatch fixed binary (35) external static;
dcl error_table_$not_act_fnc fixed binary (35) external static;
dcl error_table_$oldnamerr fixed binary (35) external static;
dcl active_fnc_err_ entry () options (variable);
dcl active_fnc_err_$suppress_name entry () options (variable);
dcl com_err_ entry () options (variable);
dcl com_err_$suppress_name entry () options (variable);
dcl convert_date_to_binary_ entry (char (*), fixed binary (71), fixed binary (35));
dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
dcl cu_$cp entry (pointer, fixed binary (21), fixed binary (35));
dcl date_time_ entry (fixed binary (71), char (*));
dcl expand_pathname_ entry (char (*), char (*), char (*), fixed binary (35));
dcl get_system_free_area_ entry () returns (pointer);
dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
dcl hcs_$star_dir_list_
entry (char (*), char (*), fixed binary (3), pointer, fixed binary, fixed binary, pointer, pointer,
fixed binary (35));
dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl ioa_ entry () options (variable);
dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl requote_string_ entry (char (*)) returns (char (*));
dcl search_paths_$get entry (char (*), bit (36), char (*), pointer, pointer, fixed binary, pointer, fixed binary (35));
dcl user_info_ entry (char (*));
dcl user_info_$homedir entry (char (*));
dcl value_$get_data entry (ptr, bit (36) aligned, char (*), ptr, ptr, fixed bin (18), fixed bin (35));
dcl value_$get_path entry (char (*), fixed bin (35));
dcl value_$set_data
entry (ptr, bit (36) aligned, char (*), ptr, fixed bin (18), ptr, ptr, fixed bin (18), fixed bin (35));
dcl value_$set_path entry (char (*), bit (1), fixed bin (35));
/*\014*/
call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
if code = error_table_$not_act_fnc then do;
sw.af = "0"b;
complain = com_err_;
end;
else do;
sw.af = "1"b;
complain = active_fnc_err_;
return_arg = "";
end;
sl_info_p = null ();
star_entry_ptr = null ();
star_names_ptr = null ();
uid_list_ptr = null ();
on cleanup call cleanup_;
last_time_looked = 0; /* none yet supplied */
sw.absp = "0"b;
sw.brief = "0"b;
sw.call = "0"b;
sw.long = "0"b;
sw.pathname = "0"b;
sw.check_time = "0"b;
sw.update = "1"b;
change_sw = "0"b;
call_str_length = 0;
do argx = 1 to arg_count;
call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
if code ^= 0 then do;
call complain (code, command, "Fetching argument #^d.", argx);
return;
end;
if arg_string = "-absolute_pathname" | arg_string = "-absp" then sw.absp = "1"b;
else if arg_string = "-brief" | arg_string = "-bf" then
if sw.af then
go to BAD_OPT;
else sw.brief = "1"b;
else if arg_string = "-call" then do;
if sw.af then go to BAD_OPT;
sw.call = "1"b;
argx = argx + 1;
call cu_$arg_ptr (argx, call_str_ptr, call_str_length, code);
if code ^= 0 then do;
call complain (code, command, "Missing command line after -call.");
return;
end;
end;
else if arg_string = "-date" | arg_string = "-dt" then do;
sw.update = "0"b;
argx = argx + 1;
call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
if code ^= 0 then do;
call complain (code, command, "Missing date after -date.");
return;
end;
call convert_date_to_binary_ (arg_string, last_time_looked, code);
if code ^= 0 then do;
call complain (code, command, "^a", arg_string);
return;
end;
end;
else if arg_string = "-long" | arg_string = "-lg" then
if sw.af then
go to BAD_OPT;
else sw.long = "1"b;
else if arg_string = "-no_update" | arg_string = "-nud" then sw.update = "0"b;
else if arg_string = "-time_checked" | arg_string = "-tmck" then sw.check_time = "1"b;
else if arg_string = "-pathname" | arg_string = "-pn" then do;
sw.pathname = "1"b;
argx = argx + 1;
call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
if code ^= 0 then do;
call complain (code, command, "Missing star pathname after -pathname.");
return;
end;
call expand_pathname_ (arg_string, dir_name, entryname, code);
if code ^= 0 then do;
call complain (code, command, "^a", arg_string);
return;
end;
end;
else if is_control_arg (arg_string) then do;
BAD_OPT:
call complain (error_table_$badopt, command, "^a", arg_string);
return;
end;
else do;
if sw.af then
call active_fnc_err_$suppress_name (0, command, "Usage: [^a {-control_args}]", command);
else call com_err_$suppress_name (0, command, "Usage: ^a {-control_args}", command);
return;
end;
end;
if sw.af & sw.check_time then
if arg_count > 1 then do;
call complain (0, command, "The -time_checked control argument is incompatible with any others.");
return;
end;
/*\014*/
if last_time_looked = 0 then /* if user didn't supply a date/time on the command line */
call get_time (last_time_looked);
if sw.check_time then do;
call date_time_ (last_time_looked, time_checked);
if sw.af then
if last_time_looked = 0 then do;
call complain (0, command,
"There is no initial date in the user profile on when info segments were last checked.");
return;
end;
else do;
return_arg = requote_string_ (time_checked);
return;
end;
else do;
if last_time_looked = 0 then do;
call complain (0, command,
"There is no initial date in the user profile on when info segments were last checked.");
return;
end;
else call ioa_ ("Info segments were last checked on ^a", time_checked);
if arg_count = 1 then return;
end;
end;
update_time = clock (); /* avoids missing segments if -call is used */
if sw.update & last_time_looked = 0 then do;
if ^sw.af then
call ioa_ ("^a: ^a", command,
"Initializing date stored in default value segment on which info segments were last checked.");
call put_time (update_time);
return;
end;
call get_temp_segment_ (command, uid_list_ptr, code);
if code ^= 0 then do;
call complain (code, command);
call cleanup_;
return;
end;
uid_list_count = 0;
if sw.pathname then do;
do argx = 1 to arg_count;
call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
if code = 0 then
if arg_string = "-pathname" | arg_string = "-pn" then do;
argx = argx + 1;
call cu_$arg_ptr (argx, arg_ptr, arg_length, code);
call expand_pathname_ (arg_string, dir_name, entryname, code);
call check_directory (dir_name, entryname);
end;
else if arg_string = "-call" | arg_string = "-date" | arg_string = "-dt" then argx = argx + 1;
end;
end;
else do;
call search_paths_$get ("info_segments", sl_control_default, "", null (), get_system_free_area_ (),
sl_info_version_1, sl_info_p, code);
if code ^= 0 then do;
call complain (code, command, "info_segments");
call cleanup_;
return;
end;
do argx = 1 to sl_info.num_paths;
call check_directory (sl_info.paths (argx).pathname, "**.info");
end;
end;
if ^change_sw & ^sw.brief & ^sw.af then call ioa_ ("No changed info segments.");
if sw.update then call put_time (update_time);
RETURN_FROM_CHECK_INFO_SEGS:
call cleanup_;
return;
/*\014*/
/* Check a directory for changed info segments */
check_directory:
procedure (dir_name, star_name);
dcl dir_name char (*); /* (Input) directory to search */
dcl star_name char (*); /* (Input) star name of segments to check */
dcl 1 branch like status_branch.short aligned;
dcl target_dn char (168);
dcl target_en char (32);
dcl command_line char (call_str_length + 169) aligned;
dcl entryx fixed binary;
dcl NO_CHASE fixed binary (1) internal static options (constant) initial (0);
on program_interrupt goto done_checking_dir;
star_select_sw = star_ALL_ENTRIES;
call hcs_$star_dir_list_ (dir_name, star_name, star_select_sw, get_system_free_area_ (), star_branch_count,
star_link_count, star_list_branch_ptr, star_list_names_ptr, code);
if code ^= 0 & code ^= error_table_$nomatch & code ^= error_table_$no_dir & ^sw.brief then
call complain (code, command, "^a^[>^]^a", dir_name, dir_name ^= ">", star_name);
/* in particular, >doc>iml_info may be empty or non-existent */
else do entryx = 1 to hbound (star_links, 1);
if star_links (entryx).type = star_SEGMENT then
call check_segment (dir_name, star_list_names (star_dir_list_branch (entryx).nindex), dir_name,
star_list_names (star_dir_list_branch (entryx).nindex), star_dir_list_branch (entryx).dtem);
else if star_links (entryx).type = star_LINK then do;
call hcs_$get_link_target (dir_name, star_list_names (star_links (entryx).nindex), target_dn,
target_en, code);
if code = 0 then do; /* target exists */
call hcs_$status_ (target_dn, target_en, NO_CHASE, addr (branch), null (), code);
if code ^= 0 & code ^= error_table_$noentry & code ^= error_table_$no_s_permission then
call complain (code, command, "Link target ^a^[>^]^a", target_dn, target_dn ^= ">",
target_en);
else if branch.type = Segment then
call check_segment (target_dn, target_en, dir_name,
star_list_names (star_links (entryx).nindex), branch.dtcm);
end;
end;
end;
done_checking_dir:
if star_list_names_ptr ^= null () then do;
free star_list_names;
star_list_names_ptr = null ();
end;
if star_list_branch_ptr ^= null () then do;
free star_links;
star_list_branch_ptr = null ();
end;
return;
/*\014*/
/* Check if a segment has been modified */
check_segment:
procedure (dir_name, entryname, print_dn, print_en, dtm);
dcl dir_name char (*); /* (Input) directory containing the segment */
dcl entryname char (*); /* (Input) entryname of the segment */
dcl print_dn char (*); /* (Input) directory name of link if link, or seg */
dcl print_en char (*); /* (Input) entryname of link if link, or seg */
dcl dtm bit (36); /* (Input) date-time modified */
dcl name char (168); /* name as printed */
dcl pathname char (168); /* absolute pathname */
dcl date_time char (16);
dcl modified_time fixed binary (71);
dcl call_str char (call_str_length) based (call_str_ptr);
dcl 1 branch like status_branch aligned;
dcl NO_CHASE fixed bin (1) int static options (constant) init (0);
modified_time = binary (dtm || (16)"0"b, 71);
if modified_time >= last_time_looked then do;
call hcs_$status_long (dir_name, entryname, NO_CHASE, addr (branch), null (), code);
modified_time = binary (dtcm || (16)"0"b, 71);
/* make sure by checking dtcm */
if modified_time >= last_time_looked then do;
duplicate = "0"b;
do uid_list_index = 1 to uid_list_count;
if uid_list (uid_list_index) = branch.uid then do;
duplicate = "1"b;
uid_list_index = uid_list_count;
end;
end;
if duplicate = "0"b then do;
uid_list_count = uid_list_count + 1;
uid_list (uid_list_count) = branch.uid;
change_sw = "1"b; /* something has actually changed */
if print_dn = ">" then
pathname = ">";
else pathname = rtrim (print_dn) || ">";
pathname = rtrim (pathname) || print_en;
if sw.absp then
name = pathname; /* return absolute pathnames */
else name = print_en;
if sw.af then do;
if return_arg ^= "" then return_arg = return_arg || " ";
return_arg = return_arg || requote_string_ (rtrim (name));
end;
else if sw.long then do;
call date_time_ (modified_time, date_time);
call ioa_ ("^a ^a", date_time, name);
end;
else if ^sw.brief then call ioa_ ("^a", name);
if sw.call then do;
command_line = call_str || " " || pathname;
call cu_$cp (addr (command_line), length (rtrim (command_line)), code);
end;
end;
end;
end;
return;
end check_segment;
end check_directory;
/*\014*/
/* Check if an argument is a control arg */
is_control_arg:
procedure (arg) returns (bit (1));
dcl arg char (*); /* (Input) command argument */
if arg = "" then
return ("0"b);
else return (index (arg, "-") = 1);
end is_control_arg;
/*\014*/
cleanup_:
procedure ();
if sl_info_p ^= null () then do;
free sl_info;
sl_info_p = null ();
end;
if star_names_ptr ^= null () then do;
free star_list_names;
star_names_ptr = null ();
end;
if star_entry_ptr ^= null () then do;
free star_links;
star_entry_ptr = null ();
end;
if uid_list_ptr ^= null () then call release_temp_segment_ (command, uid_list_ptr, code);
return;
end cleanup_;
/*\014*/
/* Fetch the date/time info segments were last check from the value segment: if the time isn't present in the value
segment, check the abbrev profile for an old style date/time and copy it to the value segment */
get_time:
procedure (p_date_time);
dcl p_date_time fixed binary (71) parameter;
dcl small_area area (256);
dcl based_date_time fixed binary (71) based (date_time_ptr);
dcl date_time_ptr pointer;
call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area), date_time_ptr,
(0), code);
if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
call get_date_time_from_profile ();
call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (small_area),
date_time_ptr, (0), code);
end;
if code ^= 0 then /* couldn't find a date/time anywhere */
p_date_time = 0;
else p_date_time = based_date_time;
return;
/* Internal to get_time: check for an abbrev style profile and, if present, copy the date/time from it */
get_date_time_from_profile:
procedure ();
dcl home_dir character (168);
dcl person_id character (24);
dcl profile_ename character (32);
dcl 1 old_profile aligned based (profile_ptr), /* abbrev profile */
2 version fixed binary,
2 pad (3) bit (36),
2 check_info_time fixed binary (71);
dcl profile_ptr pointer;
call user_info_$homedir (home_dir);
call user_info_ (person_id);
profile_ename = rtrim (person_id) || ".profile";
profile_ptr = null ();
on cleanup
begin; /* just in case (even with such a small window) */
if profile_ptr ^= null () then call hcs_$terminate_noname (profile_ptr, (0));
profile_ptr = null ();
end;
call hcs_$initiate (home_dir, profile_ename, "", 0b, 00b, profile_ptr, (0));
if profile_ptr ^= null () then do; /* there is a profile */
if old_profile.version = 1 then /* only new style profile has the cis date/time */
call put_time (old_profile.check_info_time);
call hcs_$terminate_noname (profile_ptr, (0));
end;
return;
end get_date_time_from_profile;
end get_time;
/*\014*/
/* Put the updated date/time into the user's value segment */
put_time:
procedure (p_date_time);
dcl p_date_time fixed binary (71) parameter;
call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
currentsize (p_date_time), null (), (null ()), (0), code);
if code = error_table_$noentry then do; /* value segment not present: try to create it */
call create_default_value_segment ();
call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, CIS_VALUE_NAME, addr (p_date_time),
currentsize (p_date_time), null (), (null ()), (0), code);
end;
if code ^= 0 then call com_err_ (code, command, "Attempting to update date/time in default value segment.");
return;
/* Internal to put_time: create the default value segment (if possible) */
create_default_value_segment:
procedure ();
dcl value_segment_path character (168);
call value_$set_path ("", "1"b, code);
if code = 0 then do; /* created it */
call value_$get_path (value_segment_path, (0));
call com_err_ (0, command, "Created ^a.", value_segment_path);
end;
return;
end create_default_value_segment;
end put_time;
/*\014*/
%include sl_info;
%include sl_control_s;
%page;
%include star_structures;
%page;
%include status_structures;
end check_info_segs;
\014
help.pl1 03/27/81 1446.0rew 03/27/81 1444.9 128583
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Name: help */
/* */
/* This is the command interface to the Multics help facility. It does the following. */
/* */
/* 1) call help_$init to obtain a help_args structure in which arguments and control */
/* arguments can be stored. */
/* 2) process caller-supplied arguments, filling in the help_args structure. */
/* 3) call help_ with the help_args structure to actually find and print the info segs. */
/* 4) call help_$term to release the help_args structure. */
/* */
/* help searches for info segments (having a suffix of info) in the directories given in */
/* the search paths of the info_segments (info_segs or infos) search list, which */
/* is maintained by the Multics search facility. */
/* */
/* Status */
/* */
/* 0) Created: November, 1969 by T. H. VanVleck */
/* 1) Modified: February, 1975 by T. H. VanVleck - complete rewrite */
/* 2) Modified: September,1976 by Steve Herbst - accept -pathname ctl_arg */
/* 3) Modified: June, 1977 by Paul Green - diagnose zero-length info segs */
/* 4) Modified: October, 1978 by Gary Dixon - complete rewrite; split into help */
/* command and separate help_ subroutine. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
\014
help: procedure;
dcl
(Iarg_end_ca, Iarg_end_scn, Iarg_start_ca, Iarg_start_scn, Iarg_start_srh)
fixed bin,
(Larg, Lop) fixed bin,
Nargs fixed bin,
(Parg, Pop) ptr,
Serror bit(1) aligned,
(cleanup, conversion, size) condition,
code fixed bin(35),
error_type fixed bin,
(i, j) fixed bin;
dcl
arg char(Larg) based(Parg),
op char(Lop) based(Pop);
dcl (bin, convert, dim, maxlength, null, substr)
builtin;
dcl
com_err_ entry options(variable),
cu_$arg_count entry returns(fixed bin),
cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35));
dcl
(FALSE init ("0"b),
TRUE init ("1"b)) bit(1) aligned int static options(constant),
ctl_abbrev (10) char(6) varying int static options(constant) init (
"-scn", /* 1 */
"-srh", /* 2 */
"-bf", /* 3 */
"-ca", /* 4 */
"-ep", /* 5 */
"-he", /* 6 */
"-bfhe", /* 7 */
"-pn", /* 8 */
"-a", /* 9 */
"-title"), /*10 */
ctl_word (12) char(13) varying int static options(constant) init (
"-section", /* 1 */
"-search", /* 2 */
"-brief", /* 3 */
"-control_arg", /* 4 */
"-entry_point", /* 5 */
"-header", /* 6 */
"-brief_header", /* 7 */
"-pathname", /* 8 */
"-all", /* 9 */
"-titles", /*10 */
"-maxlines", /*11 */
"-minlines"), /*12 */
\014
ctl_obsolete (2) char(3) varying int static options(constant) init (
"-sc", /* 1 */
"-sh"), /* 2 */
(error_table_$bad_arg,
error_table_$badopt,
error_table_$bigarg,
error_table_$inconsistent,
error_table_$noarg,
error_table_$noentry,
error_table_$unimplemented_version)
fixed bin(35) ext static;
\014
%include help_args_;
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
Phelp_args = null;
on cleanup call janitor(); /* Cleanup help arg segment if help aborted. */
call help_$init ("help", "info_segments", "", Vhelp_args_1, Phelp_args, code);
if Phelp_args = null then /* get help input arguments. */
go to ARG_STRUC_ERR;
if help_args.version ^= Vhelp_args_1 then do; /* check version of structure for validity. */
code = error_table_$unimplemented_version;
go to ARG_STRUC_ERR;
end;
Nargs = cu_$arg_count(); /* get count of input arguments. */
Serror = FALSE; /* Remember if error encountered in args. */
Iarg_start_srh = Nargs+1; /* -search not encountered so far. */
Iarg_start_ca = Nargs+1; /* Same for -control_arg. */
Iarg_start_scn = Nargs+1; /* Same for -section */
Iarg_end_ca = 0;
Iarg_end_scn = 0;
help_args.Sctl.he_pn = TRUE; /* Output long heading by default. */
help_args.Sctl.he_counts = TRUE;
do i = 1 to Nargs; /* Process args. */
call cu_$arg_ptr (i, Parg, Larg, 0);
if Larg>=1 & substr(arg,1,1) = "-" then do;
do j = 1 to dim(ctl_abbrev,1) while (arg ^= ctl_abbrev(j));
end;
if j > dim(ctl_abbrev,1) then do;
do j = 1 to dim(ctl_word,1) while (arg ^= ctl_word(j));
end;
if j > dim(ctl_word,1) then do;
do j = 1 to dim(ctl_obsolete,1) while (arg ^= ctl_obsolete(j));
end;
if j > dim(ctl_obsolete,1) then do;
Serror = TRUE;
call com_err_ (error_table_$badopt, "help", arg);
go to NEXT_ARG;
end;
end;
end;
go to DO_ARG(j);
\014
DO_ARG(1): if i = Nargs then go to NO_OPERAND;
call cu_$arg_ptr (i+1, Pop, Lop, code);
if Lop>=1 then
if substr(op,1,1) = "-" then go to NO_OPERAND;
help_args.Sctl.scn = TRUE;
i = i+1; /* -section: next arg guaranteed part of */
Iarg_start_scn = i; /* section name. */
Iarg_end_scn = i;
do i = i+1 to Nargs; /* Remaining args not starting with - are part */
/* of section name too. */
call cu_$arg_ptr (i, Pop, Lop, 0);
if Lop >= 1 then
if substr(op,1,1) = "-" then do;
i = i - 1;
go to NEXT_ARG;
end;
Iarg_end_scn = i;
end;
go to NEXT_ARG;
\014
DO_ARG(2): if i = Nargs then go to NO_OPERAND;
help_args.Sctl.srh = TRUE; /* -search: All remaining args are search */
/* strings. */
Iarg_start_srh = i + 1; /* Remember where search args begin. */
i = Nargs;
go to NEXT_ARG;
DO_ARG(3): help_args.Sctl.bf = TRUE; /* -brief */
go to NEXT_ARG;
DO_ARG(4): if i = Nargs then go to NO_OPERAND;
i = i + 1; /* -control_arg: args not starting with - are */
/* control argument names. */
Iarg_start_ca = i; /* Remember where ca names start. */
Iarg_end_ca = i; /* Remember where last ca name is. */
help_args.Sctl.ca = TRUE; /* -ca */
do i = i+1 to Nargs;
call cu_$arg_ptr (i, Pop, Lop, 0);
if Lop>=1 then
if substr(op,1,1) = "-" then do;
i = i - 1;
go to NEXT_ARG;
end;
Iarg_end_ca = i;
end;
go to NEXT_ARG;
\014
DO_ARG(5): help_args.Sctl.ep = TRUE; /* -entry_point */
go to NEXT_ARG;
DO_ARG(6): help_args.Sctl.he_only = TRUE; /* -header (print only heading) */
go to NEXT_ARG;
DO_ARG(7): help_args.Sctl.he_pn = FALSE; /* -brief_header (output brief headings) */
go to NEXT_ARG;
DO_ARG(8): if i = Nargs then go to NO_OPERAND; /* -pathname: following arg is a pathname, */
i = i + 1; /* no matter what it looks like. */
call cu_$arg_ptr (i, Pop, Lop, 0);
j = 1;
if maxlength(help_args.path(j).value) < Lop then do;
call com_err_ (error_table_$bigarg, "help", " ^a ^a",
arg, op);
Serror = TRUE;
end;
else do;
help_args.Npaths, j = help_args.Npaths + 1;
help_args.path(j).S = "0"b;
help_args.path(j).S.pn_ctl_arg = TRUE;
help_args.path(j).value = op;
help_args.path(j).info_name = "";
end;
go to NEXT_ARG;
\014
DO_ARG(9): help_args.Sctl.all = TRUE; /* -all */
go to NEXT_ARG;
DO_ARG(10): help_args.Sctl.title = TRUE; /* -title */
go to NEXT_ARG;
DO_ARG(11): if i = Nargs then go to NO_OPERAND; /* -maxlines N */
i = i + 1;
call cu_$arg_ptr (i, Pop, Lop, 0);
on conversion, size go to BAD_OPERAND;
help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
revert conversion, size;
if help_args.min_Lpgh < 1 | help_args.min_Lpgh > 50 then
go to BAD_OPERAND;
go to NEXT_ARG;
DO_ARG(12): if i = Nargs then go to NO_OPERAND; /* -minlines N */
i = i + 1;
call cu_$arg_ptr (i, Pop, Lop, 0);
on conversion, size go to BAD_OPERAND;
help_args.min_Lpgh = convert (help_args.min_Lpgh, op);
revert conversion, size;
if help_args.min_Lpgh < 1 | help_args.min_Lpgh > 50 then
go to BAD_OPERAND;
go to NEXT_ARG;
NO_OPERAND: Serror = TRUE; /* No operand given with -scn, -srh, -ca, -pn */
call com_err_ (error_table_$noarg, "help", "No operand given following ^a.", arg);
go to NEXT_ARG;
BAD_OPERAND: Serror = TRUE; /* Bad numeric operand with -minlines. */
call com_err_ (error_table_$bad_arg, "help",
" ^a^/Operand of ^a must be integer from 1 to 50.", op, arg);
end;
else do;
j = 1;
if maxlength(help_args.path(j).value) < Larg then do;
call com_err_ (error_table_$bigarg, "help", " ^a",
arg);
Serror = TRUE;
end;
else do;
help_args.Npaths, j = help_args.Npaths + 1;
help_args.path(j).S = "0"b;
help_args.path(j).value = arg;
help_args.path(j).info_name = "";
end;
end;
NEXT_ARG: end;
\014
if help_args.Sctl.bf then /* Complain if other ctl_args given with -brief */
if help_args.Sctl.title |
help_args.Sctl.all then do;
Serror = TRUE;
call com_err_ (error_table_$inconsistent, "help",
"^/-brief may not be given with: ^[ -title^]^[ -all^].",
help_args.Sctl.title, help_args.Sctl.all);
end;
if help_args.Sctl.ca then /* Complain if other ctl_args given with -ca */
if help_args.Sctl.title |
help_args.Sctl.all then do;
Serror = TRUE;
call com_err_ (error_table_$inconsistent, "help",
"^/-control_arg may not be given with: ^[ -title^]^[ -all^].",
help_args.Sctl.title, help_args.Sctl.all);
end;
if help_args.Sctl.he_only then
if help_args.Sctl.title |
help_args.Sctl.bf |
help_args.Sctl.all |
help_args.Sctl.ca then do;
Serror = TRUE;
call com_err_ (error_table_$inconsistent, "help", "
-header may not be given with: ^[ -brief^]^[ -title^]^[ -control_arg^]^[ -all^].",
help_args.Sctl.bf, help_args.Sctl.title,
help_args.Sctl.ca, help_args.Sctl.all);
end;
if help_args.Npaths = 0 then do; /* Supply default pathname of help_system.gi.info. */
help_args.Npaths = 1;
help_args.path(1).value = ">doc>info>help_system.gi.info";
/* Give info for installed help command. */
help_args.path(1).info_name = "";
help_args.path(1).S = "0"b;
end;
\014
do i = Iarg_start_ca to Iarg_end_ca; /* Add control arg names to arg structure. */
call cu_$arg_ptr (i, Parg, Larg, 0);
j = 1;
if maxlength (help_args.ca(j)) < Larg then do;
Serror = TRUE;
call com_err_ (error_table_$bigarg, "help", " -ca ^a
Maximum length is ^d characters.", arg, maxlength(help_args.ca(j)));
end;
else do;
help_args.Ncas, j = help_args.Ncas + 1;
help_args.ca(j) = arg;
end;
end;
do i = Iarg_start_scn to Iarg_end_scn; /* Add -section substrings to arg structure. */
call cu_$arg_ptr (i, Parg, Larg, 0);
j = 1;
if maxlength (help_args.scn(j)) < Larg then do;
Serror = TRUE;
call com_err_ (error_table_$bigarg, "help", " -scn ^a
Maximum length is ^d characters.", arg, maxlength(help_args.scn(j)));
end;
else do;
help_args.Nscns, j = help_args.Nscns + 1;
help_args.scn(j) = arg;
end;
end;
do i = Iarg_start_srh to Nargs; /* Add -search args to control structure. */
call cu_$arg_ptr (i, Parg, Larg, 0);
j = 1;
if maxlength (help_args.srh(j)) < Larg then do;
Serror = TRUE;
call com_err_ (error_table_$bigarg, "help", " -srh ^a
Maximum length is ^d characters.", arg, maxlength(help_args.srh(j)));
end;
else do;
help_args.Nsrhs, j = help_args.Nsrhs + 1;
help_args.srh(j) = arg;
end;
end;
if Serror then do;
call janitor();
return;
end;
\014
call help_ ("help", Phelp_args, "info", error_type, code);
go to ERROR (error_type);
ARG_STRUC_ERR:
ERROR(1): /* bad help_args version. */
ERROR(2): /* No pathnames given in help_args. */
call com_err_ (code, "help", "^/While processing the argument structure used by help_.");
call janitor();
return;
ERROR(3): /* Error encountered in processing one or more */
/* of the pathnames given in help_args. */
do i = 1 to help_args.Npaths;
if help_args.path(i).code ^= 0 then
call com_err_ (help_args.path(i).code, "help", " ^[-pn ^]^a",
help_args.path(i).S.pn_ctl_arg, help_args.path(i).value);
end;
call janitor();
return;
ERROR(5): /* If a nonzero error code is returned, it means */
/* than -section and -search failed to find any */
/* matching info segs to print. This error must */
/* be reported to the user. */
if code ^= 0 then
call com_err_ (error_table_$noentry, "help", "
Looking for infos matching info_name^[s^]^[^; and -search criteria^; and -section criteria^;, plus -section and -search criteria^].",
(help_args.Npaths > 1), (1 + 2*bin(help_args.Sctl.scn,1) + bin(help_args.Sctl.srh,1)));
ERROR(4): /* No fatal errors encountered. Most nonfatal */
/* errors have been reported by help_. */
call janitor();
return;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
janitor: procedure;
if Phelp_args ^= null then
call help_$term ("help", Phelp_args, code);
end janitor;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
end help;
\014
help_.pl1 11/19/82 1015.7rew 11/19/82 0956.4 1507932
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Name: help_ */
/* */
/* This subroutine implements the help command. It performs the following functions. */
/* */
/* 1) Finds info segments. */
/* 2) Selects particular infos within multi-info segments. */
/* 3) Sorts the list of infos to be processed. */
/* 4) Processes each info, implementing all help control arguments and query responses. */
/* */
/* The subroutine may also be used to implement a help-style information facility in */
/* other subsystems. Information segments (with an info suffix or another suffix) are */
/* selected and printed, based upon information given primarily in a help_args structure, */
/* which is declared in help_args_.incl.pl1. */
/* */
/* Usage */
/* */
/* The help_ subroutine must be invoked by a sequence of calls. */
/* */
/* 1) call help_$init to get temp segment containing help_args structure and stores the */
/* current info_segments search rules in the structure. */
/* 2) call help_ one or more times to select and print info segments. */
/* 3) call help_$term to release the temp segment. */
/* */
/* Entry: help_$check_info_segs */
/* */
/* This subroutine generates the list of info segments to be processed by the */
/* check_info_segs command. It finds info segments modified since a given date, sorts */
/* the list and returns it for check_info_segs to process. */
/* */
/* Usage */
/* */
/* 1) call help_$init to get temp segment containing help_args and the output list. */
/* 2) call help_$check_info_segs to build and sort the list of segments to be processed. */
/* 3) call help_$term to release the temp segment. */
/* */
\014
/* Status */
/* */
/* 0) Created: November, 1969 by T. H. VanVleck */
/* 1) Modified: February, 1975 by T. H. VanVleck - complete rewrite */
/* 2) Modified: September,1976 by Steve Herbst - accept -pathname ctl_arg */
/* 3) Modified: June, 1977 by Paul Green - diagnose zero-length info segs */
/* 4) Modified: October, 1978 by Gary Dixon - complete rewrite; split into help */
/* command and separate help_ subroutine. */
/* Add support for check_info_segs. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
\014
help_: procedure (procedure_name, Phelp_args, suffix, progress, Acode);
dcl /* Parameters */
procedure_name char(*), /* Caller of help_ and help_$init. */
/* 1) Owns temp segment help_args are stored in.*/
/* 2) Name used in error messages. */
/* Phelp_args ptr, /* ptr to argument struc at base of temp seg. */
/* This is really declared in include seg. */
suffix char(*), /* Suffix on segs to be processed. Normally "info"*/
/* but may be some other suffix or "" to omit */
/* suffix processing. */
progress fixed bin, /* =1: bad help_args version */
/* =2: no pathnames given. */
/* =3: evaluating pathnames. */
/* =4: finding help segs. */
/* =5: -section/-search & printing help segs. */
Acode fixed bin(35), /* Return code. */
APPDinfo_seg ptr; /* Ptr to output structures returned by */
/* help_$check_info_segs */
dcl Loutput_line fixed bin, /* Length of terminal user's output line. */
Ninfos_printed fixed bin, /* Number of infos for which something has printed*/
Nlast_info_cross_ref fixed bin, /* Last info with Scross_ref on. */
Nlast_info_no_brief_data fixed bin, /* Last info not containing Syntax section, */
/* which get_brief_data encountered. */
PI_LABEL label variable,
PDeps ptr,
PDinfo ptr,
Pinit_assoc_mem ptr,
Pnext_free_space ptr, /* ptr to next free word location in temp */
/* seg containing help_args. */
Pquery_answers ptr, /* ptr to formatted list of help responses. */
Ptemp ptr,
Sprint_inhibit bit(1) aligned, /* on if printing stopped by program_interrupt. */
cleanup condition,
code fixed bin(35),
fcn fixed bin, /* Function to be performed by this invocation. */
(HELP init(0), /* help_ */
CIS init(1)) /* check_info_segs */
fixed bin int static options(constant),
(i, j) fixed bin,
offset fixed bin(35),
program_interrupt condition;
\014
%include help_cis_args_;
\014
dcl 1 Dinfo aligned based(PDinfo),
2 N fixed bin,
2 seg (0 refer (Dinfo.N)) like Dinfo_seg; /* Information about each log. info to be printed.*/
dcl 1 init_assoc_mem aligned based(Pinit_assoc_mem),
/* Associative memory in which initiated segments */
2 N fixed bin, /* are stored. */
2 seg (50), /* Allow up to 50 initiated segments at once. */
3 dir char(168) unal,
3 ent char(32) unal,
3 uid bit(36),
3 pad fixed bin,
3 P ptr;
dcl 1 LIST aligned based, /* structure used to format list of things to be */
2 header, /* output in columns. */
3 N fixed bin, /* number of list elements. */
3 Nreal fixed bin, /* number of filled list elements. */
3 Npghs fixed bin, /* number of filled paragraphs of formatted out.*/
3 Nrows fixed bin, /* number of rows in formatted output. */
3 Ncols fixed bin, /* number of columns in formatted output. */
3 ML (6) fixed bin, /* length of longest element in each column. */
3 title char(80) varying, /* title of output list. */
3 Iunit fixed bin, /* unit no of pgh containing list elements. */
2 group (0 refer (LIST.N)),
3 arg char(88) varying, /* the argument. */
3 Snot_found fixed bin; /* = 1 if no match found for the argument. */
dcl 1 query_answers aligned based(Pquery_answers),
2 header like LIST.header,
2 group (0 refer (query_answers.N))
like LIST.group;
dcl responses (21) char(36) var int static options(constant) init(
" yes, y", /* List of allowed responses to questions asked */
" rest {-scn},",
" r {-scn}",/* by help_. */
" no, n",
" quit, q",
" top, t",
" header, he",
" title {-top}",
" section {STRs} {-top},",
" scn {STRs} {-top}",
" search {STRs} {-top},",
" srh {STRs} {-top}",
" skip {-scn} {-seen} {-rest} {-ep},",
" s {-scn} {-seen} {-rest} {-ep}",
" brief, bf",
" control_arg STRs, ca STRs",
" entry_point {EP_NAME},",
" ep {EP_NAME}",
" ?",
" .",
" ..");
dcl bit36 bit(36) aligned based,
bit72 bit(72) aligned based;
dcl (addr, addrel, binary, currentsize, dim, dimension, divide, empty, hbound, index, lbound, length,
ltrim, max, maxlength, min, mod, null, ptr, rel, reverse, rtrim, search, string, substr, sum,
translate, verify)
builtin;
dcl
com_err_ entry options(variable),
command_query_ entry options(variable),
convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35)),
get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin),
get_temp_segment_ entry (char(*), ptr, fixed bin(35)),
hcs_$get_uid_seg entry (ptr, bit(36) aligned, 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)),
hcs_$truncate_seg entry (ptr, fixed bin, fixed bin(35)),
(ioa_, ioa_$nnl, ioa_$rsnnl) entry options(variable),
iox_$control entry (ptr, char(*), ptr, fixed bin(35)),
iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)),
ipc_$block entry (ptr, ptr, fixed bin(35)),
match_star_name_ entry (char(*), char(*), fixed bin(35)),
release_temp_segment_ entry (char(*), ptr, fixed bin(35)),
search_paths_$get entry (char(*), bit(36), char(*), ptr, ptr,
fixed bin, ptr, fixed bin(35)),
(sort_items_$bit,
sort_items_$char) entry (ptr, fixed bin);
dcl
BS_underscore char(2) aligned int static options(constant) init ("_"),
FALSE bit(1) aligned int static options(constant) init ("0"b),
HELP_LINE_SIZE fixed bin int static options(constant) init (79),
HT_SP char(2) init(" ") int static options(constant),
/* Horizontal-tab followed by space. */
MAX_HELP_LINE_SIZE fixed bin int static options(constant) init(136),
NL char(1) int static options(constant) init ("
"),
OLD_HELP_PGH_CHAR char(1) aligned int static options(constant) init (""), /* \006 */
SPACES char(100) aligned int static options(constant) init((100)" "),
TRUE bit(1) int static options(constant) init("1"b),
(error_table_$badsyntax,
error_table_$inconsistent,
error_table_$incorrect_access,
error_table_$moderr,
error_table_$no_s_permission,
error_table_$noarg,
error_table_$noentry,
error_table_$nomatch,
error_table_$unimplemented_version,
error_table_$zero_length_seg)
fixed bin(35) ext static,
iox_$user_output ptr ext static,
underscore_BS char(2) aligned int static options(constant) init ("_");
\014
%include help_args_;
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
fcn = HELP; /* Perform a help function. */
go to COMMON;
check_info_segs: entry (procedure_name, Phelp_args, suffix, progress, Acode, APPDinfo_seg);
fcn = CIS; /* Perform a check_info_segs function. */
COMMON: progress = 1;
if help_args.version ^= Vhelp_args_1 then do; /* Validate structure version. */
Acode = error_table_$unimplemented_version;
return;
end;
progress = 2;
if help_args.Npaths ^> 0 then do; /* Make sure info file names were given. */
Acode = error_table_$noarg;
return;
end;
Acode = 0;
progress = 3;
do i = 1 to help_args.Npaths; /* validate input paths. */
call evaluate_path (help_args.path(i), suffix);
if Acode = 0 then
Acode = help_args.path.code(i);
end;
if Acode ^= 0 then return;
progress = 4;
Loutput_line = min (MAX_HELP_LINE_SIZE, get_line_length_$switch (iox_$user_output, code));
if code ^= 0 then Loutput_line = HELP_LINE_SIZE; /* Get user's terminal line size. */
Pquery_answers = set_space_used (Phelp_args, currentsize(help_args));
/* Get space for format list of help responses. */
query_answers.N = 2 * hbound(responses,1); /* Copy allowed responses into the list. */
query_answers.Nreal = query_answers.N;
query_answers.Nrows = 0; /* This indicates that list isn't formatted yet. */
query_answers.title = "List of Responses";
do i = lbound(responses,1) to hbound(responses,1);
query_answers.group(i).arg = responses(i);
end;
do i = i to query_answers.N; /* Struc must be twice size of response array */
query_answers.group(i).arg = ""; /* to allow for extension during formatting. */
end; /* Set added elements to null strings. */
Pinit_assoc_mem, Pnext_free_space = set_space_used (Pquery_answers, currentsize(query_answers));
/* Get space in temp seg for associative memory */
/* used to reduce calls to hcs_$initiate. */
init_assoc_mem.N = 0;
on cleanup call janitor(); /* Establish cleanup on unit. */
\014
PDinfo, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(init_assoc_mem));
Dinfo.N = 0; /* Obtain space for list of info segs to be read. */
do i = 1 to help_args.Npaths; /* Convert input paths to list of info segs. */
if help_args.path(i).S.less_greater then
call get_info_seg_list (procedure_name, suffix, fcn,
help_args.path(i).dir(*), help_args.path(i), PDinfo);
else call get_info_seg_list (procedure_name, suffix, fcn,
help_args.search_dirs(*), help_args.path(i), PDinfo);
end;
if Dinfo.N <= 0 then do; /* Stop if no matching segs found. */
Acode = error_table_$nomatch; /* get_info_seg_list has already complained. */
call janitor();
return;
end;
\014
progress = 5; /* Infos selected by starname. Any other errors */
/* reported via Acode describe info selection by */
/* -search and -seciton criteria. */
PPDinfo_seg, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(Dinfo));
PDinfo_seg.version = VPDinfo_seg_1;
PDinfo_seg.N = Dinfo.N;
do i = 1 to Dinfo.N; /* Sort listed infos thrice: */
PDinfo_seg.P(i) = addr(Dinfo.seg(i).uid); /* 1st: sort on Dinfo.seg.uid/.I combination */
end; /* to eliminate duplicate infos. */
/* 2nd: sort on Dinfo.seg.ent to identify */
/* versions of info seg in different dirs.*/
if Dinfo.N > 1 then do; /* 3rd: sort on Dinfo.seg.Scross_ref/dir/.ent */
call sort_items_$bit (addr(PDinfo_seg.N),72);/* combination to alphabetize output. */
offset = binary (rel (addr (Dinfo.seg(1).ent))) -
binary (rel (addr (Dinfo.seg(1).uid)));
/* Compute negative offset to adjust ptrs to */
/* Dinfo.seg.uid to point back to Dinfo.seg.ent. */
do i = 1 to Dinfo.N while (PDinfo_seg.P(i)->bit72 = "0"b);
PDinfo_seg.P(i) = addrel(PDinfo_seg.P(i), offset);
end; /* Allow duplicate .uid/.I combos for infos */
/* in which errors were encountered. These errors*/
/* must be reported. get_info_seg_list has set */
/* .uid/.I combo to "0"b in these cases. */
j = i - 1;
if i > Dinfo.N-1 then /* if all info segs are in error, skip the */
go to SKIP_ELIMINATION; /* elimination of duplicates. */
go to CHECK(fcn);
CHECK(0): do i = i to Dinfo.N - 1; /* Eliminate duplicate .uid/.I combos. */
if PDinfo_seg.P(i)->bit72 ^= PDinfo_seg.P(i+1)->bit72 then do;
j = j + 1; /* (Only retain unique .uid/.I combos.) */
PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
end;
else PDinfo_seg.P(i+1) = PDinfo_seg.P(i);
/* (Retain info found earliest in search rules).*/
end;
go to END_CHECK;
CHECK(1): do i = i to Dinfo.N - 1; /* Eliminate duplicate .uid combos. */
if PDinfo_seg.P(i)->bit36 ^= PDinfo_seg.P(i+1)->bit36 then do;
j = j + 1; /* (Only retain unique .uid combos.) */
PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
end;
else PDinfo_seg.P(i+1) = PDinfo_seg.P(i);
/* (Retain info found earliest in search rules).*/
end;
END_CHECK: j = j + 1; /* (Always retain the last entry in the list.) */
PDinfo_seg.P(j) = addrel(PDinfo_seg.P(i), offset);
PDinfo_seg.N = j;
end;
else PDinfo_seg.P(1) = addr(Dinfo.seg(1).ent);
\014
SKIP_ELIMINATION:
if PDinfo_seg.N > 1 then do; /* Sort alphabetically by ent to identify info */
call sort_items_$char(addr(PDinfo_seg.N),32);/* segments appearing in more than one search dir.*/
offset = binary (rel (addr (Dinfo.seg(1).Scross_ref))) -
binary (rel (addr (Dinfo.seg(1).ent)));
/* Compute negative offset to adjust ptrs from */
/* Dinfo.seg.ent to point to Dinfo.seg.Scross_ref.*/
PDinfo_seg.P(1) = addrel(PDinfo_seg.P(1), offset);
do i = 1 to Dinfo.N - 1; /* Check for entry of same name in different dirs.*/
PDinfo_seg.P(i+1) = addrel(PDinfo_seg.P(i+1), offset);
if PDinfo_seg.P(i) -> Dinfo_seg.ent = PDinfo_seg.P(i+1) -> Dinfo_seg.ent &
PDinfo_seg.P(i) -> Dinfo_seg.uid ^= PDinfo_seg.P(i+1) -> Dinfo_seg.uid &
PDinfo_seg.P(i) -> Dinfo_seg.uid ^= "0"b &
"0"b ^= PDinfo_seg.P(i+1) -> Dinfo_seg.uid then do;
if binary(rel(PDinfo_seg.P(i)),18) < binary(rel(PDinfo_seg.P(i+1)),18) then do;
Ptemp = PDinfo_seg.P(i); /* Mark all but entry found earliest in search */
PDinfo_seg.P(i) = PDinfo_seg.P(i+1);
PDinfo_seg.P(i+1) = Ptemp; /* rules with a cross reference flag. */
end;
PDinfo_seg.P(i) -> Dinfo_seg.Scross_ref = TRUE;
end;
end;
end;
else PDinfo_seg.P(1) = addr(Dinfo.seg(1).Scross_ref);
if PDinfo_seg.N > 1 then /* Sort alphabetically by Scross_ref/dir/ent combo*/
call sort_items_$char (addr(PDinfo_seg.N), 201 /* = 1 + 168 + 32 */);
if fcn = CIS then do;
call term_assoc_mem();
APPDinfo_seg = PPDinfo_seg;
return;
end;
PDeps, Pnext_free_space = set_space_used (Pnext_free_space, currentsize(PDinfo_seg));
/* Get space for entry point info descriptors. */
Nlast_info_no_brief_data = -1; /* No info processed yet. */
Nlast_info_cross_ref = -1;
PI_LABEL = PROCESS; /* Establish pi handler. */
on program_interrupt begin;
Sprint_inhibit = TRUE;
go to PI_LABEL;
end;
PROCESS: Ninfos_printed = 0;
do i = 1 to PDinfo_seg.N; /* Process each listed info in alphabetical order.*/
call process_info_seg (procedure_name, suffix, i, Ninfos_printed, PDinfo_seg.N,
Nlast_info_no_brief_data, Nlast_info_cross_ref, PDinfo_seg.P(i) -> Dinfo_seg, PDeps);
NEXT_INFO: end;
if Ninfos_printed = 0 then /* -section and -search didn't find any match. */
Acode = error_table_$nomatch;
QUIT: call janitor(); /* Cleanup and return. Simple huh! */
return; /* But wait 'til you see what's below. */
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
evaluate_path: procedure (info_path, suffix);
dcl 1 info_path aligned like help_args.path,
suffix char(*);
dcl i fixed bin;
dcl check_star_name_$entry entry (char(*), fixed bin(35)),
expand_pathname_$add_suffix entry (char(*), char(*), char(*), char(*), fixed bin(35));
info_path.dir(1) = ""; /* Initialize to unset so caller can depend on */
info_path.ent = ""; /* these values. */
info_path.ep = "";
info_path.S.less_greater = (search (info_path.value, "<>") > 0);
/* see if user gave more than just an entryname. */
i = index(reverse(info_path.value), "$"); /* see if user gave a subr entry point name. */
if info_path.S.less_greater then /* Must allow $ in entry names forming dir */
/* part of pathname. */
if search(reverse(info_path.value), "<>") < i then
i = 0;
if i > 0 then /* save entry point name given by user in his */
info_path.ep = substr (info_path.value, length(info_path.value)-i+2);
else info_path.ep = ""; /* pathname argument. */
call expand_pathname_$add_suffix (substr (info_path.value, 1, length(info_path.value)-i), suffix,
info_path.dir(1), info_path.ent, info_path.code);
if info_path.code ^= 0 then /* separate pathname into dir/ent parts, add info */
return; /* suffix. */
if info_path.S.pn_ctl_arg then /* if -pn given, assume relative pathname follows */
info_path.S.less_greater = TRUE; /* (Note we've already expanded path on this */
/* assumption.) */
if info_path.info_name = "" then do;
info_path.S.separate_info_name = FALSE; /* info_name usually = entryname w/o suffix. */
if suffix = "" then
info_path.info_name = info_path.ent;
else info_path.info_name =
substr(info_path.ent, 1, 32 - length(suffix) -
index(reverse(info_path.ent), reverse(suffix)||"."));
end;
else info_path.S.separate_info_name = TRUE;
call check_star_name_$entry (info_path.ent, info_path.code);
if info_path.code = 0 then do; /* if no starname given, -ep ctl arg allowed. */
info_path.S.starname_ent = FALSE;
if help_args.Sctl.ep &
info_path.ep = "" then /* Default ep name = entryname w/o suffix. */
if suffix = "" then
info_path.ep = info_path.ent;
else info_path.ep =
substr(info_path.ent, 1, 32 - length(suffix) -
index(reverse(info_path.ent), reverse(suffix)||"."));
end;
else if info_path.code = 1 | /* forbid -ep if starname was given. */
info_path.code = 2 then do;
info_path.code = 0;
info_path.S.starname_ent = TRUE;
if help_args.Sctl.ep | (info_path.ep ^= "") then
info_path.code = error_table_$inconsistent;
end;
if info_path.code ^= 0 then return;
if info_path.S.separate_info_name then do; /* Check star-ness of user-supplied info_name. */
if info_path.S.info_name_not_starname then
info_path.S.starname_info_name = FALSE;
else do;
call check_star_name_$entry (info_path.info_name, info_path.code);
if info_path.code = 1 |
info_path.code = 2 then do;
info_path.code = 0;
info_path.S.starname_info_name = TRUE;
end;
else info_path.S.starname_info_name = FALSE;
end;
end;
else info_path.S.starname_info_name = info_path.S.starname_ent;
end evaluate_path;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_info_seg_list: procedure (procedure_name, suffix, fcn,
dirs, info_path, PDinfo_) options (non_quick);
/* non_quick so that the large area won't stay around */
/* all the while help active and take up stack frame */
/* space. */
dcl procedure_name char(*),
suffix char(*),
fcn fixed bin,
dirs (*) char(168) unaligned,
1 info_path aligned like help_args.path,
PDinfo_ ptr;
dcl I fixed bin,
Lline fixed bin,
Lseg fixed bin(21),
Nbranches fixed bin,
Nentries fixed bin,
Nlinks fixed bin,
Nentry_names fixed bin,
Nstart fixed bin,
Pentry ptr,
Pentry_name ptr,
Pseg ptr,
Ptemp ptr,
area area (25000) init(empty()),
code fixed bin(35),
(i, j, k) fixed bin,
l fixed bin(21),
line char(Lline) based(Pseg),
linfo_name char(32), /* info name without the suffix. */
sinfo_name char(32), /* info name with the suffix. */
saved_date fixed bin(71);
dcl 1 Dinfo_ aligned based(PDinfo_),
2 N fixed bin,
2 seg (0 refer (Dinfo_.N)) like Dinfo_seg;
dcl 1 branch aligned, /* returned by hcs_$status_long */
(2 type bit(2),
2 pad1 bit(34),
2 pad2 (2) fixed bin(35),
2 mode bit(5),
2 pad3 bit(31),
2 pad4 fixed bin(35),
2 dtem bit(36),
2 pad5 fixed bin(35),
2 pad6 bit(12),
2 bit_count bit(24),
2 pad7 (2) fixed bin(35)) unal;
\014
dcl 1 entry (Nentries) aligned based (Pentry),
(2 type bit(2), /* returned by hcs_$star_dir_list_ */
2 nnames fixed bin(15),
2 nindex fixed bin(17),
2 dtem bit(36),
2 pad1 bit(36),
2 mode bit(5),
2 raw_mode bit(5),
2 master_dir bit(1),
2 bit_count fixed bin(24)) unal,
entry_name (Nentry_names) char(32) aligned based (Pentry_name);
dcl seg char(Lseg) based(Pseg),
/* The info segment. Pseg must be declared in */
/* the external procedure so its on unit */
/* (janitor) can terminate the segment. */
seg_char (Lseg) char(1) based(Pseg);
dcl hcs_$star_dir_list_ entry (char(*), char(*), fixed bin(3), ptr,
fixed bin, fixed bin, ptr, ptr, fixed bin(35)),
hcs_$status_long entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35));
dcl (DIRECTORY init ("10"b),
LINK init ("00"b),
SEGMENT init ("01"b)) bit(2) aligned int static options(constant);
Nstart = Dinfo_.N; /* Remember count of info segs found before we */
/* start. Then we'll know if we find any. */
do i = lbound(dirs,1) to hbound(dirs,1); /* Apply info path to each dir to be searched. */
call hcs_$star_dir_list_ (dirs(i), info_path.ent, 3, addr(area), Nbranches, Nlinks, Pentry, Pentry_name,
code);
if code = 0 then do;
Nentries = Nbranches + Nlinks;
Nentry_names = entry(Nentries).nnames + entry(Nentries).nindex - 1;
do j = 1 to Nentries; /* process entries found in this directory. */
k, Dinfo_.N = Dinfo_.N + 1;
Dinfo_.seg(k).Scross_ref = FALSE;
Dinfo_.seg(k).dir = dirs(i);
Dinfo_.seg(k).ent = entry_name(entry(j).nindex);
Dinfo_.seg(k).info_name = "";
Dinfo_.seg(k).ep = info_path.ep;
Dinfo_.seg(k).segment_type = entry(j).type;
/* Process each entry according to its type. */
if entry(j).type = SEGMENT then do;
Dinfo_.seg(k).L = divide(entry(j).bit_count, 9, 24, 0);
Dinfo_.seg(k).date = numeric_date (entry(j).dtem);
Dinfo_.seg(k).mode = substr(entry(j).mode,2,3);
Dinfo_.seg(k).code = 0; /* extract "rew" mode bits from "trewa". */
if Dinfo_.seg(k).L = 0 then
Dinfo_.seg(k).code = error_table_$zero_length_seg;
else if entry(j).bit_count - 9*Dinfo_.seg(k).L > 0 then
Dinfo_.seg(k).code = error_table_$badsyntax;
end;
else if entry(j).type = LINK then do;
/* Links must be chased, and target examined. */
call hcs_$status_long (Dinfo_.seg(k).dir, Dinfo_.seg(k).ent,
1, addr(branch), null(), code);
if (code = 0) | (code = error_table_$no_s_permission) then do;
if branch.type = SEGMENT then do;
Dinfo_.seg(k).L = divide( binary(branch.bit_count, 24), 9, 24, 0);
Dinfo_.seg(k).date = numeric_date (branch.dtem);
Dinfo_.seg(k).mode = substr(branch.mode,2,3);
Dinfo_.seg(k).code = 0;
if Dinfo_.seg(k).L = 0 then
Dinfo_.seg(k).code = error_table_$zero_length_seg;
else if binary(branch.bit_count, 24) - 9*Dinfo_.seg(k).L > 0 then
Dinfo_.seg(k).code = error_table_$badsyntax;
end;
else if branch.type = LINK then do;
Dinfo_.seg(k).L = 0;
Dinfo_.seg(k).date = 0;
Dinfo_.seg(k).mode = "0"b;
Dinfo_.seg(k).code = error_table_$noentry;
end;
else do; /* Skip matching directories. */
Dinfo_.N = Dinfo_.N - 1;
go to SKIP_ENTRY; /* Forget everything we've done for this entry. */
end;
end;
else do; /* Don't have access to the link target. */
Dinfo_.seg(k).L = 0;
Dinfo_.seg(k).date = 0;
Dinfo_.seg(k).mode = "0"b;
Dinfo_.seg(k).code = code;
end;
end;
else do; /* Skip matching directories. */
Dinfo_.N = Dinfo_.N - 1;
go to SKIP_ENTRY;
end;
if Dinfo_.seg(k).code = 0 then
if (Dinfo_.seg(k).mode & "100"b) then
if help_args.min_date_time ^< Dinfo_.seg(k).date then
Dinfo_.N = Dinfo_.N - 1;
else;
else Dinfo_.seg(k).code = error_table_$moderr;
/* report error if user can't access info seg. */
SKIP_ENTRY: end;
free entry in (area), /* free found entry structures. */
entry_name in (area);
end;
else if code = error_table_$incorrect_access & ^info_path.S.starname_ent then do;
/* If user does not have "s" permission to dir, */
/* look for a specific help seg. */
call hcs_$status_long (dirs(i), info_path.ent, 1, addr(branch), null(), code);
if (code = error_table_$no_s_permission) | (code = 0) then do;
if branch.type ^= DIRECTORY then do;
k, Dinfo_.N = Dinfo_.N + 1;
Dinfo_.seg(k).Scross_ref = FALSE;
Dinfo_.seg(k).dir = dirs(i);
Dinfo_.seg(k).ent = info_path.ent;
Dinfo_.seg(k).info_name = "";
Dinfo_.seg(k).ep = info_path.ep;
Dinfo_.seg(k).segment_type = branch.type;
if branch.type = SEGMENT then do;
Dinfo_.seg(k).L = divide( binary(branch.bit_count, 24), 9, 24, 0);
Dinfo_.seg(k).date = numeric_date (branch.dtem);
Dinfo_.seg(k).mode = substr(branch.mode,2,3);
if Dinfo_.seg(k).mode & "100"b then
Dinfo_.seg(k).code = 0;
else Dinfo_.seg(k).code = error_table_$moderr;
if Dinfo_.seg(k).L = 0 then
Dinfo_.seg(k).code = error_table_$zero_length_seg;
else if binary(branch.bit_count, 24) - 9*Dinfo_.seg(k).L > 0 then
Dinfo_.seg(k).code = error_table_$badsyntax;
else if code = 0 then
if help_args.min_date_time ^< Dinfo_.seg(k).date then
Dinfo_.N = Dinfo_.N - 1;
end;
else do; /* Give error for link target being a link. */
Dinfo_.seg(k).L = 0;
Dinfo_.seg(k).date = 0;
Dinfo_.seg(k).mode = "0"b;
Dinfo_.seg(k).code = error_table_$noentry;
end;
end;
end;
else if code = error_table_$noentry then;
else go to DIR_ERROR;
end;
else if code = error_table_$nomatch then;
else do; /* Fatal error looking in this dir. */
DIR_ERROR: call com_err_ (code, procedure_name,
"^/While looking for info segments in ^a.", dirs(i));
if dim(dirs,1) = 1 then return; /* Avoid getting nomatch error in addition to */
end; /* this one when only 1 dir to look into. */
end;
if fcn = CIS then do;
do i = Nstart+1 to Dinfo_.N;
if Dinfo_.seg(i).code ^= 0 then do;
Dinfo_.seg(i).uid = "0"b;
Dinfo_.seg(i).I = 0;
end;
end;
return;
end;
else if Dinfo_.N = Nstart then do;
if info_path.S.starname_ent then
code = error_table_$nomatch;
else code = error_table_$noentry;
call com_err_ (code, procedure_name,
"^/Looking for: ^[-pn ^]^a", info_path.S.pn_ctl_arg, info_path.value);
end;
else do i = Nstart+1 to Dinfo_.N; /* Look for :Info: info dividers. */
if Dinfo_.seg(i).code = 0 then do;
Dinfo_.seg(i).uid = "0"b; /* We don't know seg's uid yet. */
call initiate (Dinfo_.seg(i).dir, Dinfo_.seg(i).ent, Dinfo_.seg(i).uid, Pseg, code);
if Pseg ^= null then do;
Lseg = Dinfo_.seg(i).L;
Dinfo_.seg(i).I = 1; /* Fill in substring index of 1st */
/* char of physical info seg. */
I = verify(seg, "
");
if I > 1 then do; /* Strip HT SP NL from start of info seg. */
Pseg = addr(seg_char(I));
Lseg = Lseg - (I-1);
end;
if Lseg > 8 then /* See if info seg begins with :Info: */
/* (8 = length(":Info:C:"), C is any char. */
if substr(seg,1,6) = ":Info:" then do;
Pseg = addr(seg_char(7));
Lseg = Lseg - 6;
k = i;
Dinfo_.seg(k).info_name = info_path.info_name;
/* save info_name used to find infos for use in */
/* error messages (without suffix). */
saved_date = Dinfo_.seg(k).date;
/* save date assoc with phys info seg in case */
/* some log. infos don't have date in their header*/
end;
else Lseg, k = 0;
else Lseg, k = 0;
do while (Lseg > 0); /* It does contain :Info:. Look for info(s) */
Lline = index(seg, NL); /* which match user-supplied entryname. */
if Lline = 0 then Lline = Lseg;
linfo_name = find_info_name(line, I);
do while (I > 0);
if info_path.S.starname_info_name then do;
call match_star_name_ (linfo_name, info_path.info_name, code);
if code ^= 0 then go to NO_MATCH;
end;
else if linfo_name ^= info_path.info_name then
go to NO_MATCH;
if ^info_path.S.separate_info_name then do;
/* POTENTIAL BUG: Use of assoc. memory for */
/* initiated segs may subvert test to see if */
/* info_name really a name on phys. info seg. */
/* Subsequent attempt to reinitiate may succeed */
/* by uid found in assoc mem, rather than by name */
/* being found on phys. info seg. */
if suffix ^= "" then
sinfo_name = rtrim(linfo_name) || "." || suffix;
else sinfo_name = linfo_name;
/* Test now to see if log info_name is on seg. */
if info_path.S.starname_ent then do;
call hcs_$initiate (Dinfo_.seg(k).dir, sinfo_name, "", 0, 0,
Ptemp, code);
if Ptemp = null then go to NO_MATCH;
end;
Dinfo_.seg(k).ent = sinfo_name;
end;
/* This info matches. Include it in output list. */
j = Lline - index(reverse(line),":") + 2;
Dinfo_.seg(k).I = rel_char(addr(seg_char(j))) + 1;
/* get index of first char of this info. */
/* 1 is added to the char offset returned by */
/* rel_char to get a char index. */
l = index(seg,"
:Info:"); /* get info length by finding next info. */
if l > 0 then
Dinfo_.seg(k).L = l - (j-1);
else Dinfo_.seg(k).L = Lseg - (j-1);
Pseg = addr(seg_char(j));
Lseg = Lseg - (j-1);
Lline = Lline - (j-1);
j = verify(seg, "
");
if j > 1 then do; /* Remove leading HT SP NL from log info. */
Pseg = addr(seg_char(j));
Lseg = Lseg - (j-1);
Lline = index(seg, NL);
if Lline = 0 then Lline = Lseg;
end;
if Lseg >= Lline+1 then /* Store date assoc with log info. */
if seg_char(Lline+1) = NL then do;
/* Date comes from 1st field of heading line of */
/* log info, which must be followed by blank line.*/
Lline = Lline - 1;
j = search (line, " ");
if j = 0 then
j = Lline;
else do;
call convert_date_to_binary_ (substr(line,1,j), Dinfo_.seg(k).date, code);
if code ^= 0 then
Dinfo_.seg(k).date = saved_date;
end;
end;
else Dinfo_.seg(k).date = saved_date;
else Dinfo_.seg(k).date = saved_date;
I = 0; /* Stop processing this :Info: line (this info). */
if ^(info_path.S.starname_info_name | info_path.S.separate_info_name) then
Lseg = 0; /* If not a starname or separate info_name, */
/* we've found one & only matching log. info */
if help_args.min_date_time ^< Dinfo_.seg(k).date then
go to MATCH; /* Info modified before min date; skip it */
Dinfo_.seg(k).info_name = linfo_name;
/* Save info_name for use in headings. */
k, Dinfo_.N = Dinfo_.N + 1;
Dinfo_.seg(k) = Dinfo_.seg(i);
go to MATCH;
NO_MATCH: Pseg = addr(seg_char(I+1));
Lseg = Lseg - I; /* Look for another name on this info, since */
Lline = Lline - I; /* previous names on it don't match user wants. */
linfo_name = find_info_name (line, I);
MATCH: end;
I = index(seg, "
:Info:");
if I = 0 then Lseg = 0;
else do;
Pseg = addr(seg_char(I+9));
Lseg = Lseg - (I+8);
end;
end;
if k = 0 then; /* No :Info: in phys info seg. */
else if k = i then /* No matching info in phys info seg. */
if info_path.S.starname_info_name then
Dinfo_.seg(i).code = error_table_$nomatch;
else Dinfo_.seg(i).code = error_table_$noentry;
else Dinfo_.N = Dinfo_.N - 1; /* Matching info found. We always get one more */
/* Dinfo_.seg than we can use. */
end;
else Dinfo_.seg(i).code = code; /* Failed to initiate physical info seg. */
end;
if Dinfo_.seg(i).code ^= 0 then do;
Dinfo_.seg(i).uid = "0"b; /* If error occurred during processing, mark */
Dinfo_.seg(i).I = 0; /* info to cause error message to be printed. */
end;
end;
\014
find_info_name: proc (Aline, Iline) returns(char(32));
dcl Aline char(*), /* unprocessed part of :Info: line (incl NL). */
Iline fixed bin, /* amount processed while finding this info name. */
info_name char(32) varying; /* the info_name which was found. */
dcl (Icolon, Inon_space, Iquote, Iquote_quote)
fixed bin,
Lline fixed bin,
Pline ptr;
dcl (QUOTE char(1) init(""""),
QUOTE_QUOTE char(2) init("""""")) int static options(constant);
dcl line char(Lline) based(Pline),
line_char (Lline) char(1) based(Pline);
Pline = addr(Aline);
Lline = length(Aline);
Inon_space = verify (line, HT_SP); /* Remove leading white space from info name. */
if Inon_space > 1 then do;
Pline = addr(line_char(Inon_space));
Lline = Lline - (Inon_space-1);
end;
else if Inon_space = 0 then do; /* Remainder of line is empty. */
ERROR: Iline = length(Aline);
return("");
end;
if line_char(1) = QUOTE then do; /* Look for quoted info name. */
Pline = addr(line_char(length(QUOTE)+1)); /* Skip the opening quote. */
Lline = Lline - length(QUOTE);
Iquote = index (line, QUOTE); /* Search for trailing quote. */
if Iquote=0 | Iquote+2>Lline then /* Trailing quote is missing. */
go to ERROR;
Iquote_quote = index (line, QUOTE_QUOTE); /* Check for doubled quotes. */
if Iquote ^= Iquote_quote then /* There are none. */
info_name = substr (line, 1, Iquote-1);
else do; /* Doubled quotes must be undoubled in info name*/
info_name = "";
do while (Iquote = Iquote_quote);
info_name = info_name || substr (line, 1, Iquote);
Pline = addr(line_char(Iquote + length(QUOTE_QUOTE)));
Lline = Lline - (Iquote + length(QUOTE_QUOTE) - 1);
Iquote = index (line, QUOTE);
if Iquote=0 | Iquote+2>Lline then go to ERROR;
Iquote_quote = index (line, QUOTE_QUOTE);
end;
info_name = info_name || substr (line, 1, Iquote-1);
end;
Pline = addr(line_char(Iquote + length(QUOTE)));
Lline = Lline - (Iquote + length(QUOTE) - 1);
Inon_space = verify (line, HT_SP); /* Remove trailing white space. */
if Inon_space > 1 then do;
Pline = addr(line_char(Inon_space));
Lline = Lline - (Inon_space-1);
end;
else if Inon_space = 0 then go to ERROR; /* No trailing colon. Skip last name. */
if line_char(1) = ":" then /* info name found in correct format. */
Iline = length(Aline) - (Lline - 1);
else go to ERROR; /* No trailing colon. That's bad; */
end;
else do; /* Info name is not quoted. */
Icolon = index (line, ":");
if Icolon = 0 then go to ERROR; /* No trailing colon. */
info_name = rtrim (substr (line, 1, Icolon-1));
Iline = length(Aline) - (Lline - Icolon);
end;
return (info_name);
end find_info_name;
end get_info_seg_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
initiate: proc (dir, ent, uid, Pseg, code); /* Provide an associative memory for info segs */
/* to reduce amt. of double initiating each seg. */
dcl dir char(168) unal,
ent char(32) unal,
uid bit(36) aligned,
Pseg ptr,
code fixed bin(35);
dcl i fixed bin;
dcl Iempty fixed bin;
Iempty = 0; /* No empty slots in assoc. mem so far. */
code = 0;
Pseg = null;
do i = 1 to init_assoc_mem.N while (Pseg = null); /* Look for seg to be initiated in assoc. mem. */
if init_assoc_mem.seg(i).uid ^= "0"b then do;/* Zero uid? No, we must check the cell. */
if uid ^= "0"b then /* Can't check if we don't know segs uid. */
if uid = init_assoc_mem.seg(i).uid then
Pseg = init_assoc_mem.seg(i).P;
/* Found seg in assoc mem. Got off cheap! */
else;
else if dir = init_assoc_mem.seg(i).dir & ent = init_assoc_mem.seg(i).ent then do;
/* Check segs dir/ent with assoc mem. */
uid = init_assoc_mem.seg(i).uid;
Pseg = init_assoc_mem.seg(i).P;
end;
end;
else if Iempty = 0 then /* Remember first empty cell in case seg not */
Iempty = i; /* found in assoc. mem. */
end;
if Pseg ^= null then return; /* See found in assoc. All done! */
call hcs_$initiate (dir, ent, "", 0, 0, Pseg, code);
if Pseg = null then return; /* Have to initiate the segment. */
call hcs_$get_uid_seg (Pseg, uid, code); /* Complain if error. Otherwise, get seg's uid. */
do i = 1 to init_assoc_mem.N while (init_assoc_mem.seg(i).uid ^= uid);
end; /* make sure uid doesn't appear in assoc memory */
if i <= init_assoc_mem.N then return; /* under another name. If so, don't add again. */
if Iempty = 0 then /* If no empty cells, must make one. */
if init_assoc_mem.N < dimension (init_assoc_mem.seg, 1) then do;
init_assoc_mem.N = init_assoc_mem.N + 1;
Iempty = init_assoc_mem.N; /* Add new cell to the table, if room. */
end;
else do; /* Must terminate cell member to make room for new*/
Iempty = init_assoc_mem.N; /* seg in assoc. mem. */
call hcs_$terminate_noname (init_assoc_mem.seg(Iempty).P, code);
end;
init_assoc_mem.seg(Iempty).dir = dir;
init_assoc_mem.seg(Iempty).ent = ent;
init_assoc_mem.seg(Iempty).uid = uid;
init_assoc_mem.seg(Iempty).P = Pseg;
return;
\014
terminate: entry (Pseg, code);
do i = init_assoc_mem.N to 1 by -1 while (Pseg ^= init_assoc_mem.seg(i).P);
end; /* Start looking at end of assoc. mem. since seg */
init_assoc_mem.seg(i).uid = "0"b; /* is most likely to be there. */
if i = init_assoc_mem.N then
init_assoc_mem.N = init_assoc_mem.N - 1;
call hcs_$terminate_noname (Pseg, code);
end initiate;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
janitor: procedure; /* terminate known info segs; truncate temp seg. */
call term_assoc_mem();
call hcs_$truncate_seg (Phelp_args, currentsize(help_args), 0);
end janitor;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
numeric_date: procedure (bit_date) returns (fixed bin(71));
/* This procedure converts a file system date */
/* to a numeric clock value. A file system date */
/* is the high-order 36 bits of a 52 bit clock */
/* value. */
dcl bit_date bit(36) unal,
num_date fixed bin(71);
num_date = 0;
substr(unspec(num_date),21,36) = bit_date;
return (num_date);
end numeric_date;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
rel_char: proc (P) returns(fixed bin(21)); /* This procedure converts a pointer value into */
/* a character offset from base of segment */
/* pointed to. We need a PL/I bif to do this. */
dcl P ptr;
dcl I fixed bin(21),
P1 ptr,
i fixed bin;
dcl char_offset (0:3) char(1) based(P1);
P1 = ptr(P, rel(P));
I = 4 * binary(rel(P));
do i = 0 to 3 while (addr(char_offset(i)) ^= P);
end;
I = I + i;
return(I);
end rel_char;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
set_space_used: procedure (Pcurrent_space, size_current_space) returns(ptr);
/* This procedure returns pointer to next free */
/* word of storage in help_args temp segment. */
dcl Pcurrent_space ptr, /* ptr to last space allocated in the seg. */
size_current_space fixed bin(21), /* amount of space used in structure last alloc. */
Pnext_space ptr; /* ptr to next free space. */
Pnext_space = addrel (Pcurrent_space, size_current_space + mod(size_current_space,2));
return (Pnext_space);
end set_space_used;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
term_assoc_mem: procedure; /* terminate known info segs. */
do init_assoc_mem.N = init_assoc_mem.N to 1 by -1;
if init_assoc_mem.seg(init_assoc_mem.N).uid ^= "0"b then
call hcs_$terminate_noname (init_assoc_mem.seg(init_assoc_mem.N).P, 0);
end;
end term_assoc_mem;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
process_info_seg: procedure (procedure_name, suffix, Iinfo, Ninfos_printed, Ninfos, Nlast_info_no_brief_data,
Nlast_info_cross_ref, Dinfo_seg_, PDeps);
/* This procedure does all the work of printing */
/* each info. */
dcl procedure_name char(*),
suffix char(*),
Iinfo fixed bin, /* Number of the info being processed. */
Ninfos_printed fixed bin, /* Number of infos for which something has printed*/
Ninfos fixed bin(24), /* Number of infos handled during this invocation */
Nlast_info_no_brief_data fixed bin, /* Last info processed not containing Syntax sect.*/
Nlast_info_cross_ref fixed bin, /* Last info processed with Scross_ref on. */
/* as diagnosed by get_brief_data. */
1 Dinfo_seg_ aligned like Dinfo_seg,
PDeps ptr;
dcl Iep fixed bin, /* subscript of current entry point or info */
/* (logical info segment) being processed. */
Iunit fixed bin, /* subscript of current unit (paragraph). */
Iunit_end fixed bin,
Iunit_search fixed bin, /* searching begins with this unit. */
Iunit_syntax (10) fixed bin, /* indices of syntax units. */
Lcount fixed bin,
Linfo_name fixed bin,
Loutput fixed bin,
Lpath fixed bin,
Lpgh fixed bin,
Lseg fixed bin(21),
(Ncommon_units, Nconsecutive_bad_ops, Nuncommon_units, Nprint_units)
fixed bin,
(Nlines, Nlines_titles) fixed bin,
(Nlists_of_args, Nlists_of_bf_args)
fixed bin,
Nunit_syntax fixed bin, /* number of syntax units. */
(Plist, Plist_of_titles, Plist_of_cas)
ptr,
Pcommon_units ptr,
PDlinfo ptr,
Plist_base ptr,
Plists_of_args (18) ptr,
Poutput ptr,
Ppgh ptr,
Pseg ptr,
Sfound bit(1) aligned,
Sloop bit(1) aligned,
(Snl1,Snl2) bit(1) aligned, /* Switches used to compute if NL should be output.*/
ISnl3 fixed bin,
Ssearch bit(1) aligned, /* on if -section/-search searching to be done. */
Sseen bit(1) aligned, /* on if pgh already seen by user. */
answer char(500) varying,
ep_name char(65) varying,
(i, j) fixed bin,
match_result fixed bin,
(no_match init(0),
match init(1),
exact_match init(2)) fixed bin int static options(constant),
new_section char(88) varying, /* title of new section in which match pgh found */
op fixed bin,
query char(200) varying,
query_type fixed bin,
(normal init(1),
some_unseen init(2),
search_unseen init(3),
new_entry init(4)) fixed bin int static options(constant),
ref_name char(32) varying;
dcl 1 query_info aligned int static options(constant),
2 version fixed bin init(2),
2 yes_or_no_sw bit(1) unal init("0"b),
2 suppress_name_sw bit(1) unal init("1"b),
2 CODE fixed bin(35) init(0),
2 query_code fixed bin(35) init(0);
dcl 1 list_base aligned based(Plist_base),
/* struc locating lists of things to be output. */
2 N fixed bin, /* number of output lists now allocated. */
2 Nmax fixed bin, /* max number of list ptrs allocatable. */
2 Ispace_used_set fixed bin, /* index of last list on which space used set. */
2 Plists (0 refer(list_base.Nmax))
ptr; /* ptrs to allocated lists. */
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
/* struc containing lists of things to be output. */
dcl 1 Deps aligned based (PDeps),
/* structure defining all entry points in log info*/
2 Nlines fixed bin, /* number of lines in log info. */
2 N fixed bin, /* total number of entry points in log info. */
2 linfo (0: 0 refer (Deps.N)), /* description of each entry point. */
3 date fixed bin(71), /* binary date assoc with entry point. */
3 Nep_names fixed bin, /* number of entry point names. */
3 ep_name (20) char(32) var, /* name of the entry point. */
3 PDlinfo ptr, /* ptr to paragraph descriptors for this info.*/
3 Pstart ptr, /* first character of entry point info. */
3 L fixed bin, /* length (in chars) of entry point info. */
3 header char(88) varying, /* its heading line. */
3 Nlines fixed bin, /* number of lines in entry point info. */
3 S, /* switches: */
(4 seen_by_user, /* this entry point seen by the user. */
4 old_format) bit(1) unal, /* this entry point contains \006 chars. */
4 pad1 bit(34) unal;
\014
dcl 1 Dlinfo aligned based (PDlinfo),
/* structure defining all paragraphs (units) in */
/* an entry point (misnamed linfo). */
2 Nunits fixed bin, /* number of units in this ep. */
2 Nsections fixed bin, /* number of units beginning a section. */
2 unit (0 refer (Dlinfo.Nunits)), /* unit (paragraph) descriptors. */
3 Pstart ptr, /* ptr to first char of unit (excl. title). */
3 title char(80) varying, /* title of the unit. */
3 L fixed bin(21), /* length of the unit (in chars). */
3 Nlines fixed bin, /* number of lines in the unit. */
3 S aligned, /* switches. */
(4 scn, /* unit begins a new section. */
4 seen_by_user, /* unit has been seen by user. */
4 ep_list, /* unit is an entry point list, to be */
/* generated by help_. */
4 arg_list) bit(1) unal, /* unit is Arguments or Control args. */
4 pad1 bit(14) unal,
3 Icommon_unit fixed bin(17) unal; /* Index of common pgh in common_units. */
dcl 1 common_units (Ncommon_units) aligned like Dlinfo.unit based(Pcommon_units);
dcl 1 ca aligned, /* current control_arg STRs. */
2 header like LIST.header,
2 group (100) like LIST.group,
1 scn aligned, /* current section STRs. */
2 header like LIST.header,
2 group (100) like LIST.group,
1 srh aligned, /* current search STRs. */
2 header like LIST.header,
2 group (100) like LIST.group;
dcl output char(Loutput) based(Poutput);
dcl pgh char(Lpgh) based(Ppgh);
dcl seg_char (Lseg) char(1) based(Pseg);
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* 1) Report any errors encountered while finding physical info segment. */
/* 2) Initiate the physical info segment. */
/* 3) Parse up the physical info segment into logical info segments (infos). */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
PI_LABEL = NEXT_INFO; /* Before any output starts, a pi skips to next */
/* info. */
Sprint_inhibit = FALSE; /* Printing is not inhibited yet. */
ca.N, scn.N, srh.N = 0; /* No control_arg, search or section args done. */
ref_name = ""; /* No entry point reference name set yet. */
if Dinfo_seg_.code ^= 0 then do; /* Print any error encountered while finding seg. */
INIT_ERROR: call com_err_ (Dinfo_seg_.code, procedure_name,
"^/While processing ^[link^;segment^;directory^] ^a^[>^]^a^[
Looking for an info matching ^a^].",
binary (Dinfo_seg_.segment_type, 2) + 1,
Dinfo_seg_.dir, Dinfo_seg_.dir ^= ">", Dinfo_seg_.ent,
(Dinfo_seg_.info_name ^= ""), Dinfo_seg_.info_name);
go to RETURN;
end;
call initiate (Dinfo_seg_.dir, Dinfo_seg_.ent, Dinfo_seg_.uid, Pseg, code);
if Pseg = null then go to INIT_ERROR; /* Initiate the info segment. */
Lseg = Dinfo_seg_.I; /* Address first char of logical info. */
Pseg = addr(seg_char(Dinfo_seg_.I));
Lseg = Dinfo_seg_.L; /* Address all/only log info we are printing. */
if Lseg = 0 then do;
code = error_table_$zero_length_seg;
go to INIT_ERROR;
end;
call parse_info_into_entry_points (Pseg, Lseg, PDeps);
/* Parse up the log info into entry points. */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Various kinds of output (arguments and control arguments, section titles, */
/* entry point names, etc) are output in columnar lists. More than one list */
/* may exist at a time. Initialize array of list pointers to keep track of them. */
/* The lists themselves are appended to the end of the segment containing */
/* the help_args structure, as are all of the variable size structures used in help_. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
Pnext_free_space = addrel(PDeps, currentsize(Deps));
/* reuse space for lists, etc each time that */
/* process_info_seg is called. */
Plist_base = get_list_base (Pnext_free_space, currentsize(Deps), 30);
/* get space for gen'l purpose list of lists. */
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* 1) Get space for the descriptor of the paragraphs (units) in the common (or only) part */
/* of the logical info. Parse this common part into pgh units. */
/* 2) If there are other entry point descriptions in the log info, then */
/* get space for their paragraph descriptors. */
/* Parse them up into pghs, and append to their descriptors the common units */
/* (paragraphs included in all entry points) obtained from the common info */
/* descriptors created in step 1 above. */
/* All entry point parts must be parsed now to get line count of entire info right. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
Ncommon_units = 0; /* No common info has been found yet. */
PDlinfo = Pnext_free_space; /* get space for paragraph descriptions of common */
/* or only part of logical info. */
call parse_entry_point_into_units (Deps.linfo(0), Pcommon_units, Ncommon_units, PDlinfo);
Pnext_free_space = set_space_used (PDlinfo, currentsize(Dlinfo));
if Deps.N > 0 then do; /* handle log. info w/ several entry point parts. */
do Nuncommon_units = 2 to Dlinfo.Nunits
while (^Dlinfo.unit(Nuncommon_units).S.scn);
/* Find paragraphs in common part which are */
/* shared by (common to) all entry point parts. */
end;
Nuncommon_units = Nuncommon_units - 1;
Ncommon_units = Dlinfo.Nunits - Nuncommon_units;
if (Ncommon_units = 0) & (Nuncommon_units = 1) then
if length(Dlinfo.unit(1).title) > length("Entry points in") then
if substr(Dlinfo.unit(1).title,1,length("Entry points in ")) = "Entry points in " then do;
Nuncommon_units = 0;
Ncommon_units = 1;
end;
if Ncommon_units > 0 then do;
Pcommon_units = addr (Dlinfo.unit(Nuncommon_units+1));
end;
else Pcommon_units = PDlinfo;
do i = 1 to Ncommon_units; /* Find section of common part containing */
/* help-generated list of entry points in info. */
if length(common_units(i).title) > 15 then /* 15 = length("Entry points in "). */
if substr(common_units(i).title,1,15) = "Entry points in " then do;
common_units(i).S.ep_list = TRUE;
j = i;
do i = i to Ncommon_units; /* Remove any pghs following this special one */
/* from the common part of the info. */
Deps.linfo(0).Nlines = Deps.linfo(0).Nlines -
common_units(i).Nlines - 2;
end; /* Subtract line count of pghs following the */
/* "Entry points in " section. */
Ncommon_units = j; /* "Entry points in " is last pgh of info. */
Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
end;
end;
\014
if Ncommon_units > 0 then
if common_units(Ncommon_units).S.ep_list then do;
Plist = get_list (Plist_base); /* Build entry point list pghs in temp seg. */
list.title = common_units(Ncommon_units).title;
if ref_name = "" then
if suffix = "" then
ref_name = rtrim(Dinfo_seg_.ent);
else ref_name = substr(Dinfo_seg_.ent, 1, 32 - length(suffix) -
index(reverse(Dinfo_seg_.ent), reverse(suffix) || "."));
call get_ep_list (ref_name, PDeps, Plist);
call format_list (Plist, divide(list.N, 5, 17, 0) + 1, 0);
Ncommon_units = Ncommon_units - 1; /* Forget about empty entry point list pgh for now*/
Poutput, Pnext_free_space = set_space_used (Plist, currentsize(list));
do i = 1 to list.Npghs; /* Create new entry point list pghs. */
call output_list (Plist, i, Poutput, Loutput, Nlines);
j, Ncommon_units = Ncommon_units + 1;
common_units(j).Pstart = Poutput; /* Add new pghs to end of common units. */
common_units(j).L = Loutput;
common_units(j).Nlines = Nlines;
Deps.linfo(0).Nlines = Deps.linfo(0).Nlines + Nlines + 2;
common_units(j).S = "0"b;
if i = 1 then do; /* Include section title for 1st pgh of ep list.*/
common_units(j).title = list.title;
common_units(j).S.scn = TRUE;
end;
else do; /* No section title for subsequent pghs. */
common_units(j).title = "";
end;
common_units(j).S.ep_list = TRUE; /* Remember how pghs got there (for debugging). */
Poutput, Pnext_free_space = set_space_used (Poutput, currentsize(output));
end; /* Get space for next pgh. */
Dlinfo.Nunits = Nuncommon_units + Ncommon_units;
list_base.N = list_base.N - 1; /* Discard list containing entry point names. */
end;
do i = 1 to Ncommon_units; /* Mark all common units by number. */
common_units(i).Icommon_unit = i; /* This will help avoid seeing common units in */
end; /* every entry point info. */
PDlinfo = Pnext_free_space;
do i = 1 to Deps.N; /* Parse all other entry points to count lines. */
call parse_entry_point_into_units (Deps.linfo(i), Pcommon_units, Ncommon_units, PDlinfo);
PDlinfo, Pnext_free_space = set_space_used (PDlinfo, currentsize(Dlinfo));
end; /* Common pghs added to other entries when parsed.*/
end;
else do;
Pcommon_units = PDlinfo;
Ncommon_units = 0;
end;
Deps.Nlines = sum(Deps.linfo.Nlines); /* Count lines in total info. */
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Copy -section and -search control arguments. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
if help_args.Sctl.scn then do; /* Copy -section args to local storage. */
do i = 1 to min(help_args.Nscns, dim(scn.arg,1));
scn.arg(i) = help_args.scn(i);
end;
scn.N = i-1;
end;
if help_args.Sctl.srh then do; /* Copy -search args to local storage. */
do i = 1 to min(help_args.Nsrhs, dim(srh.arg,1));
srh.arg(i) = help_args.srh(i);
end;
srh.N = i-1;
end;
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Find the correct logical info segment (info), if any was requested by user. */
/* If desired info was not found, then any searching required for the */
/* -section and -search control arguments cannot and will not be done, though the */
/* operands given with these control arguments are stored as the default values to be */
/* used with the section and search requests if first issued without operands. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
if Dinfo_seg_.ep = "" then do; /* if no entry point requested, */
if help_args.min_date_time ^= -1 then do; /* process 1st newer than given date/time */
do Iep = 0 to Deps.N while (help_args.min_date_time ^< Deps.linfo(Iep).date);
end; /* iff a nonzero date/time selector was given. */
if Iep > Deps.N then Iep = 0;
end;
else if help_args.Sctl.scn | help_args.Sctl.srh then do;
Ssearch = FALSE; /* process 1st entry containing matches for */
Iunit = 1; /* -section and/or -search ctl_args. */
if help_args.Sctl.scn & help_args.Sctl.srh then do;
do Iep = 0 to Deps.N while(^Ssearch);
match_result = find_section (Deps.linfo(Iep).PDlinfo, scn, Iunit);
if match_result ^= no_match then
Ssearch = find_pgh (Deps.linfo(Iep).PDlinfo, srh, Iunit, new_section);
end;
end;
else if help_args.Sctl.scn then do;
do Iep = 0 to Deps.N while(^Ssearch);
match_result = find_section (Deps.linfo(Iep).PDlinfo, scn, Iunit);
Ssearch = (match_result ^= no_match);
end;
end;
else do;
do Iep = 0 to Deps.N while(^Ssearch);
Ssearch = find_pgh (Deps.linfo(Iep).PDlinfo, srh, Iunit, new_section);
end;
end;
if ^Ssearch then return;
Iep = Iep - 1;
end;
else Iep = 0; /* otherwise, process general description. */
Ssearch = TRUE;
end;
\014
else do; /* else search for requested entry point. */
Sfound = FALSE;
do Iep = 1 to Deps.N while (^Sfound);
do i = 1 to Deps.linfo(Iep).Nep_names while(^Sfound);
if Dinfo_seg_.ep = Deps.linfo(Iep).ep_name(i) then
Sfound = TRUE;
end;
end;
if Sfound then do;
Iep = Iep - 1;
Ssearch = TRUE; /* Do -section/-search matching if user asked. */
end;
else do; /* requested ep not found. */
if Dinfo_seg_.info_name = "" then
Linfo_name = 0;
else Linfo_name = length(rtrim(Dinfo_seg_.info_name)) + length(" ()");
call com_err_ (error_table_$noentry, procedure_name,
"^/Looking for entry point ^a in info^[ ^a^/(^a^[>^]^a)^;^s^/^a^[>^]^a^]",
Dinfo_seg_.ep, Linfo_name>0, Dinfo_seg_.info_name,
Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent);
Ssearch = FALSE; /* Don't do -section/-search matching. */
Iep = 0;
end;
end;
PDlinfo = Deps.linfo(Iep).PDlinfo; /* Address entry point user wants first. */
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* When -header is given without other control arguments, generate a heading line */
/* containing full pathname of physical info segment, title line from logical */
/* info segment, line count of logical info segment, and count of logical info segments */
/* (infos) in physical info seg (excluding common portion at the beginning). */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
Ninfos_printed = Ninfos_printed + 1; /* Beyond this point, something must get printed. */
if Dinfo_seg_.Scross_ref then do; /* Just remark about existence of other versions */
/* of an info. */
if Ninfos_printed = 1 then do;
call ioa_ ("^a: No infos matching -section and -search control arguments were found.", procedure_name);
call ioa_ ("However, several infos appear more than once in the search paths.");
call ioa_ ("The following secondary info(s) match -section and -search control arguments.");
end;
else if Nlast_info_cross_ref ^= Iinfo-1 then do;
call ioa_ ("^v/^a: Other versions of the info^[s^] above were found. See also:",
help_args.Lspace_between_infos, procedure_name, Ninfos_printed>2);
end;
call ioa_ (" ^a^[>^]^a", Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent);
Nlast_info_cross_ref = Iinfo;
go to RETURN;
end;
else if help_args.Sctl.he_only then do; /* When -header is given without other ctl_args */
/* output the header and return. */
call print_header_only();
go to RETURN;
end;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* The -brief control argument requests that the "Syntax" section (or "Usage" section of */
/* old format info segs) be output in full, along with a list of arguments and control */
/* arguments from the "Arguments" and "Control arguments" sections. */
/* 1) Find "Syntax" or "Usage" sections, and count lines in these sections. */
/* 2) Find "Arguments" and "Control arguments" sections, and build lists of arguments. */
/* Count output lines in each list. */
/* 3) Output a header line, optionally given full pathname of physical info seg (-header) */
/* as well as number of lines in the brief output, total lines in the info, and */
/* count of (other) infos in this physical info seg. */
/* 4) Output the "Syntax" or "Usage" section. */
/* 5) Output the columnar lists of "Arguments" and "Control arguments". */
/* 6) Stop processing this physical info segment, and move on to the next specified */
/* by user (if any). */
/* */
/* When -control_arg is given, output description of all args/ctl_args whose name lines */
/* contain match for substring identifier(s) given as operands by the user. */
/* 1) Find "Argument" and "Control argument" name lines which contain one of the */
/* substrings given by the user after -control_arg. */
/* 2) Store those argument description lines in a list. */
/* 3) Print the argument description lines in the list after an appropriate heading. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
\014
if help_args.Sctl.bf |
help_args.Sctl.ca then do; /* Print argument descriptions when -ca given. */
Nlines = 1; /* Count lines to be output. */
/* Add 1 line for heading line. */
if help_args.Sctl.bf then do;
call get_brief_data (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
Plist_base, Dinfo_seg_.dir, Dinfo_seg_.ent, Nlast_info_no_brief_data,
Iinfo, Ninfos_printed, Iunit_syntax,
Nunit_syntax, Nlists_of_bf_args, Nlines);
if Nlines = 1 then go to RETURN;
end;
else do;
Nunit_syntax = 0;
Nlists_of_bf_args = 0;
if ^brief_data_ok (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
Dinfo_seg_.dir, Dinfo_seg_.ent, Iinfo, Ninfos_printed,
Nlast_info_no_brief_data) then go to RETURN;
end;
if help_args.Sctl.ca then do; /* Get control argument descriptions. */
Plist, Plist_of_cas = get_list (Plist_base);
list.N = help_args.Ncas; /* Begin by copying user-supplied arg names. */
list.arg = help_args.ca;
list.title = "-control_arg"; /* Get one list for each section with ctl args. */
call get_arg_descriptions (Plist_of_cas, PDlinfo, Plist_base,
Deps.linfo(Iep).S.old_format, Plists_of_args, Nlists_of_args);
do i = 1 to Nlists_of_args; /* Count output lines in each list. Lists are */
Plist = Plists_of_args(i); /* separated by 2 1 line, with 1 line for */
Nlines = Nlines + list.N + 2; /* title of section containing the args. */
end;
end;
if length(Deps.linfo(Iep).header) = 0 then Nlines = Nlines - 2;
/* No title? Remove its line count. */
if Ninfos > 1 then /* Suppress heading if only 1 info being printed. */
call print_header();
call print_brief_data (PDlinfo, Ninfos>1, Plist_base,
Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);
if help_args.Sctl.ca then do; /* Print ctl arg descriptions, section by sect. */
do j = 1 to Nlists_of_args;
Plist = Plists_of_args(j);
call ioa_ ("^[^/^]^a:", (j>1 | Ninfos>1 |
(help_args.Sctl.bf & help_args.Sctl.ca)), list.title);
do i = 1 to list.N;
call ioa_ ("^a", list.arg(i));
end;
end;
end;
go to RETURN; /* Stop when -brief or -control_arg given. */
end;
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* When -title is given, output a heading line and titles of paragraph sections. */
/* The heading line contains: */
/* 1) The full pathname of the info segment (if -header was given). */
/* 2) The primary title line from the info selected by the user. */
/* 3) The count of section title lines to be output. */
/* 4) Count of total lines in logical info segment. */
/* 5) Count of (other) infos in this physical info segment. */
/* Output a list of section titles in columnar form. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
PI_LABEL = QUERY; /* once printing starts, pi skips to next query. */
Iunit = 0; /* No pghs printed so far. */
if help_args.Sctl.title &
((Dlinfo.Nsections > 1) |
(Dlinfo.Nsections = 1 & ^Dlinfo.unit(1).S.scn))
then do; /* Print pgh titles when -title is given only if */
/* more than one title will be printed. */
if length(Deps.linfo(Iep).header) > 0 then
Nlines = 1;
else Nlines = -1;
Plist_of_titles = get_list (Plist_base);
call get_title_list (PDlinfo, Plist_of_titles, 0);
call format_list (Plist_of_titles, divide(Dlinfo.Nsections,7,17,0)+1, 1);
Nlines = Nlines + Plist_of_titles->list.Nrows + 1;
if help_args.Sctl.all then do;
Nlines = Nlines + Deps.linfo(Iep).Nlines + 2;
if length(Deps.linfo(Iep).header) > 0 then Nlines = Nlines - 2;
end;
call print_header();
call print_list(Plist_of_titles, Sprint_inhibit);
Pnext_free_space = Plist_of_titles;
list_base.N = list_base.N - 1; /* Free list of titles. */
if help_args.Sctl.all then do;
do Iunit = 1 to Dlinfo.Nunits;
call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
go to QUERY;
end;
end;
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* When -title not given, begin printing paragraphs. Normally start with first pgh. */
/* However, if -section is given, search for section whose title contains */
/* user-specified substrings. Print first pgh of this section if found. */
/* If -search is given, search for pgh containing user-specified substrings. */
/* Start with first matching pgh. If both -section and -search are given, position to */
/* matching section before searching more matching pgh. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
else do;
Iunit = 1; /* Start searching in first unit. */
new_section = "";
if ^help_args.Sctl.all &
^help_args.Sctl.title &
(help_args.Sctl.scn | /* Select pgh when -section given. */
help_args.Sctl.srh) then do; /* Select pgh when -search given. */
if help_args.Sctl.scn then do; /* Search all section titles for one containing */
match_result = find_section (PDlinfo, scn, Iunit);
if match_result = no_match then return;
end;
if help_args.Sctl.srh then do; /* Search subsequent pghs for one containing */
Ssearch = find_pgh (PDlinfo, srh, Iunit, new_section);
if ^Ssearch then return;
end;
end;
\014
if help_args.Sctl.all then do;
Nlines = Deps.linfo(Iep).Nlines;
Nprint_units = Dlinfo.Nunits;
end;
else do;
Nlines = Dlinfo.unit(Iunit).Nlines + 2; /* Add 2 for entry point heading. */
if length(Deps.linfo(Iep).header) = 0 then Nlines = Nlines - 2;
/* However, if no heading, subtract the 2 lines.*/
if new_section^="" & ^Dlinfo.unit(Iunit).S.scn then
Nlines = Nlines + 1; /* Add 1 line for section title of matched pgh. */
Nprint_units = 1; /* Print one pgh. If -section and -search were */
/* not given, print more pghs as well so long */
/* as total lines fewer than help_args.max_Lpgh */
/* and additional pghs shorter than min_Lpgh. */
if ^(help_args.Sctl.scn | help_args.Sctl.srh) then
do while (Iunit+Nprint_units <= Dlinfo.Nunits &
Dlinfo.unit(Iunit+Nprint_units).Nlines < help_args.min_Lpgh &
Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines <= help_args.max_Lpgh);
Nlines = Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines;
Nprint_units = Nprint_units + 1;
end;
end;
call print_header();
if new_section^="" & ^Dlinfo.unit(Iunit).S.scn then do;
call ioa_ ("^/^a:", new_section);
call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
else if ^help_args.Sctl.he_pn &
^help_args.Sctl.he_info_name &
^help_args.Sctl.he_counts &
length(Deps.linfo(Iep).header) = 0 then
call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
else call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
do Iunit = Iunit + 1 to Iunit + Nprint_units - 1;
call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
Iunit = Iunit - 1;
end;
\014
QUERY: Nconsecutive_bad_ops = 0; /* No errors in responses so far. */
Ssearch = FALSE; /* no searching for matching section/pgh underway.*/
Sloop = TRUE; /* Loop through all paragraphs of info. */
Iunit = Iunit + 1; /* Beginning with the next one. */
query_type = normal; /* Print normal section/pgh messages for now. */
do while (Sloop); /* Print remaining pghs under user control. */
PI_LABEL = ASK; /* Recompute query after most program_interrupt's.*/
if Iunit > Dlinfo.Nunits then /* Detect end_of_info and handle specially, but */
go to END_OF_INFO; /* still remain within do group. */
ASK: if query_type = normal |
query_type = some_unseen |
query_type = search_unseen then do;
Sseen = seen_pgh (Dlinfo.unit(Iunit)); /* Tell user in query if he's already seen pgh. */
Nlines = Dlinfo.unit(Iunit).Nlines;
Nprint_units = 1; /* Normally print one pgh at a time. */
if Dlinfo.unit(Iunit).S.scn | Iunit=1 then do;
/* However, if pgh begins a section and following */
if Iunit = 1 & ^Dlinfo.unit(1).S.scn then
query = "UNTITLED";
else query = Dlinfo.unit(Iunit).title;
/* pghs are shorter than min_Lpgh, print them */
do i = Iunit+Nprint_units by 1 /* as well, until max_Lpgh lines are aggregated. */
while (i <= Dlinfo.Nunits & /* When aggregating sections, include all */
^Ssearch & /* section titles in the query. */
Sseen = seen_pgh (Dlinfo.unit(i)) &
Dlinfo.unit(i).Nlines < help_args.min_Lpgh &
Dlinfo.unit(i).Nlines + 2 + Nlines <= help_args.max_Lpgh);
Nlines = Nlines + Dlinfo.unit(i).Nlines + 2;
/* Must skip 2 lines between pghs to keep line */
/* count of total info equal to count of all */
/* printed lines. */
if Dlinfo.unit(i).S.scn then do;
query = query || " & ";
if length (query) + length(Dlinfo.unit(i).title) + 12 > Loutput_line then
query = query || NL;/* 12 = length ( "(nnn lines)." ) */
query = query || Dlinfo.unit(i).title;
end;
Nprint_units = Nprint_units + 1;
end;
end;
else do; /* If pgh doesn't begin a section, we can only */
do i = Iunit+Nprint_units by 1 /* aggregate pghs in the current section. */
while (i <= Dlinfo.Nunits & /* Note that, here and above, if current pgh */
^Dlinfo.unit(i).S.scn & /* has already been seen, then can only aggregate */
^Ssearch & /* following pgh if it has been seen as well. */
Sseen = seen_pgh (Dlinfo.unit(i)) &
Dlinfo.unit(i).Nlines < help_args.min_Lpgh &
Dlinfo.unit(i).Nlines + 2 + Nlines <= help_args.max_Lpgh);
Nlines = Nlines + Dlinfo.unit(i).Nlines + 2;
Nprint_units = Nprint_units + 1;
end;
end;
end;
\014
else if query_type = new_entry then do;
Sseen = Deps.linfo(Iep).S.seen_by_user;
Nlines = Dlinfo.unit(Iunit).Nlines;
Nprint_units = 1;
do while (Iunit+Nprint_units <= Dlinfo.Nunits &
Dlinfo.unit(Iunit+Nprint_units).Nlines < help_args.min_Lpgh &
Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines <= help_args.max_Lpgh);
Nlines = Dlinfo.unit(Iunit+Nprint_units).Nlines + 2 + Nlines;
Nprint_units = Nprint_units + 1;
end;
if Nlines+2 < Deps.linfo(Iep).Nlines then
Lcount = length("Entry:(99 lines follow; 999 lines in entry point) More help?");
else Lcount = length("Entry:(999 lines in entry point) More help?");
Snl1 = (Lcount + 2 + length(Deps.linfo(Iep).header) + 3 > Loutput_line);
end;
RE_ASK: Ssearch = FALSE; /* searching for matching section/pgh is done. */
PI_LABEL = ASK; /* Routines branching here set PI_LABEL. Reset it.*/
Sprint_inhibit = FALSE;
if query_type = normal then
call command_query_ (addr(query_info), answer, procedure_name,
"^[^a (^d line^[s^]).^[^/^; ^]^2s^;^4s^d more line^[s^]. ^]^[Review^;More help^]?",
Dlinfo.unit(Iunit).S.scn, query, Nlines, Nlines > 1, (length(query)+24 > Loutput_line),
Nlines, Nlines > 1,
Sseen);
else if query_type = some_unseen then
call command_query_ (addr(query_info), answer, procedure_name,
"End of info. Some paragraphs unseen.^/^[^a^;In: ^a^] (^d line^[s^]).^[^/^; ^]More help?",
Dlinfo.unit(Iunit).S.scn, query,
Nlines, Nlines > 1,
length(query) + 30 > Loutput_line);
else if query_type = search_unseen then
call command_query_ (addr(query_info), answer, procedure_name,
"^[^[^a^;In: ^a^] (^d line^[s^])^;^2s^d more line^[s^]^].^[^/^; ^]More help?",
query ^= "", Dlinfo.unit(Iunit).S.scn, query,
Nlines, Nlines > 1,
length(query) + 30 > Loutput_line);
else if query_type = new_entry then
call command_query_ (addr(query_info), answer, procedure_name,
"Entry: ^a^[^/^; ^](^[^d lines follow; ^;^s^]^d lines in entry point). ^[Review^;More help^]?",
Deps.linfo(Iep).header,
Snl1,
(Nlines+2 < Deps.linfo(Iep).Nlines),
Nlines, Deps.linfo(Iep).Nlines-2,
Sseen);
PARSE: call parse_answer (answer, op, ep_name, ca, scn, srh);
if op = hbound(do,1) + 1 then do; /* Count consecutive errors user makes in answer. */
Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
go to ERROR;
end;
else Nconsecutive_bad_ops = 0;
go to do(op); /* Process request at user's beck and call. */
\014
YES:
do(1): Iunit_end = Iunit + Nprint_units - 1; /* yes */
PI_LABEL = YES_END; /* go to pgh user said, even if he pi's. */
call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
do Iunit = Iunit + 1 to Iunit + Nprint_units - 1;
call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
YES_END: Iunit = Iunit_end;
go to CONTINUE;
do(2): go to RETURN; /* no */
do(3): go to QUIT; /* quit */
do(4): Iunit = 0; /* top */
if length(Deps.linfo(Iep).header) > 0 then call ioa_ ("^a", Deps.linfo(Iep).header);
go to CONTINUE;
do(5): Nlines_titles = Dlinfo.unit(Iunit).Nlines; /* rest */
do Iunit_end = Iunit + 1 to Dlinfo.Nunits;
Nlines_titles = Nlines_titles + Dlinfo.unit(Iunit_end).Nlines + 2;
end;
Iunit_end = Iunit_end - 1;
REST: PI_LABEL = REST_END;
call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
do Iunit = Iunit + 1 to Iunit_end;
call print_pgh_2nl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
REST_END: Iunit = Iunit_end;
go to CONTINUE;
do(6): /* rest -scn */
Nlines_titles = Dlinfo.unit(Iunit).Nlines;
do Iunit_end = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit(Iunit_end).S.scn);
Nlines_titles = Nlines_titles + Dlinfo.unit(Iunit_end).Nlines + 2;
end;
Iunit_end = Iunit_end - 1;
go to REST;
do(7): go to CONTINUE; /* skip */
do(8): /* skip -scn */
do Iunit = Iunit + 1 to Dlinfo.Nunits while (^Dlinfo.unit(Iunit).S.scn);
end;
Iunit = Iunit - 1;
go to CONTINUE;
do(9): /* skip -ep */
do(10): /* skip -rest */
do Iunit = 1 to Dlinfo.Nunits while (^seen_pgh(Dlinfo.unit(Iunit)));
end; /* Has user seen any pgh of this entry? */
if Iunit > Dlinfo.Nunits then /* No. */
Sseen = FALSE;
else Sseen = TRUE; /* If so, by skip -ep, he's saying he's seen all */
go to CHECK_OTHER_ENTRIES; /* he wants to of this entry. */
\014
do(11): new_section = ""; /* skip -seen */
Sfound = FALSE;
do Iunit = Iunit+1 to Dlinfo.Nunits while(^Sfound);
if Dlinfo.unit(Iunit).S.scn then
new_section = Dlinfo.unit(Iunit).title;
Sfound = ^seen_pgh(Dlinfo.unit(Iunit));
end;
Iunit = Iunit - 1;
if Sfound then do;
query = new_section;
query_type = search_unseen;
go to ASK;
end;
else go to END_OF_INFO;
do(12): Iunit_search = Iunit - 1; /* title */
TITLE: PI_LABEL = RE_ASK;
Plist_of_titles = get_list (Plist_base);
call get_title_list (PDlinfo, Plist_of_titles, Iunit_search);
call format_list (Plist_of_titles, divide (Plist_of_titles->list.N, 7, 17, 0)+1, 1);
Nlines_titles = Plist_of_titles->list.Nrows;
call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
call print_list (Plist_of_titles, Sprint_inhibit);
Pnext_free_space = Plist_of_titles;
list_base.N = list_base.N - 1;
go to RE_ASK;
do(13): Iunit_search = 0; /* title -top */
go to TITLE;
\014
do(14): /* entry_point {ep_name} */
if ref_name = "" then
if suffix = "" then
ref_name = rtrim(Dinfo_seg_.ent);
else ref_name = substr(Dinfo_seg_.ent, 1, 32 - length(suffix) -
index(reverse(Dinfo_seg_.ent), reverse(suffix) || "."));
if ep_name = "" then /* Look for main entry point (eg, ioa_$ioa_) */
ep_name = ref_name;
else do;
i = index(ep_name, "$"); /* Look for hcs_$initiate rather than initiate */
if i > 1 then do; /* Validate given reference name. */
if substr(ep_name,1,i-1) ^= ref_name then do;
call ioa_ ("Reference name ^a invalid. Entry point names must be of the form:
^a$ENTRY_POINT_NAME
or just: ENTRY_POINT_NAME", substr(ep_name,1,i-1), ref_name);
Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
go to ERROR;
end;
end;
if i > 0 then
if i < length(ep_name) then
ep_name = substr(ep_name,i+1);
else ep_name = ref_name;
end;
Sfound = FALSE; /* Find the requested entry point. */
do i = 1 to Deps.N while (^Sfound);
do j = 1 to Deps.linfo(i).Nep_names while (^Sfound);
if ep_name = Deps.linfo(i).ep_name(j) then
Sfound = TRUE;
end;
end;
if Sfound then do;
Deps.linfo(Iep).S.seen_by_user = TRUE; /* user has seen all he wants of this entry point.*/
Iep = i - 1;
PDlinfo = Deps.linfo(Iep).PDlinfo;
Iunit = 1;
query_type = new_entry;
go to ASK;
end;
else do;
call ioa_ ("Entry point ^a$^a not found.", ref_name, ep_name);
go to RE_ASK;
end;
\014
do(15): Iunit_search = Iunit; /* section */
SECTION: if scn.N = 0 then do;
call ioa_$nnl ("No search strings given for section request. ");
Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
go to ERROR;
end;
match_result = find_section (PDlinfo, scn, Iunit_search);
if match_result = exact_match then do;
Iunit = Iunit_search;
Nprint_units = 1;
call ioa_ ("(^d ^[lines follow^;line follows^])",
Dlinfo.unit(Iunit).Nlines, Dlinfo.unit(Iunit).Nlines > 1);
go to YES;
end;
else if match_result = match then do;
Iunit = Iunit_search; /* When found, don't aggregate paragraphs. */
Ssearch = TRUE;
query_type = normal;
go to ASK;
end;
else do; /* Search failed? Paragraphs can be aggregated */
call ioa_ ("No matching section found.");
go to RE_ASK; /* based upon user's next response. */
end;
do(16): Iunit_search = 1; /* section -top */
go to SECTION;
do(17): Iunit_search = Iunit; /* search */
SEARCH: if srh.N = 0 then do;
call ioa_$nnl ("No search strings given for search request. ");
Nconsecutive_bad_ops = Nconsecutive_bad_ops + 1;
go to ERROR;
end;
Ssearch = find_pgh (PDlinfo, srh, Iunit_search, new_section);
if Ssearch then do; /* Found matching pgh? Print it. */
Iunit = Iunit_search;
Ssearch = FALSE;
Nlines = Dlinfo.unit(Iunit).Nlines;
if new_section^= "" & ^Dlinfo.unit(Iunit).S.scn then do;
Nlines = Nlines + 1;
call ioa_ ("(^d lines follow)^2/^a:", Nlines, new_section);
call print_pgh_nnl (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
else do;
call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines, Nlines>1);
call print_pgh (Dlinfo.unit(Iunit), Sprint_inhibit);
end;
go to CONTINUE;
end;
else do;
call ioa_ ("No matching paragraph found.");
go to RE_ASK;
end;
do(18): Iunit_search = 1; /* search -top */
go to SEARCH;
\014
do(19): Nlines_titles = -1; /* brief */
call get_brief_data (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
Plist_base, Dinfo_seg_.dir, Dinfo_seg_.ent, Nlast_info_no_brief_data,
Iinfo, Ninfos_printed, Iunit_syntax,
Nunit_syntax, Nlists_of_bf_args, Nlines_titles);
Nlists_of_bf_args = list_base.N;
if Nlines_titles > 0 then do;
call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
call print_brief_data (PDlinfo, TRUE, Plist_base,
Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);
end;
go to RE_ASK;
do(20): Nlines_titles = -1; /* control_arg */
if ^brief_data_ok (Deps.linfo(Iep).S.old_format, help_args.Sctl.he_pn, PDlinfo,
Dinfo_seg_.dir, Dinfo_seg_.ent, Iinfo, Ninfos_printed,
Nlast_info_no_brief_data) then;
else do;
ca.title = "control_arg";
call get_arg_descriptions (addr(ca), PDlinfo, Plist_base,
Deps.linfo(Iep).S.old_format, Plists_of_args, Nlists_of_args);
if Nlists_of_args > 0 then do;
do i = 1 to Nlists_of_args;
Plist = Plists_of_args(i);
Nlines_titles = Nlines_titles + list.N + 2;
end;
call ioa_ ("(^d ^[lines follow^;line follows^])", Nlines_titles, Nlines_titles>1);
do j = 1 to Nlists_of_args;
Plist = Plists_of_args(j);
call ioa_ ("^/^a:", list.title);
do i = 1 to list.N;
call ioa_ ("^a", list.arg(i));
end;
end;
Pnext_free_space = Plists_of_args(1);
list_base.N = 0;
end;
else call ioa_ ("No matching control arguments.");
end;
go to RE_ASK;
do(21): call ioa_("^a", procedure_name); /* . (= print name of caller) */
go to RE_ASK;
do(22): if query_answers.Nrows = 0 then /* ? (= list responses) */
call format_list(addr(query_answers), 5, 1);
call print_list (addr(query_answers), Sprint_inhibit);
go to RE_ASK;
do(23): call print_header_only(); /* header */
go to RE_ASK;
\014
ERROR:
if Nconsecutive_bad_ops = 1 then do; /* For first error, omit acceptable response */
/* list, and just print mini query. */
call command_query_ (addr(query_info), answer, procedure_name,
"^d ^[lines follow^;line follows^]. ^[Review^;More help^]?", Nlines, Nlines>1, Sseen);
go to PARSE;
end;
call ioa_("^/Type ? for a list of allowed responses.");
/* But if user errs more than once for given query*/
/* tell user how to print responses */
if Nconsecutive_bad_ops > 2 then go to RE_ASK;
/* If more than 2 consecutive errors, the user */
/* may have forgotten original question. */
/* Repeat it in its entirety. */
else
call command_query_ (addr(query_info), answer, procedure_name,
"^d ^[lines follow^;line follows^]. ^[Review^;More help^]?", Nlines, Nlines>1, Sseen);
go to PARSE;
\014
END_OF_INFO: Sseen = TRUE; /* Examine all pghs looking for unseen pgh. */
new_section = "UNTITLED"; /* Remember section titles as we examine them. */
do Iunit = 1 to Dlinfo.Nunits while (Sseen);
if Dlinfo.unit(Iunit).S.scn then
new_section = Dlinfo.unit(Iunit).title;
Sseen = seen_pgh (Dlinfo.unit(Iunit));
end; /* Look for unseen paragraphs. */
if ^Sseen then do; /* Some were found? */
Iunit = Iunit - 1; /* do group always increments 1 too many. */
query = new_section;
query_type = some_unseen;
go to ASK;
end;
Sseen = TRUE; /* This entry point has been seen. */
CHECK_OTHER_ENTRIES:
if Deps.N = 0 then go to RETURN; /* Only 1 part in log info? We're done. */
else do; /* Many entry points. */
Deps.linfo(Iep).S.seen_by_user = Sseen; /* Mark whether or not we've seen this entry. */
do i = Iep+1 to Deps.N while (Deps.linfo(i).S.seen_by_user |
help_args.min_date_time ^< Deps.linfo(i).date);
end; /* Look for unseen entries. */
if i > Deps.N then do; /* All entries seen? */
do i = 1 to Iep-1 while (Deps.linfo(i).S.seen_by_user |
help_args.min_date_time ^< Deps.linfo(i).date);
end;
if Deps.linfo(i).S.seen_by_user |
help_args.min_date_time ^< Deps.linfo(i).date then
go to RETURN;
end;
Iep = i; /* ith one is unseen. */
PDlinfo = Deps.linfo(Iep).PDlinfo; /* access its paragraph descriptors. */
Iunit = 1;
if help_args.Sctl.all then do;
Lcount = length("Entry:(999 lines in entry point)");
Snl1 = (Lcount + 2 + length(Deps.linfo(Iep).header) + 3 > Loutput_line);
call ioa_ ("^v/Entry: ^a^[^/^; ^](^d lines in entry point)",
help_args.Lspace_between_infos, Deps.linfo(Iep).header, Snl1, Deps.linfo(Iep).Nlines-2);
Nprint_units = Dlinfo.Nunits;
go to YES;
end;
query_type = new_entry;
go to ASK;
end;
CONTINUE: Iunit = Iunit + 1; /* Must implement looping ourselves because */
Sloop = (Iunit <= Dlinfo.Nunits+1); /* Dlinfo.Nunits will change when we switch to a */
query_type = normal; /* new entry point. Loop would be: */
end; /* do Iunit = Iunit+1 to Dlinfo.Nunits; */
RETURN: PI_LABEL = NEXT_INFO;
return;
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
find_pgh: procedure (PDlinfo_, Srh, Iunit, new_section) returns (bit(1) aligned);
dcl PDlinfo_ ptr; /* ptr to descriptors for this log info seg. */
dcl 1 Dlinfo_ aligned based(PDlinfo_),
2 Nunits fixed bin, /* number of units (pghs) in this log info seg. */
2 Nsections fixed bin, /* number of units having section title. */
2 unit (0 refer (Dlinfo_.Nunits))
like Dlinfo.unit;
dcl 1 Srh aligned, /* Paragraph search args. */
2 header like LIST.header,
2 group (100) like LIST.group;
dcl Iunit fixed bin; /* Pgh to start searching (Input) */
dcl new_section char(88) varying; /* Title of new section in which pgh occurs. */
/* Pgh found. (Output) */
dcl srh (Srh.N) char(88) varying; /* translated paragraph search args. */
dcl Ssearch bit(1) aligned;
dcl (i, j) fixed bin;
dcl PPgh ptr,
LPgh fixed bin,
Pgh char(LPgh) based(PPgh);
j = 0; /* Find length of longest pgh we will examine */
if Srh.N = 0 then return(FALSE); /* If nothing to search for, forget it. */
do i = Iunit to Dlinfo_.Nunits; /* so we can create temp storage into which */
j = max(j, Dlinfo_.unit(i).L); /* each pgh can be translated into lowercase. */
end;
BLOCK: begin;
dcl pgh char(j) varying;
do i = 1 to Srh.N; /* translate search args to lower case. */
srh(i) = translate(Srh.arg(i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
end;
Ssearch = FALSE; /* Search until matching section title found */
new_section = "";
do Iunit = Iunit to Dlinfo_.Nunits while(^Ssearch);
if Dlinfo_.unit(Iunit).S.scn then
new_section = Dlinfo_.unit(Iunit).title;
PPgh = Dlinfo_.unit(Iunit).Pstart;
LPgh = Dlinfo_.unit(Iunit).L;
pgh = translate (Pgh, "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
/* translate pgh to lower case. */
Ssearch = TRUE; /* Assume title matches until proven otherwise. */
do i = 1 to dimension(srh, 1) while(Ssearch);
if index(pgh, srh(i)) = 0 then
Ssearch = FALSE;
end;
end;
if Ssearch then /* Match found? */
Iunit = Iunit - 1; /* do-group always increments one too many. */
return (Ssearch);
end BLOCK;
end find_pgh;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
find_section: procedure (PDlinfo_, Scn, Iunit) returns (fixed bin);
dcl PDlinfo_ ptr; /* ptr to descriptors for this log info seg. */
dcl 1 Dlinfo_ aligned based(PDlinfo_),
2 Nunits fixed bin, /* number of units (pghs) in this log info seg. */
2 Nsections fixed bin, /* number of units having section title. */
2 unit (0 refer (Dlinfo_.Nunits))
like Dlinfo.unit;
dcl 1 Scn aligned, /* Section title search args. */
2 header like LIST.header,
2 group (100) like LIST.group;
dcl Iunit fixed bin; /* Pgh to start searching (Input) */
/* Pgh found. (Output) */
dcl scn (Scn.N) char(88) varying; /* translated section title search args. */
dcl Ssearch bit(1) aligned;
dcl i fixed bin;
dcl result fixed bin;
dcl temp char(88) varying;
dcl title char(88) varying;
if Scn.N = 0 then return(no_match); /* if nothing to search for, forget it. */
do i = 1 to Scn.N; /* translate search args to lower case. */
scn(i) = translate(Scn.arg(i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
end;
Ssearch = FALSE; /* Search until matching section title found */
do Iunit = Iunit to Dlinfo_.Nunits while(^Ssearch);
if Dlinfo_.unit(Iunit).S.scn then do;
title = translate (Dlinfo_.unit(Iunit).title, "abcdefghijklmnopqrstuvwxyz",
"ABCDEFGHIJKLMNOPQRSTUVWXYZ");
/* translate title to lower case. */
Ssearch = TRUE; /* Assume title matches until proven otherwise. */
do i = 1 to dimension(scn, 1) while(Ssearch);
if index(title, scn(i)) = 0 then
Ssearch = FALSE;
end;
end;
end;
if Ssearch then do; /* Match found? */
Iunit = Iunit - 1; /* do-group always increments one too many. */
temp = scn(1);
do i = 2 to Scn.N;
temp = temp || " ";
temp = temp || scn(i);
end;
if temp = title then /* check for exact match (except for letter case).*/
result = exact_match;
else result = match;
end;
else result = no_match;
return (result);
end find_section;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
format_list: procedure (Plist, Mcols, Mpghs); /* This procedure formats a list of values. */
dcl Plist ptr, /* ptr to argument list to be printed. */
Mcols fixed bin, /* maximum number of columns to be used in format.*/
Mpghs fixed bin, /* maximum pghs to be used. 0 means no limit. */
Sprint_inhibit bit(1) aligned; /* on if printing suppressed by pi. */
dcl (Icol, Ipgh, Irow) fixed bin,
Pspaces ptr,
Lspaces fixed bin,
Pmatrix ptr,
Sdoes_not_fit bit(1) aligned,
i fixed bin,
line char(MAX_HELP_LINE_SIZE) varying,
spaces char(Lspaces) based(Pspaces);
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
dcl 1 matrix (list.Npghs, list.Ncols, list.Nrows)
aligned based(Pmatrix) like LIST.group;
dcl 1 event_info aligned,
2 ev_chan fixed bin(71),
2 message fixed bin(71),
2 sender bit(36),
2 origin,
3 dev_signal bit(18) unal,
3 ring bit(18) unal,
2 chan_index fixed bin;
dcl 1 wait_list aligned int static,
2 N fixed bin,
2 ev_chan (1) fixed bin(71);
dcl 1 write_status aligned int static,
2 ev_chan fixed bin(71) init(0),
2 output_pending bit(1);
\014
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Format the arguments in as many columns as possible to reduce the output lines. */
/* However, if the output fits in 2 or more rows, the number of rows is chosen so that */
/* all columns but the final one are full. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
Pmatrix = addr(list.group); /* overlay arg list with 3-D matrix. */
Sdoes_not_fit = TRUE; /* Find proper number of columns to put output in.*/
if Mcols < 1 then /* Allow caller to limit number of columns. */
list.Ncols = dimension(list.ML,1);
else list.Ncols = min(Mcols, dimension(list.ML,1));
do list.Ncols = list.Ncols to 1 by -1 while (Sdoes_not_fit);
list.Nrows = divide (list.N + list.Ncols-1, list.Ncols, 17, 0);
/* Compute how many rows are required to display */
/* the args in list.Ncols columns. */
if Mpghs = 1 then /* compute how many paragraphs are needed. */
list.Npghs = 1;
else do;
list.Npghs = divide (list.Nrows+help_args.max_Lpgh-2, help_args.max_Lpgh-1, 17, 0);
list.Nrows = divide (list.Nrows+list.Npghs-1, list.Npghs, 17, 0);
end;
/* Make sure that the output matrix is balanced, */
/* and that only the last column is not full. */
if (list.Npghs>1) | (list.Nrows*list.Ncols - list.N < list.Nrows) then do;
list.Nreal = list.N; /* Make life easier by creating enough empty args */
/* to fill out a square matrix. */
list.N = list.Ncols * list.Nrows * list.Npghs;
do i = list.Nreal+1 to list.N;
list.arg(i) = "";
end;
list.ML(*) = 0; /* Find longest arg in each column. */
do Icol = 1 to list.Ncols;
do Ipgh = 1 to list.Npghs;
do Irow = 1 to list.Nrows;
list.ML(Icol) = max(list.ML(Icol), length(matrix.arg(Ipgh, Icol, Irow)));
end;
end;
end;
if sum(list.ML) + (list.Ncols-1)*3 > Loutput_line then
/* See if all rows will fit on a line. */
/* Leave 2 spaces between columns. */
list.N = list.Nreal;
else Sdoes_not_fit = FALSE;
end;
end;
list.Ncols = list.Ncols + 1; /* do-group decrements one too many. */
return;
\014
print_list_nnl: entry (Plist, Sprint_inhibit);
if Sprint_inhibit then return;
Pmatrix = addr(list.group);
Pspaces = addr(SPACES);
if length(list.title) > 0 then
call ioa_ ("^a:", list.title);
go to PRINT_LIST;
print_list: entry (Plist, Sprint_inhibit); /* This entry point prints a list and its title. */
if Sprint_inhibit then return;
Pmatrix = addr(list.group); /* overlay arg list with 3-D matrix. */
Pspaces = addr(SPACES);
if length(list.title) > 0 then
call ioa_ ("^/^a:", list.title);
else call iox_$put_chars(iox_$user_output, addr(NL), length(NL), 0);
PRINT_LIST:
do Ipgh = 1 to list.Npghs; /* Output paragraphs, one at a time. */
do Irow = 1 to list.Nrows; /* Output rows, one at a time. */
line = "";
do Icol = 1 to list.Ncols;
line = line || matrix.arg (Ipgh, Icol, Irow);
Lspaces = list.ML(Icol) - length(matrix.arg(Ipgh, Icol, Irow)) + 3;
line = line || spaces;
end;
call ioa_ ("^a", line);
end;
end;
return;
\014
output_list: entry (Plist, Apgh, Poutput, Loutput, Nlines);/* output 1 pgh of multipgh list into a string. */
dcl Apgh fixed bin, /* Number of pgh to output. */
Poutput ptr, /* ptr to output string. */
Loutput fixed bin, /* length of output string. */
output char(Loutput) based(Poutput),
Nlines fixed bin; /* Lines in the output. */
Nlines = 0;
Loutput = 0;
Pmatrix = addr(list.group);
Pspaces = addr(SPACES);
Ipgh = Apgh;
if Ipgh = 1 then /* Output NL which would follow section title */
if length (list.title) > 0 then do; /* in a regular (non-made-up) section. */
call out (NL);
Nlines = Nlines + 1;
end;
do Irow = 1 to list.Nrows;
do Icol = 1 to list.Ncols;
call outv (matrix.arg (Ipgh, Icol, Irow));
Lspaces = list.ML(Icol) - length(matrix.arg(Ipgh, Icol, Irow)) + 3;
call out(spaces);
end;
call out (NL);
Nlines = Nlines + 1;
end;
return;
\014
out: proc (str);
dcl str char(*);
Loutput = Loutput + length(str);
substr (output, Loutput-length(str)+1, length(str)) = str;
end out;
outv: proc (str);
dcl str char(*) var;
Loutput = Loutput + length(str);
substr (output, Loutput-length(str)+1, length(str)) = str;
end outv;
end format_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_arg_descriptions: procedure (Plist_cas, PDlinfo_, Plist_base,
Sreally_old_format, Plists_of_args, Nlists_of_args);
/* This procedure builds a list of argument */
/* descriptions which match user-given arg names. */
dcl (Plist_cas, PDlinfo_, Plist_base)
ptr,
Sreally_old_format bit(1),
Plists_of_args (*) ptr,
Nlists_of_args fixed bin;
dcl 1 list_cas aligned based(Plist_cas),
2 header like LIST.header,
2 group (0 refer (list_cas.N))
like LIST.group;
dcl 1 Dlinfo_ aligned based (PDlinfo_),
/* structure defining all paragraphs (units) in */
/* an entry point (logical info seg - linfo). */
2 Nunits fixed bin, /* number of units in this ep. */
2 Nsections fixed bin, /* number of units beginning a section. */
2 unit (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;
dcl 1 list_base aligned based(Plist_base),
/* struc locating lists of things to be output. */
2 N fixed bin, /* number of output lists now allocated. */
2 Nmax fixed bin, /* max number of list ptrs allocatable. */
2 Ispace_used_set fixed bin, /* index of last list on which space used set. */
2 Plists (0 refer(list_base.Nmax))
ptr; /* ptrs to allocated lists. */
/* unit (paragraph) descriptors. */
dcl 1 list_args aligned based(Plist_args),
2 header like LIST.header,
2 group (0 refer (list_args.N))
like LIST.group;
dcl Plist_args ptr,
Ppgh ptr,
Lpgh fixed bin,
Largs fixed bin,
args char(Largs) based(Ppgh),
pgh char(Lpgh) based (Ppgh),
pgh_char (Lpgh) char(1) based(Ppgh);
dcl Iunit fixed bin,
DO_LINE label local,
Sconsecutive_arg_lines bit(1) aligned,
Sold_format bit(1) aligned,
(i, j, k, l) fixed bin;
\014
Nlists_of_args = 0;
list_cas.Snot_found(*) = 1;
do Iunit = 1 to Dlinfo_.Nunits;
if Dlinfo_.unit(Iunit).S.arg_list then do;
if Dlinfo_.unit(Iunit).S.scn then do;
if Nlists_of_args > 0 then
if list_args.N = 0 then
list_args.title = Dlinfo_.unit(Iunit).title;
else go to NEXT_LIST;
else do;
NEXT_LIST: if Nlists_of_args >= dimension(Plists_of_args,1) then;
else do;
Nlists_of_args = Nlists_of_args + 1;
Plist_args, Plists_of_args(Nlists_of_args) = get_list (Plist_base);
list_args.title = Dlinfo_.unit(Iunit).title;
end;
end;
end;
Ppgh = Dlinfo_.unit(Iunit).Pstart;
Lpgh = Dlinfo_.unit(Iunit).L;
i = index(pgh, "
"); /* Old format if some pgh lines don't begin w/ SP*/
if i = 0 then
Sold_format = TRUE;
else Sold_format = Sreally_old_format;
DO_LINE = SKIP_LINE;
do while (Lpgh > 0); /* Search pgh for arguments. */
i = index(pgh, NL); /* skip blank lines & lines starting with HT SP. */
if i > 0 then
j = verify(substr(pgh,1,i), "
");
if ((i > 0) & (j = 0)) | (index (" ", pgh_char(1)) > 0) then do;
Sconsecutive_arg_lines = FALSE;
end;
else if Sold_format then do; /* Add arg to list iff it is a control_arg. */
if pgh_char(1) ^= "-" then go to DO_LINE;
if i = 0 then i = Lpgh; /* arg name line must begin with - */
Largs = index(substr(pgh,1,i), " ");
k = index(substr(pgh,1,i), " ");
if (Largs^=0) & (k^=0) then
Largs = min(Largs, k);
/* arg name ends when first double SP is found, */
if Largs = 0 then do; /* or with first HT or SP char. */
Largs = search(substr(pgh,1,i), " ");
if Largs = 0 then do; /* No SP/HT in line? Forget it. */
DO_LINE = SKIP_LINE;
go to SKIP_LINE;
end;
k = index(substr(pgh,1,i), ",");
if k = 0 then; /* Does line contain a comma? */
else if k = Largs-1 then
Largs = Largs + search(substr(pgh,Largs+1, i-Largs)," ");
/* Yes, look for "-long, -lg " */
else do; /* Yes, look for "-pathname path, -pn path " */
l = Largs + search(substr(pgh,Largs+1,i-Largs), " ");
if l ^= Largs & k = l-1 then do;
k = l + search(substr(pgh,l+1,i-l)," ");
if k ^= l then do;
l = k + search(substr(pgh,k+1,i-k)," ");
if l ^= k then Largs = l;
end;
end;
end;
end;
do k = 1 to list_cas.N while (index(args, list_cas.arg(k))=0);
end;
if k <= list_cas.N then do;
list_cas.Snot_found(k) = 0;
DO_LINE = KEEP_LINE;
end;
else DO_LINE = SKIP_LINE;
end;
else do; /* arg name is entire line. */
if i = 0 then i = Lpgh;
k = index(pgh, " ");
if k ^= 0 then if k < i then
Largs = k-1;
else Largs = i-1;
if substr(args, Largs, 1) = "," & i<Lpgh then
Largs = Largs + index(substr(pgh,i+1, Lpgh-i), NL);
/* If arg name line ends with , then assume it */
/* it is continued on next line. */
do k = 1 to list_cas.N while (index(args,list_cas.arg(k))=0);
end;
if k <= list_cas.N then do;
list_cas.Snot_found(k) = 0;
DO_LINE = KEEP_LINE;
Largs = length(rtrim(args, "
"));
end;
else DO_LINE = SKIP_LINE;
end;
go to DO_LINE;
KEEP_LINE: list_args.N = list_args.N + 1;
if i = 0 then Largs = Lpgh;
else Largs = i - 1;
list_args.arg(list_args.N) = args;
SKIP_LINE: if i = 0 then Lpgh = 0;
else if i = Lpgh then Lpgh = 0;
else do;
Ppgh = addr(pgh_char(i+1));
Lpgh = Lpgh - i;
end;
END_LOOP: end;
end;
end;
if Nlists_of_args > 0 then /* May have unused list. If so, free it. */
if list_args.N = 0 then do;
list_base.N = list_base.N - 1;
Nlists_of_args = Nlists_of_args - 1;
end;
if sum(list_cas.Snot_found) > 0 then do; /* Any control arg names given by user unmatched? */
if Nlists_of_args = 0 then do;
Nlists_of_args = Nlists_of_args + 1;
Plist_args, Plists_of_args(Nlists_of_args) = get_list (Plist_base);
list_args.title = "NO MATCH FOR " || list_cas.title || " STRINGS";
end;
else do;
list_args.N = list_args.N + 1;
list_args.arg(list_args.N) = "";
list_args.N = list_args.N + 1;
list_args.arg(list_args.N) = "NO MATCH FOR " || list_cas.title || " STRINGS:";
end;
do k = 1 to list_cas.N;
if list_cas.Snot_found(k) > 0 then do;
list_args.N = list_args.N + 1;
list_args.arg(list_args.N) = " ";
list_args.arg(list_args.N) =
list_args.arg(list_args.N) || list_cas.arg(k);
end;
end;
end;
end get_arg_descriptions;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_arg_list: procedure (unit, Plist, Sreally_old_format); /* This procedure builds a list of arguments. */
dcl 1 unit aligned like Dlinfo.unit,
Plist ptr, /* ptr to space for arg list. */
Sreally_old_format bit(1); /* on if info segs contains \006 chars. */
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
dcl Ppgh ptr,
Lpgh fixed bin,
Sconsecutive_arg_lines bit(1) aligned, /* on if info seg is in new format, and if */
/* previous line of pgh was arg line ending with */
/* a comma. */
Sold_format bit(1) aligned, /* on if info seg is old or really old. */
(i, j, k, l) fixed bin,
pgh char(Lpgh) based (Ppgh),
pgh_char (Lpgh) char(1) based(Ppgh);
Ppgh = unit.Pstart; /* address the paragraph. */
Lpgh = unit.L;
i = index (pgh, "
"); if i = 0 then /* Check for old format info segs. */
Sold_format = TRUE;
else Sold_format = Sreally_old_format;
do while (Lpgh > 0); /* search pgh for arguments. */
i = index(pgh, NL); /* skip blank lines. */
if i > 0 then
j = verify(substr(pgh,1,i), "
");
if ((i > 0) & (j = 0)) | (index (" ", pgh_char(1)) > 0) then do;
/* skip line beginning with SP or HT. */
Sconsecutive_arg_lines = FALSE;
SKIP_LINE: if i = 0 then Lpgh = 0;
else if i = Lpgh then Lpgh = 0;
else do;
Ppgh = addr(pgh_char(i+1));
Lpgh = Lpgh - i;
end;
end;
else if Sold_format then do; /* add arg to list if it is control arg. */
if pgh_char(1) ^= "-" then go to SKIP_LINE;
if i = 0 then i = Lpgh; /* arg name line must begin with - */
j = index(substr(pgh,1,i), " "); /* arg name ends when first double SP is found, */
k = index(substr(pgh,1,i), " "); /* or with first HT char. */
if (j^=0) & (k^=0) then
j = min(j,k);
if j = 0 then do; /* If no double SP, ends with first SP char. */
j = search(substr(pgh,1,i), " ");
if j = 0 then /* If no SP or HT, forget it. */
go to SKIP_LINE;
k = index(substr(pgh,1,i), ","); /* Does comma immediately precede SP/HT? */
if k = 0 then; /* No. We've found arg. */
else if k = j-1 then /* Yes, look for "-long, -lg " */
j = j + search(substr(pgh,j+1, i-j), " ");
else do; /* Comma found in line. */
l = j + search(substr(pgh,j+1,i-j), " ");
if l ^= j & k = l-1 then do;
k = l + search(substr(pgh,l+1,i-l)," ");
if k ^= l then do; /* Look for "-pathname path, -pn path ". */
l = k + search(substr(pgh,k+1,i-k)," ");
if l ^= k then j = l;
end;
end;
end;
end;
list.N = list.N + 1;
list.arg(list.N) = " ";
list.arg(list.N) = list.arg(list.N) || substr(pgh,1,j-1);
if length(list.arg(list.N)) > 18 then do;
k =index(list.arg(list.N), ",");
if k > 0 then do;
list.N = list.N + 1;
list.arg(list.N) = " ";
k = k + 1;
k = (k-1) + verify(substr(list.arg(list.N-1),k), " ");
list.arg(list.N) = list.arg(list.N) || substr(list.arg(list.N-1),k);
list.arg(list.N-1) = rtrim(substr(list.arg(list.N-1),1,k-1));
end;
end;
go to SKIP_LINE;
end;
else do; /* add arg line to list. */
if i = 0 then i = Lpgh;
k = index(pgh, " ");
if k ^= 0 then if k < i then i = k-1;
j, list.N = list.N + 1; /* arg is everything on the line. */
if Sconsecutive_arg_lines then
list.arg(j) = " ";
else list.arg(j) = " ";
list.arg(j) = list.arg(j) || rtrim(substr (pgh, 1, i), "
");
if substr(list.arg(j), length(list.arg(j)), 1) = "," then
Sconsecutive_arg_lines = TRUE;
else if length(list.arg(j)) > 18 then do;
k =index(list.arg(j), ",");
if k > 0 then do;
j, list.N = list.N + 1;
list.arg(j) = " ";
k = k + 1;
k = (k-1) + verify(substr(list.arg(j-1),k), " ");
list.arg(j) = list.arg(j) || substr(list.arg(j-1),k);
list.arg(j-1) = rtrim(substr(list.arg(j-1),1,k-1));
end;
end;
go to SKIP_LINE;
end;
end;
end get_arg_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_brief_data: proc (Sold_format, Sheader, PDlinfo_, Plist_base, dir, ent, Nlast_info_no_brief_data,
Iinfo, Ninfos_printed, Iunit_syntax, Nunit_syntax, Nlists_of_bf_args, Nlines);
dcl Sold_format bit(1) unal, /* on if log info contains \006 chars. */
Sheader bit(1) unal, /* on if -header required. */
PDlinfo_ ptr, /* ptr to pgh descriptors of log info. */
Plist_base ptr, /* ptr to list of lists. */
dir char(168) unal, /* dir part of phys info seg's path. */
ent char(32) unal, /* ent part of phys info seg's path. */
Nlast_info_no_brief_data fixed bin, /* Last info processed not containing Syntax sect.*/
Iinfo fixed bin, /* number of the info seg being processed. */
Ninfos_printed fixed bin, /* number of infos for which something printed. */
Iunit_syntax (10) fixed bin, /* indices of Syntax sections. */
Nunit_syntax fixed bin, /* count of Syntax sections. */
Nlists_of_bf_args fixed bin, /* count of sections containing args/ctl_args. */
Nlines fixed bin;
dcl 1 Dlinfo_ aligned based(PDlinfo_),
2 Nunits fixed bin, /* number of units (pghs) in this log info seg. */
2 Nsections fixed bin, /* number of units having section title. */
2 unit (0 refer (Dlinfo_.Nunits))
like Dlinfo.unit;
dcl Iunit fixed bin,
Plist ptr,
Sfound bit(1) aligned,
(i, j) fixed bin;
dcl 1 list_base aligned based(Plist_base),
2 N fixed bin, /* number of lists in this list ptr structure. */
2 Nmax fixed bin, /* max possible number of lists in structure. */
2 Ispace_used_set fixed bin, /* index of last list on which space used was set.*/
2 Plists (0 refer (list_base.Nmax))
ptr; /* pointers to list structures. */
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
if Sold_format then /* Be sure "Syntax" section(s) exist. */
do Iunit = 1 to Dlinfo_.Nunits while (Dlinfo_.unit(Iunit).title ^= "Usage");
end;
else do Iunit = 1 to Dlinfo_.Nunits
while (substr(Dlinfo_.unit(Iunit).title, 1,
min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
end; /* Search for the "Syntax" section. */
if Iunit > Dlinfo_.Nunits then do; /* Tell user if not found. */
call ioa_ ("^[^v/^;^s^]No brief info available for ^[^a^[>^]^;^2s^]^a.",
((Ninfos_printed > 1) & help_args.Sctl.bf & (Nlast_info_no_brief_data ^= Iinfo-1)),
help_args.Lspace_between_infos,
Sheader, dir, dir^=">", ent);
Nlast_info_no_brief_data = Iinfo;
return;
end;
\014
do i = 1 to dimension(Iunit_syntax,1) while (Iunit <= Dlinfo_.Nunits);
Iunit_syntax(i) = Iunit; /* Find & record location of syntax sections. */
Nunit_syntax = i;
do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.scn);
Nlines = Nlines + Dlinfo_.unit(Iunit).Nlines + 1;
end; /* Count lines in each pgh of Syntax section. */
/* Add 1 line for blank line preceding each pgh. */
if ^Sold_format then
do Iunit = Iunit to Dlinfo_.Nunits
while (substr(Dlinfo_.unit(Iunit).title, 1,
min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
end;
else Iunit = Dlinfo_.Nunits + 1;
end;
Iunit = 1;
do while(Iunit <= Dlinfo_.Nunits); /* Search for "Arguments" & "Control arguments" */
/* paragraphs to summarize these arguments. */
do Iunit = Iunit to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.arg_list);
end; /* These units were flagged by */
if Iunit <= Dlinfo_.Nunits then do; /* parse_entry_point_into_units. */
Plist = get_list (Plist_base);
if Plist = null() then
Iunit = Dlinfo_.Nunits + 1;
else do;
list.title = Dlinfo_.unit(Iunit).title;
list.Iunit = Iunit;
if length(list.title) <= 17 then do;
list.N = 1;
list.arg(1) = list.title;
list.arg(1) = list.arg(1) || ":";
end; /* Put title on same line as arg names, unless */
/* title is too long. */
do Iunit = Iunit, Iunit + 1 to Dlinfo_.Nunits while (^Dlinfo_.unit(Iunit).S.scn);
call get_arg_list (Dlinfo_.unit(Iunit), Plist, Sold_format);
end;
if list.N > 0 & list.title = "Arguments" then do;
/* Suppress Arguments list if all arg names */
/* appear in Syntax section. */
if list.arg(1) = "Arguments:" then
i = 2;
else i = 1;
Sfound = TRUE;
do i = i to list.N while(Sfound);
do j = 1 to Nunit_syntax while(Sfound);
Ppgh = Dlinfo_.unit(Iunit_syntax(j)).Pstart;
Lpgh = Dlinfo_.unit(Iunit_syntax(j)).L;
if index (pgh, ltrim(rtrim(list.arg(i), ", "))) = 0 then
Sfound = FALSE;
end;
end;
if Sfound then list.N = 0;
end;
if list.N = 1 then
if list.title = substr(list.arg(1),1,length(list.arg(1))-1) then
list.N = 0;
\014
if list.N > 0 then do;
if list.title = substr(list.arg(1),1,length(list.arg(1))-1) then
list.title = "";
call format_list (Plist, 0, 1);
if list.Nrows < 3 then do;
do i = 2 by 1 while (i <=list.N);
if length(list.arg(i)) > 4 then
if substr(list.arg(i),1,4) = " " then do;
list.arg(i-1) = list.arg(i-1) || " ";
list.arg(i-1) = list.arg(i-1) || substr(list.arg(i),5);
do j = i+1 to list.N;
list.arg(j-1) = list.arg(j);
end;
list.N = list.N - 1;
end;
end;
call format_list (Plist, 0, 1);
end;
Nlines = Nlines + list.Nrows + 1;
if length(list.title) > 0 then
Nlines = Nlines + 1;
end;
else list_base.N = list_base.N - 1;
end;
end;
end;
Nlists_of_bf_args = list_base.N;
return;
print_brief_data: entry (PDlinfo_, Sheader, Plist_base, Iunit_syntax, Nunit_syntax, Nlists_of_bf_args);
j = 1; /* For -brief, print Syntax section and list of */
do i = 1 to Nunit_syntax; /* ctl args in order that their sections appear */
PRINT_NEXT_LIST: if j <= Nlists_of_bf_args then do; /* in the info. */
Plist = list_base.Plists(j); /* Print lists of args. */
if list.Iunit < Iunit_syntax(i) then do;
call print_list (Plist, FALSE);
j = j + 1;
go to PRINT_NEXT_LIST;
end;
end;
do Iunit = Iunit_syntax(i), Iunit+1 to Dlinfo_.Nunits while(^Dlinfo_.unit(Iunit).S.scn);
if j = 1 & Iunit = Iunit_syntax(1) & Ninfos=1 & ^Sheader then
call print_pgh_nnl (Dlinfo_.unit(Iunit), FALSE);
else call print_pgh (Dlinfo_.unit(Iunit), FALSE);
end; /* Print syntax sections. */
end;
do j = j to Nlists_of_bf_args; /* Print remaining lists of ctl args. */
call print_list (list_base.Plists(j), FALSE);
end;
if Nlists_of_bf_args > 0 then do;
Pnext_free_space = list_base.Plists(1);
list_base.N = 0;
end;
return;
\014
brief_data_ok: entry (Sold_format, Sheader, PDlinfo_, dir, ent, Iinfo, Ninfos_printed,
Nlast_info_no_brief_data) returns(bit(1) aligned);
if Sold_format then /* Be sure "Syntax" section(s) exist. */
do Iunit = 1 to Dlinfo_.Nunits while (Dlinfo_.unit(Iunit).title ^= "Usage");
end;
else do Iunit = 1 to Dlinfo_.Nunits
while (substr(Dlinfo_.unit(Iunit).title, 1,
min(6, length(Dlinfo_.unit(Iunit).title))) ^= "Syntax");
end; /* Search for the "Syntax" section. */
if Iunit > Dlinfo_.Nunits then do; /* Tell user if not found. */
call ioa_ ("^[^v/^;^s^]No control argument info available for ^[^a^[>^]^;^2s^]^a.",
((Ninfos_printed > 1) & help_args.Sctl.ca & (Nlast_info_no_brief_data ^= Iinfo-1)),
help_args.Lspace_between_infos,
Sheader, dir, dir^=">", ent);
Nlast_info_no_brief_data = Iinfo;
return (FALSE);
end;
return(TRUE);
end get_brief_data;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_ep_list: procedure (ref_name, PDeps_, Plist); /* Create list of entry points in this phys. seg. */
dcl ref_name char(32) varying,
(PDeps_, Plist) ptr;
dcl 1 Deps_ aligned based(PDeps_),
2 Nlines fixed bin,
2 N fixed bin,
2 linfo (0: 0 refer (Deps_.N)) like Deps.linfo;
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
dcl (i, j, k) fixed bin;
do i = 1 to Deps.N; /* Build list of all entry point info headers. */
k, list.N = list.N + 1;
if length(Deps_.linfo(i).header) > 0 then do;/* If header already exists, use it. */
list.arg(k) = Deps_.linfo(i).header;
if length(list.arg(k)) > 21 then do; /* Split a long heading into several lines. */
j = 20 + index (substr(list.arg(k),21), " ");
do while (j > 20);
k, list.N = list.N + 1;
list.arg(k) = " ";
j = j + verify(substr(list.arg(k),j), " ");
list.arg(k) = list.arg(k) || substr(list.arg(k-1), j);
list.arg(k-1) = rtrim(substr(list.arg(k-1),1,j-1));
if length(list.arg(k)) > 21 then
j = 20 + index(substr(list.arg(k),21), " ");
else j = 0;
end;
end;
end;
else do; /* If doesn't exist, make one up. */
list.arg(k) = ref_name;
list.arg(k) = list.arg(k) || "$";
list.arg(k) = list.arg(k) || Deps_.linfo(i).ep_name(1);
do j = 2 to Deps_.linfo(i).Nep_names;
list.arg(k) = list.arg(k) || ",";
k, list.N = list.N + 1;
list.arg(k) = " ";
list.arg(k) = list.arg(k) || ref_name;
list.arg(k) = list.arg(k) || "$";
list.arg(k) = list.arg(k) || Deps_.linfo(i).ep_name(j);
end;
Deps_.linfo(i).header = list.arg(k); /* Apply fruits of our labor by using header */
/* in entry point info as well. */
end;
end;
end get_ep_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_list: procedure (Plist_base) returns(ptr); /* This procedure allocates a new list in */
/* the help_args segment. */
dcl Plist_base ptr;
dcl 1 list_base aligned based(Plist_base),
2 N fixed bin, /* number of lists in this list ptr structure. */
2 Nmax fixed bin, /* max possible number of lists in structure. */
2 Ispace_used_set fixed bin, /* index of last list on which space used was set.*/
2 Plists (0 refer (list_base.Nmax))
ptr, /* pointers to list structures. */
Plist ptr,
1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
if list_base.N = dimension(list_base.Plists,1) then
return(null); /* list of lists full. Oops! */
if list_base.Ispace_used_set > list_base.N then
list_base.Ispace_used_set = 0;
if list_base.Ispace_used_set < list_base.N-1 then
return(null); /* someone forgot to set space used for a list */
/* other than the last in list of lists. */
if list_base.Ispace_used_set = list_base.N-1 then do;
Plist = list_base.Plists(list_base.N); /* set space used for last list. */
Pnext_free_space = set_space_used(Pnext_free_space, currentsize(list));
list_base.Ispace_used_set = list_base.N;
end;
list_base.N = list_base.N + 1; /* get new list. */
Plist = Pnext_free_space;
list_base.Plists(list_base.N) = Plist;
list.N = 0;
list.Nreal = 0;
list.title = "";
return(Plist);
end get_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_list_base: procedure (Pnext_free_space, space_used, Nmax) returns (ptr);
dcl Pnext_free_space ptr, /* ptr to next free word of space in temp seg. */
space_used fixed bin(21), /* number of words used at that free word loc. */
Nmax fixed bin, /* number of lists to maintain in list of lists. */
Plist_base ptr; /* ptr to creates list of lists. */
dcl 1 list_base aligned based(Plist_base),
2 N fixed bin, /* number of lists in this list ptr structure. */
2 Nmax fixed bin, /* max possible number of lists in structure. */
2 Ispace_used_set fixed bin, /* index of last list on which space used was set.*/
2 Plists (0 refer (list_base.Nmax))
ptr; /* pointers to list structures. */
if space_used ^= 0 then /* set space used by previous allocation. */
Pnext_free_space = set_space_used (Pnext_free_space, space_used);
Plist_base = Pnext_free_space; /* get list of lists. */
list_base.N = 0; /* No lists listed yet. */
list_base.Ispace_used_set = 0;
list_base.Nmax = Nmax;
if Nmax > 0 then /* Size known? Set space used. */
Pnext_free_space = set_space_used (Pnext_free_space, currentsize(list_base));
return(Plist_base);
end get_list_base;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
get_title_list: procedure (PDlinfo_, Plist, Iunit_start ); /* This entry builds a list of titles. */
dcl PDlinfo_ ptr,
Plist ptr,
Iunit_start fixed bin; /* Current unit number. Get title of following */
/* units. */
dcl Iunit fixed bin,
Nlines fixed bin,
Nlines_pic pic "zzzzz9",
(i, j, k) fixed bin;
dcl 1 Dlinfo_ aligned based (PDlinfo_),
/* structure defining all paragraphs (units) in */
/* an entry point (logical info seg - linfo). */
2 Nunits fixed bin, /* number of units in this ep. */
2 Nsections fixed bin, /* number of units beginning a section. */
2 unit (0 refer (Dlinfo_.Nunits)) like Dlinfo.unit;
/* unit (paragraph) descriptors. */
dcl 1 list aligned based(Plist),
2 header like LIST.header,
2 group (0 refer (list.N)) like LIST.group;
do Iunit = Iunit_start+1 to Dlinfo_.Nunits;
if Dlinfo_.unit(Iunit).S.scn | Iunit = 1 then do;
k, list.N = list.N + 1;
if Iunit = 1 & ^Dlinfo_.unit(1).S.scn then
list.arg(k) = "UNTITLED";
else list.arg(k) = Dlinfo_.unit(Iunit).title;
if length(list.arg(k)) > 21 then do; /* Split a long section title into several lines. */
j = 20 + index (substr(list.arg(k),21), " ");
do while (j > 20);
k, list.N = list.N + 1;
list.arg(k) = " ";
j = j + verify(substr(list.arg(k),j), " ");
list.arg(k) = list.arg(k) || substr(list.arg(k-1), j);
list.arg(k-1) = rtrim(substr(list.arg(k-1),1,j-1));
if length(list.arg(k)) > 21 then
j = 20 + index(substr(list.arg(k),21), " ");
else j = 0;
end;
end;
Nlines = Dlinfo_.unit(Iunit).Nlines; /* Count lines in section. */
do i = Iunit+1 to Dlinfo_.Nunits while(^Dlinfo_.unit(i).S.scn);
Nlines = Nlines + Dlinfo_.unit(i).Nlines + 2;
end;
Iunit = i - 1;
Nlines_pic = Nlines;
list.arg(k) = list.arg(k) || " (";
list.arg(k) = list.arg(k) || ltrim(Nlines_pic);
list.arg(k) = list.arg(k) || ")";
end;
end;
\014
if list.N = 0 then do;
list.N = 1;
list.arg(1) = "NO MORE TITLES";
end;
end get_title_list;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
parse_answer: proc (answer, op, ep_name, ca, scn, srh);
dcl answer char(500) varying,
op fixed bin, /* Operation specified by the answer. */
ep_name char(65) varying, /* Name of entry point given in ep request. */
1 ca aligned,
2 header like LIST.header,
2 group (100) like LIST.group,
1 scn aligned,
2 header like LIST.header,
2 group (100) like LIST.group,
1 srh aligned,
2 header like LIST.header,
2 group (100) like LIST.group;
dcl (i, j, k) fixed bin,
operation char(12) varying,
operand char(89) varying;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* The tables below define the following combinations of answers and control args. */
/* */
/* OP_CODE OPERATION OP_CODE OPERATION OP_CODE OPERATION */
/* 1 yes, y 7 skip, s 14 entry_point {STR} */
/* 2 no, n 8 skip -scn ep {STR} */
/* 3 quit, q 9 skip -ep 15 section {STRs} */
/* 4 top, t 10 skip -rest scn {STRs} */
/* 5 rest, r 11 skip -seen sc {STRs} --obsolete-- */
/* 6 rest -scn 12 title 16 section {STRs} -top */
/* titles scn {STRs} -top */
/* 13 title -top sc {STRs} -top --obsolete-- */
/* titles -top */
/* */
/* 17 search {STRs} 19 brief */
/* srh {STRs} bf */
/* sh {STRs} --obsolete-- 20 control_arg STRs */
/* 18 search {STRs} -top ca STRs */
/* srh {STRs} -top 21 . */
/* sh {STRs} -top --obsolete-- 22 ? */
/* 23 header */
/* he */
/* */
/* -scn is the short name for -section. Both are accepted. */
/* sc is obsolete short name for section. It is still accepted, but -sc is not accept */
/* as control arg in help requests. It is accepted in command line, however. */
/* sh is obsolete short name for search. It is still accepted. */
/* titles is in error, but is a ccommon error for the title request. Accept it anyway. */
/* -ep is the short name for -entry_point. Both are accepted. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
\014
dcl defined_ops (30) char(11) varying int static options(constant) init (
"yes", "y", "no", "n", /* 1 to 4 */
"quit", "q", "top", "t", /* 5 to 8 */
"rest", "r", "skip", "s", /* 9 to 12 */
"title", "titles", /* 13 & 14 */
"entry_point", "ep", /* 15 & 16 */
"section", "scn", "sc", /* 17 to 19 */
"search", "srh", "sh", /* 20 to 22 */
"brief", "bf", /* 23 & 24 */
"control_arg", "ca", /* 25 & 26 */
".", "?", "header", "he"), /* 27 to 30 */
op_code (30) fixed bin int static options(constant) init(
1, 1, 2, 2, 3,
3, 4, 4, 5, 5,
7, 7, 12, 12, 14,
14, 15, 15, 15, 17,
17, 17, 19, 19, 20,
20, 21, 22, 23, 23);
k = 0; /* No search or section operands processed yet. */
ca.N = 0; /* Control_args must be given with every ca req. */
ep_name = "";
i = search (answer, " "); /* Find end of request name in answer. */
if i = 0 then i = length(answer)+1;
operation = substr(answer,1,i-1); /* Request name is our operation. */
if length(operation) > maxlength(defined_ops(1)) then do;
RESPONSE_UNKNOWN:
call ioa_$nnl ("Response unknown: ^a. ", substr(answer,1,i-1));
ERROR: op = hbound(parse_operand,1) + 1; /* Error op code. */
return;
end;
else if length(operation) = 0 then go to ERROR; /* Just reask question for blank lines. */
do j = 1 to dimension(defined_ops,1) while (operation ^= defined_ops(j));
end; /* See if operation defined. */
if j > dimension(defined_ops,1) then go to RESPONSE_UNKNOWN;
/* No? Report the error. */
\014
op = op_code(j);
if i >= length(answer) then /* Remainder of answer is operands. */
answer = "";
else answer = ltrim(substr(answer,i), " "); /* Trim leading SP HT from operands. */
do while(length(answer) > 0); /* Process operands. */
i = search (answer, " ");
if i = 0 then i = length(answer)+1;
operand = substr(answer,1,i-1);
go to parse_operand(op);
parse_operand(5): /* rest */
if operand = "-section" | operand = "-scn" then
op = op + 1;
else go to BAD_OPERAND;
go to NEXT_OPERAND;
parse_operand(7): /* skip */
if operand = "-section" | operand = "-scn" then
op = op + 1;
else if operand = "-entry_point" | operand = "-ep" then
op = op + 2;
else if operand = "-rest" | operand = "-r" then
op = op + 3;
else if operand = "-seen" then
op = op + 4;
else go to BAD_OPERAND;
go to NEXT_OPERAND;
parse_operand(12): /* title */
if operand = "-top" | operand = "-t" then
op = op + 1;
else go to BAD_OPERAND;
go to NEXT_OPERAND;
\014
parse_operand(14): /* entry_point or ep */
if k > 0 then do;
call ioa_ ("Only one entry point name can be given in ^a response.", operation);
go to ERROR;
end;
if length(operand) > maxlength(ep_name) then do;
call ioa_ ("Entry point name ^a is too long.", operand);
go to ERROR;
end;
ep_name = operand;
k = 1;
go to NEXT_OPERAND;
parse_operand(15): /* section */
if operand = "-top" | operand = "-t" then
op = op + 1;
else do;
parse_operand(16): /* section -top */
if length(operand) > maxlength(scn.group(1).arg) then do;
Lcount = 38; /* 38 = length("Operand of response is too long."); */
Snl1 = (Lcount + i + length(operation) > Loutput_line);
call ioa_$nnl ("Operand ^a^[^/^] of ^a response is too long. ",
substr(answer,1,i-1), Snl1, operation);
go to ERROR;
end;
if k = dimension (scn.group, 1) then do;
call ioa_$nnl ("More than ^d substrings given with ^a response. ",
dimension(scn.group,1), operation);
go to ERROR;
end;
k, scn.N = k + 1;
scn.arg(k) = operand;
end;
go to NEXT_OPERAND;
parse_operand(17): /* search */
if operand = "-top" | operand = "-t" then
op = op + 1;
else do;
parse_operand(18): /* search -top */
if length(operand) > maxlength(srh.group(1).arg) then do;
Lcount = 38; /* 38 = length("Operand of response is too long."); */
Snl1 = (Lcount + i + length(operation) > Loutput_line);
call ioa_$nnl ("Operand ^a^[^/^] of ^a response is too long. ",
substr(answer,1,i-1), Snl1, operation);
go to ERROR;
end;
if k = dimension (srh.group, 1) then do;
call ioa_$nnl ("More than ^d substrings given with ^a response. ",
dimension(srh.group,1), operation);
go to ERROR;
end;
k, srh.N = k + 1;
srh.arg(k) = operand;
end;
go to NEXT_OPERAND;
\014
parse_operand(20): /* control_arg STRs */
if length(operand) > maxlength(ca.group(1).arg) then do;
Lcount = 38; /* 38 = length("Operand of response is too long."); */
Snl1 = (Lcount + i + length(operation) > Loutput_line);
call ioa_$nnl ("Operand ^a^[^/^] of ^a response is too long. ",
substr(answer,1,i-1), Snl1, operation);
go to ERROR;
end;
if k = dimension (ca.group, 1) then do;
call ioa_$nnl ("More than ^d substrings given with ^a response. ",
dimension(ca.group, 1), operation);
go to ERROR;
end;
k, ca.N = k + 1;
ca.arg(k) = operand;
go to NEXT_OPERAND;
parse_operand(1): /* yes */
parse_operand(2): /* no */
parse_operand(3): /* quit */
parse_operand(4): /* top */
parse_operand(19): /* brief */
parse_operand(21): /* . (= print "help") */
parse_operand(22): /* ? (= list requests) */
parse_operand(23): /* header */
call ioa_$nnl ("^a response does not allow operands. ", operation);
go to ERROR;
parse_operand(6): /* rest -scn */
parse_operand(8): /* skip -scn */
parse_operand(9): /* skip -ep */
parse_operand(10): /* skip -rest */
parse_operand(11): /* skip -seen */
parse_operand(13): /* title -top */
call ioa_$nnl ("Invalid combination of operands for ^a response. ", operation);
go to ERROR;
BAD_OPERAND: call ioa_$nnl ("Operand ^a invalid for ^a operation. ", operand, operation);
go to ERROR;
NEXT_OPERAND: if i >= length(answer) then
answer = "";
else answer = ltrim (substr(answer,i), " ");
end; /* Strip leading HT SP from next operand. */
if op = 20 then /* control_arg STRs */
if ca.N = 0 then do;
call ioa_$nnl ("Substrings must be given with the ^a response. ", operation);
op = hbound(parse_operand,1) + 1;
end;
end parse_answer;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
parse_entry_point_into_units: procedure (linfo, Pcommon_units, Ncommon_units, PDlinfo_);
/* This procedure parses an entry point (logical */
/* info segment) into units (paragraphs). */
dcl 1 linfo aligned like Deps.linfo,
Pcommon_units ptr,
Ncommon_units fixed bin,
PDlinfo_ ptr; /* ptr to descriptors for this log info seg. */
dcl 1 Dlinfo_ aligned based(PDlinfo_),
2 Nunits fixed bin, /* number of units (pghs) in this log info seg. */
2 Nsections fixed bin, /* number of units having section title. */
2 unit (0 refer (Dlinfo_.Nunits))
like Dlinfo.unit;
dcl 1 common_units (Ncommon_units)aligned based(Pcommon_units) like Dlinfo.unit;
dcl Iunit fixed bin,
(Lline1, Lline2, Lline3) fixed bin,
(Llseg, Lpgh) fixed bin(21),
(Pline1, Pline2, Pline3) ptr,
(Plseg, Ppgh) ptr,
(i, j, k) fixed bin;
dcl line1 char(Lline1) based(Pline1),
line2 char(Lline2) based(Pline2),
line3 char(Lline3) based(Pline3),
lseg char(Llseg) based(Plseg),
lseg_char (Llseg) char(1) based(Plseg),
pgh char(Lpgh) based(Ppgh),
pgh_char (Lpgh) char(1) based(Ppgh);
\014
Dlinfo_.Nunits = 0;
Dlinfo_.Icommon_unit = 0;
Dlinfo_.Nsections = 0;
linfo.PDlinfo = PDlinfo_;
Plseg = linfo.Pstart;
Llseg = linfo.L;
if linfo.S.old_format then
go to OLD_FORMAT; /* parse an old-format info segment. */
do while (Llseg > 0); /* parse into units until log info seg exhausted. */
i = verify (lseg, "
"); /* check for pgh containing HT SP NL. */
if i = 0 then Llseg = 0; /* stop if remaining part of log info seg */
/* consists of these chars. */
else do;
i = verify (lseg, " "); /* strip blank lines from start of pgh. */
do while (i > 0);
if lseg_char(i) = NL then do;
Plseg = addr(lseg_char(i+1));
Llseg = Llseg - i;
i = verify (lseg, " ");
end;
else i = 0;
end;
i = index(lseg, "
"); /* find beginning of next pgh (<NL><NL><NL>). */
Pline1, Ppgh = Plseg; /* address this pgh. */
if i = 0 then do; /* this is last pgh of log info seg. */
Lpgh = Llseg;
Llseg = 0;
end;
else do; /* next pgh found. */
Lpgh = i; /* i is index relative to start of this */
/* pgh. Save length of this pgh. */
Plseg = addr(lseg_char(i+1)); /* First NL of <NL><NL><NL> is in this pgh. */
Llseg = Llseg - i;
end;
j, Dlinfo_.Nunits = Dlinfo_.Nunits + 1; /* Fill in unit descriptor for this pgh. */
Dlinfo_.unit(j).title = "";
Dlinfo_.unit(j).Pstart = Ppgh;
Dlinfo_.unit(j).L = Lpgh;
Dlinfo_.unit(j).Nlines = 0;
Dlinfo_.unit(j).S = FALSE;
Dlinfo_.unit(j).Icommon_unit = 0;
\014
Lline1 = index(pgh, NL); /* See if pgh begins new section (has title). */
k = index (reverse(line1), ":"); /* Title ends with LAST : on 1st line of pgh. */
if k > 0 then do;
k = Lline1 - (k-1); /* Get char index of last colon in line. */
Dlinfo_.unit(j).title = ltrim(rtrim(substr(line1,1,k-1), " "), " ");
Dlinfo_.unit(j).Pstart = addr(pgh_char(k+1));
Dlinfo_.unit(j).L = Dlinfo_.unit(j).L - k;
Dlinfo_.unit(j).S.scn = TRUE;
Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
/* Is section an arg_list section? */
if length(Dlinfo_.unit(j).title) >= 16 then
if substr(Dlinfo_.unit(j).title,1,16) = "Control argument" |
substr(Dlinfo_.unit(j).title,1,16) = "Control Argument" |
substr(Dlinfo_.unit(j).title,1,8) = "Argument" |
substr(Dlinfo_.unit(j).title,1,8) = "List of " then
Dlinfo_.unit(j).S.arg_list = TRUE;
else;
else if length(Dlinfo_.unit(j).title) >= 8 then
if substr(Dlinfo_.unit(j).title,1,8) = "Argument" |
substr(Dlinfo_.unit(j).title,1,8) = "List of " then
Dlinfo_.unit(j).S.arg_list = TRUE;
end;
else if j > 1 then /* propagate arg_list finding to all pghs of sect.*/
if Dlinfo_.unit(j-1).S.arg_list then
Dlinfo_.unit(j).S.arg_list = TRUE;
do while (Lpgh > 0); /* Count lines in pgh. */
Dlinfo_.unit(j).Nlines = Dlinfo_.unit(j).Nlines + 1;
i = index(pgh, NL);
if i = 0 then Lpgh = 0;
else do;
if i < Lpgh then
Ppgh = addr(pgh_char(i+1));
Lpgh = Lpgh - i;
end;
end;
end;
end;
if Ncommon_units > 0 then do; /* Add common units onto end of entry point part. */
i = Dlinfo_.Nunits + 1;
Dlinfo_.Nunits = Dlinfo_.Nunits + Ncommon_units;
addr(Dlinfo_.unit(i))->common_units = common_units;
end;
/* Compute line count of entry point part. */
linfo.Nlines = sum(Dlinfo_.unit.Nlines) + (Dlinfo_.Nunits-1)*2;
if length(linfo.header) > 0 then linfo.Nlines = linfo.Nlines + 2;
return;
\014
OLD_FORMAT:
i = verify(lseg, "
"); /* strip off HT NL SP chars. */
if i = 0 then
Llseg = 0;
else do; /* process the first unit. */
Plseg = addr(lseg_char(i));
Llseg = Llseg - (i-1);
Llseg = length(rtrim(lseg, "
")); /* Remove trailing SP HT NL \006 chars. */
Dlinfo_.Nunits = 1;
Dlinfo_.unit(1).Nlines = 0;
Dlinfo_.unit(1).S = FALSE;
Dlinfo_.unit(1).Icommon_unit = 0;
i = index(lseg, NL); /* See if first line contains section title. */
if i = 0 then i = Llseg + 1;
j = index(substr(lseg,1,i-1), ":");
if j > 0 then do; /* It does. */
Dlinfo_.unit(1).title = substr(lseg,1,j-1);
Dlinfo_.unit(1).Pstart = addr(lseg_char(j+1));
Dlinfo_.unit(1).S.scn = TRUE;
Plseg = addr(lseg_char(j+1));
Llseg = Llseg - j;
end;
else do;
Dlinfo_.unit(1).title = "";
Dlinfo_.unit(1).Pstart = Plseg;
end;
Dlinfo_.unit(1).L = Llseg; /* store interim length for now. */
Iunit = 0;
end;
do while( Iunit = 0 | Llseg > 0); /* parse old-format info seg into units (pghs). */
Iunit = Iunit + 1; /* process the next unit. */
Ppgh = Plseg;
i = index(lseg, OLD_HELP_PGH_CHAR);
if i = 0 then i = Llseg + 1;
if (i >= Llseg) then do; /* this is last pgh of log info seg. */
Lpgh = Llseg - 1;
Lpgh = length(rtrim(lseg, "
")); /* strip HT NL SP off end of unit. */
Llseg = 0;
Dlinfo_.unit(Iunit).L = Lpgh;
end;
else do; /* next pgh found. */
Dlinfo_.Nunits = Dlinfo_.Nunits + 1;
Dlinfo_.unit(Iunit+1).S = FALSE;
Dlinfo_.unit(Iunit+1).Icommon_unit = 0;
Lpgh = i - 1;
i = index(reverse(pgh), NL); /* address last 3 lines of pgh. */
j = index(reverse(substr(pgh,1,Lpgh-i)),NL);
if j > 0 then do;
j = j + i;
k = index(reverse(substr(pgh,1,Lpgh-j)),NL);
if k = 0 then k = Lpgh+1-j;
end;
else k = 0;
if k > 0 then do;
k = k + j;
Pline1 = addr(pgh_char(Lpgh-k+2));
Lline1 = k-j-1;
end;
else do;
Pline1 = Ppgh;
Lline1 = 0;
end;
if j > 0 then do;
Pline2 = addr(pgh_char(Lpgh-j+2));
Lline2 = j-i-1;
end;
else do;
Pline2 = Ppgh;
Lline2 = 0;
end;
Pline3 = addr(pgh_char(Lpgh-i+2));
Lline3 = i - 1;
if Lpgh+1 < Llseg then /* address units following the current unit. */
Plseg = addr(lseg_char(Lpgh+2));
Llseg = Llseg - (Lpgh+1);
if Llseg <= 0 then /* Check for empty next pgh. */
Llseg, Lline1, Lline2, Lline3 = 0;
if length(ltrim(line3," ")) > 0 & /* Section title on line containing PGH char. */
length(ltrim(line2," ")) = 0 then do;
Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line3," :"), " ");
Dlinfo_.unit(Iunit+1).S.scn = TRUE;
Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
Lpgh = Lpgh - (j-1);
end;
else if length(ltrim(line3," ")) = 0 &
length(ltrim(line2," ")) > 0 &
length(ltrim(line1," ")) = 0 then do;
/* Section title on line preceding PGH char. */
Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line2," :"), " ");
Dlinfo_.unit(Iunit+1).S.scn = TRUE;
Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
Lpgh = Lpgh - (k-1);
end;
else do; /* No section title preceding PGH char. */
i = verify(lseg, "
"); if i = 0 then do; /* Next pgh is empty. Forget about it. */
Llseg = 0;
Dlinfo_.Nunits = Dlinfo_.Nunits - 1;
end;
else do; /* Ignoring any SP HT NL chars at pgh head, */
Pline1 = addr(lseg_char(i)); /* see if a title is in 1st line of next pgh. */
Lline1 = Llseg - (i-1);
j = index(line1, NL);
if j > 0 then
Lline1 = j - 1;
Lline1 = index(line1, ":");
if Lline1 > 0 then do;
Dlinfo_.unit(Iunit+1).title = ltrim(rtrim(line1," :"), " ");
Dlinfo_.unit(Iunit+1).S.scn = TRUE;
Dlinfo_.Nsections = Dlinfo_.Nsections + 1;
if Lline1+1+(i-1) < Llseg then
Plseg = addr(lseg_char(Lline1+2+(i-1)));
Llseg = Llseg - (Lline1+1) - (i-1);
end;
else Dlinfo_.unit(Iunit+1).title = "";
end;
end;
end;
if Dlinfo_.unit(Iunit).S.scn then
i = 0; /* Strip HT SP off pghs not starting a section. */
else i = verify(pgh,NL); /* Strip NL off other sections. */
if i > 1 then do;
Ppgh = addr(pgh_char(i));
Lpgh = Lpgh - (i-1);
end;
i = verify(reverse(pgh), "
"); /* Strip HT SP NL from end of pgh. */
Pline1 = addr(pgh_char(Lpgh-(i-2)));
Lline1 = (i-1);
k = index(line1, NL);
if k = 0 then
Lpgh = Lpgh - (i-1);
else Lpgh = Lpgh - (i-1) + k;
Dlinfo_.unit(Iunit).Pstart = Ppgh;
Dlinfo_.unit(Iunit).L = Lpgh;
Dlinfo_.unit(Iunit).Nlines = 0;
if Dlinfo_.unit(Iunit).S.scn then do;
i = index(Dlinfo_.unit(Iunit).title, BS_underscore);
do while (i > 0); /* Remove underscoring from title of old info seg.*/
if i+2 <= length(Dlinfo_.unit(Iunit).title) then
Dlinfo_.unit(Iunit).title =
substr(Dlinfo_.unit(Iunit).title,1,i-1) ||
substr(Dlinfo_.unit(Iunit).title,i+2);
else Dlinfo_.unit(Iunit).title =
substr(Dlinfo_.unit(Iunit).title,1,i-1);
i = index(Dlinfo_.unit(Iunit).title, BS_underscore);
end;
i = index(Dlinfo_.unit(Iunit).title, underscore_BS);
do while (i > 0);
if i+2 <= length(Dlinfo_.unit(Iunit).title) then
Dlinfo_.unit(Iunit).title =
substr(Dlinfo_.unit(Iunit).title,1,i-1) ||
substr(Dlinfo_.unit(Iunit).title,i+2);
else Dlinfo_.unit(Iunit).title =
substr(Dlinfo_.unit(Iunit).title,1,i-1);
i = index(Dlinfo_.unit(Iunit).title, underscore_BS);
end;
/* Check for an arg_list section. */
if length(Dlinfo_.unit(j).title) >= 8 then
if substr(Dlinfo_.unit(Iunit).title,1,8) = "Argument" then
Dlinfo_.unit(Iunit).S.arg_list = TRUE;
else if length(Dlinfo_.unit(Iunit).title) >= 16 then
if substr(Dlinfo_.unit(Iunit).title,1,16) = "Control argument" |
substr(Dlinfo_.unit(Iunit).title,1,16) = "Control Argument" then
Dlinfo_.unit(Iunit).S.arg_list = TRUE;
end;
else if Iunit > 1 then /* propagate arg_list finding to all pghs of sect.*/
if Dlinfo_.unit(Iunit-1).S.arg_list then
Dlinfo_.unit(Iunit).S.arg_list = TRUE;
/* Count lines in the pgh. */
do while (Lpgh > 0);
Dlinfo_.unit(Iunit).Nlines = Dlinfo_.unit(Iunit).Nlines + 1;
i = index(pgh, NL);
if i = 0 then Lpgh = 0;
else do;
if i < Lpgh then
Ppgh = addr(pgh_char(i+1));
Lpgh = Lpgh - i;
end;
end;
end;
/* Compute line count of log. info. */
linfo.Nlines = sum(Dlinfo_.unit.Nlines) + (Dlinfo_.Nunits-1)*2;
if length(linfo.header) > 0 then linfo.Nlines = linfo.Nlines + 2;
end parse_entry_point_into_units;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
parse_info_into_entry_points: procedure (APseg, ALseg, PDeps_);
/* Parse logical info into 1 or more entry points */
dcl APseg ptr, /* ptr to logical info. (Input) */
ALseg fixed bin(21), /* length of logical info (in chars). (In) */
PDeps_ ptr; /* ptr to entry points structure to be filled in. */
dcl (Llseg, Lseg) fixed bin(21),
Lline fixed bin,
(Plseg, Pseg) ptr,
code fixed bin(35),
i fixed bin(21),
(j, k) fixed bin;
dcl line char(Lline) based (Plseg),
seg char(Lseg) based(Pseg),
seg_char (Lseg) char(1) based(Pseg),
lseg char(Llseg) based(Plseg),
lseg_char (Llseg) char(1) based(Plseg);
dcl 1 Deps_ aligned based(PDeps_),
2 Nlines fixed bin,
2 N fixed bin,
2 linfo (0: 0 refer (Deps_.N)) like Deps.linfo;
Pseg = APseg; /* Address the logical info segment. */
Lseg = ALseg;
Deps_.N = -1; /* At least 1 entry point will be found. */
Deps_.Nlines = 0; /* No lines counted yet in logical info. */
i = index(seg, "
:Entry:"); /* Search for 1st log info seg divider. */
do while(Lseg > 0); /* record info about log. info seg. */
Plseg = Pseg;
Deps_.N, j = Deps_.N + 1;
Deps_.linfo(j).Nep_names = 0;
if (i = 0) & (j = 0) then do; /* This info has no :Entry: lines. */
Llseg = Lseg;
Lseg = 0;
i = verify (lseg, "
"); /* Strip off leading SP HT NL chars. */
if i = 0 then do;
Deps_.N = Deps_.N - 1; /* Empty entry. */
go to END_ENTRIES;
end;
else if i > 1 then do;
Plseg = addr(lseg_char(i));
Llseg = Llseg - (i-1);
end;
end;
\014
else do;
if i = 0 then do; /* This is last entry point in the info. */
Llseg = Lseg;
Lseg = 0;
end;
else do; /* One of other entry points in the info. */
Llseg = i;
Pseg = addr(seg_char(i+10)); /* 10 = length("<NL><NL><NL>:Entry:") */
Lseg = Lseg - (i+9);
end;
Lline = index(lseg, NL); /* Search for entry names in :Entry: line. */
if Lline = 0 then do;
Deps_.N = Deps_.N - 1; /* Nothing left of :Entry: line. */
go to END_ENTRIES;
end;
i = index(line, ":"); /* Look for : ending first entry point name. */
do while (i > 0); /* Sample line looks like: */
/* :Entry: rs: rsnnl: 05/25/78 ioa_$rs, ioa_$rsnnl*/
k, Deps_.linfo(j).Nep_names = Deps_.linfo(j).Nep_names+1;
if k <= dim(Deps_.linfo.ep_name, 2) then
Deps_.linfo(j).ep_name(k) = ltrim(rtrim(substr(line,1,i), " :"), " ");
Plseg = addr(lseg_char(i+1)); /* Skip over name and : */
Llseg = Llseg - i;
Lline = Lline - i;
i = index(line, ":");
end;
if (j > 0) & (Deps_.linfo(j).Nep_names = 0) then do;
Deps_.N = Deps_.N - 1; /* All but common info must have entry point */
go to NEXT_ENTRY; /* names. But look! */
end; /* No names! Can never read this info via help */
i = verify(lseg, "
"); /* Strip off HT SP NL from start of info */
if i = 0 then do; /* Nothing in info! Forget about it. */
Deps_.N = Deps_.N - 1;
go to NEXT_ENTRY;
end;
else if i > 1 then do;
Plseg = addr(lseg_char(i));
Llseg = Llseg - (i-1);
end;
end;
\014
Deps_.linfo(j).Pstart = Plseg;
Deps_.linfo(j).L = Llseg;
Deps_.linfo(j).Nlines = 0;
Deps_.linfo(j).S = "0"b;
Lline = index(lseg, NL); /* header is first line of log. info seg. */
if Lline >= Llseg then do; /* header is only line of file. */
Deps_.linfo(j).header = "";
Deps_.linfo(j).date = 0;
end;
else if lseg_char(Lline+1) = NL then do; /* header line must be followed by 1 blank line, */
/* at least. */
Deps_.linfo(j).header = substr(lseg,1,Lline-1);
/* Remainder should be an entry point name. */
Deps_.linfo(j).Pstart = addr(lseg_char(Lline+1));
Deps_.linfo(j).L = Llseg - Lline; /* Remove header from logical info. */
i = search(substr(lseg,1,Lline), " ");
if i = 0 then
Deps_.linfo(j).date = 0;
else do;
call convert_date_to_binary_ (substr(line,1,i-1), Deps_.linfo(j).date, code);
if code ^= 0 then /* No date! */
Deps_.linfo(j).date = 0;
end;
end;
else do;
Deps_.linfo(j).header = "";
Deps_.linfo(j).date = 0;
end;
if index(lseg, OLD_HELP_PGH_CHAR) > 0 then /* check old format info segs with \006 chars */
Deps_.linfo(j).S.old_format = TRUE;
NEXT_ENTRY: i = index(seg, "
:Entry:");
end;
END_ENTRIES:
end parse_info_into_entry_points;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
print_header: proc (); /* This procedure prints a regular heading line. */
dcl Lcount fixed bin,
Linfo_name fixed bin,
Lpath fixed bin;
dcl case fixed bin;
dcl line char(256) varying;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Output heading line before other info. The heading spans at least 2 lines, and has */
/* the form: */
/* pathname (line counts) */
/* info_name: info_title */
/* */
/* where all parts but the info_title are optional. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
if help_args.Sctl.he_counts then do; /* Do following only if line/entry counts wanted. */
if Deps.N = 0 then /* No subroutine entry points. */
if Nlines >= Deps.linfo(0).Nlines then /* Only 1 paragraph. */
case = 1;
else case = 2; /* Multiple paragraphs. */
else do; /* Subroutine entry points. */
if Iep = 0 then /* Subroutine introduction. */
if Nlines >= Deps.linfo(0).Nlines then
case = 3; /* Only 1 paragraph. */
else case = 4; /* Multiple paragraphs. */
else /* A subroutine entry point. */
if Deps.N = 1 then /* Only 1 entry point. */
if Nlines >= Deps.linfo(Iep).Nlines then
case = 5; /* Only 1 paragraph. */
else case = 6; /* Multiple paragraphs. */
else /* Multiple entry points. */
if Nlines >= Deps.linfo(Iep).Nlines then
case = 7; /* Only 1 paragraph. */
else case = 8; /* Multiple paragraphs. */
end;
go to FORM(case);
FORM(1): call ioa_$rsnnl ("^d line^[s^] in info", line, 0,
Nlines, (Nlines > 1));
go to END_FORM;
FORM(2): call ioa_$rsnnl ("^d ^[lines follow^;line follows^]; ^d in info", line, 0,
Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines);
go to END_FORM;
FORM(3): call ioa_$rsnnl ("^d line^[s^] in introduction; ^d lines, ^d entry point^[s^] in info", line, 0,
Nlines, (Nlines > 1), Deps.Nlines, Deps.N, (Deps.N > 1));
go to END_FORM;
\014
FORM(4): call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in introduction; ^d lines, ^d entry point^[s^] in info",
line, 0, Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines, Deps.Nlines, Deps.N, (Deps.N > 1));
go to END_FORM;
FORM(5): call ioa_$rsnnl ("^d line^[s^] in entry point", line, 0, Nlines, (Nlines > 1));
go to END_FORM;
FORM(6): call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point", line, 0,
Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines);
go to END_FORM;
FORM(7): call ioa_$rsnnl ("^d line^[s^] in entry point; ^d lines, ^d other entry point^[s^] in info",
line, 0, Nlines, (Nlines > 1), Deps.Nlines, (Deps.N-1), (Deps.N-1 > 1));
go to END_FORM;
FORM(8): call ioa_$rsnnl ("^d ^[lines follow^;line follows^], ^d in entry point; ^d lines, ^d other entry point^[s^] in info",
line, 0, Nlines, (Nlines > 1), Deps.linfo(Iep).Nlines,
Deps.Nlines, (Deps.N-1), (Deps.N-1 > 1));
END_FORM: Lcount =length(line);
end;
else Lcount = 0;
if help_args.Sctl.he_pn then do; /* Compute length of pathname for heading. */
Lpath = length(rtrim(Dinfo_seg_.dir)) + length(rtrim(Dinfo_seg_.ent)) + length(" ");
if Dinfo_seg_.dir ^= ">" then Lpath = Lpath + 1;
end;
else Lpath = 0;
if help_args.Sctl.he_info_name then do; /* If info_name to be output, compute its length */
Linfo_name = length(rtrim(Dinfo_seg_.info_name));
if Linfo_name > 0 then /* + colon + 2 spaces. */
Linfo_name = Linfo_name + length(": ");
end;
else Linfo_name = 0;
if Lpath>0 & Lcount>0 then
if Lpath+Lcount <= Loutput_line then
ISnl3 = 2;
else ISnl3 = 1;
else ISnl3 = 3;
if Lpath + Lcount > 0 then
Snl1 = TRUE;
else Snl1 = FALSE;
if Linfo_name + length(Deps.linfo(Iep).header) >= 0 then
Snl2 = TRUE;
else Snl2 = FALSE;
call ioa_$nnl ("^[^v/^;^s^]^[^a^[>^]^a^;^3s^]^[^/^; ^;^]^[(^a)^;^s^]^[^/^]^[^a: ^;^s^]^a^[^/^]",
(Ninfos_printed > 1), /* For all but the first info printed, */
help_args.Lspace_between_infos, /* output spaces between infos. */
help_args.Sctl.he_pn, /* Put pathname into heading. */
Dinfo_seg_.dir, (Dinfo_seg_.dir ^= ">"), Dinfo_seg_.ent,
ISnl3,
help_args.Sctl.he_counts, /* Put line/entry point count into heading. */
line, /* Description formulated above. */
Snl1,
(Linfo_name > 0), /*Put info_name into heading. */
Dinfo_seg_.info_name,
Deps.linfo(Iep).header, /* Heading line of info or entry point. */
Snl2);
return;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
print_header_only: entry; /* Print header for an info. */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Output a special-format info heading line when only heading lines are being output. */
/* The idea is for the headings to occupy as few lines as possible. */
/* */
/* The heading line has the form: */
/* pathname info_name: info_title (line counts) */
/* */
/* where all fields but info_title are optional. */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
if help_args.Sctl.he_pn then do;
Lpath = length(rtrim(Dinfo_seg_.dir)) + length(rtrim(Dinfo_seg_.ent)) + length(" ");
if Dinfo_seg_.dir ^= ">" then Lpath = Lpath + 1;
end; /* If pathname to be output, compute length of */
else Lpath = 0; /* path + 3 spaces. */
if help_args.Sctl.he_info_name then do; /* If info_name to be output, compute length of */
Linfo_name = length(rtrim(Dinfo_seg_.info_name));
if Linfo_name > 0 then /* info_name + colon + 2 spaces. */
Linfo_name = Linfo_name + length(": ");
end;
else Linfo_name = 0;
if help_args.Sctl.he_counts then do; /* If line/entry point counts to be output, */
if Dinfo_seg_.Scross_ref then /* compute length of appropriate format + 3 spaces*/
Lcount = length(" (another version)");
else if Deps.N = 0 then
Lcount = length(" (9999 lines in info)");
else if Iep = 0 then
Lcount = length(" (9999 lines, 999 entries in info)");
else Lcount = length(" (9999 lines, 999 other entries in info)");
end;
else Lcount = 0;
if Lpath + Linfo_name + length(Deps.linfo(Iep).header) + Lcount <= Loutput_line then do;
Snl1 = FALSE; /* Compute if heading must be broken into several */
Snl2 = FALSE; /* lines. Break points are after pathname and */
end; /* before line/entry counts. */
else if Lpath + Linfo_name + length(Deps.linfo(Iep).header) <= Loutput_line then do;
Snl1 = FALSE;
Snl2 = TRUE;
end;
else if Linfo_name + length(Deps.linfo(Iep).header) + Lcount <= Loutput_line then do;
Snl1 = TRUE;
Snl2 = FALSE;
end;
else do;
Snl1 = (Lpath > 0);
Snl2 = (Lcount > 0);
end;
\014
call ioa_ ("^[^a^[>^]^a^;^3s^]^[^/^] ^[^a: ^;^s^]^a^[
^]^[ ^[(another version)^;(^d line^[s^]^[, ^[^d^s^;^s^d other^] ^[entries^;entry^]^;^4s^] in info)^]^]",
/* Output long heading line. */
help_args.Sctl.he_pn,
Dinfo_seg_.dir, Dinfo_seg_.dir^=">", Dinfo_seg_.ent,
Snl1,
Linfo_name > 0,
Dinfo_seg_.info_name,
Deps.linfo(Iep).header, /* Output the entry point heading. */
Snl2,
help_args.Sctl.he_counts,
Dinfo_seg_.Scross_ref, /* Second occurence of info in another dir. */
Deps.Nlines, (Deps.Nlines > 1), /* Output line count for all entry points. */
((Deps.N > 0) & (Iep = 0)) | (Deps.N > 1),
/* Output count of entry points. */
(Iep = 0), /* Looking at common part. Output info about */
/* all entry points. */
Deps.N,
Deps.N-1, /* Looking at entry point. Output info about */
/* other entry points. */
((Iep = 0) & (Deps.N > 1)) | (Deps.N-1 > 1));
end print_header;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
print_pgh_2nl: procedure (unit, Sprint_inhibit); /* This procedure prints a paragraph. */
dcl 1 unit aligned like Dlinfo.unit,
Sprint_inhibit bit(1) aligned;
dcl code fixed bin(35);
dcl 1 event_info aligned,
2 ev_chan fixed bin(71),
2 message fixed bin(71),
2 sender bit(36),
2 origin,
3 dev_signal bit(18) unal,
3 ring bit(18) unal,
2 chan_index fixed bin;
dcl 1 wait_list aligned int static,
2 N fixed bin,
2 ev_chan (1) fixed bin(71);
dcl 1 write_status aligned int static,
2 ev_chan fixed bin(71) init(0),
2 output_pending bit(1);
if Sprint_inhibit then return;
call ioa_ ("^/");
go to PRINT_PGH;
print_pgh: entry (unit, Sprint_inhibit);
if Sprint_inhibit then return;
call ioa_ ("");
print_pgh_nnl: entry (unit, Sprint_inhibit);
if Sprint_inhibit then return;
PRINT_PGH:
if unit.S.scn then /* Print section title, if any. */
call ioa_$nnl ("^a:", unit.title);
call iox_$put_chars (iox_$user_output, unit.Pstart, unit.L, code);
call iox_$control (iox_$user_output, "write_status", addr(write_status), code);
if (code = 0) & (write_status.output_pending) then do;
/* Wait until output on user's terminal before */
wait_list.N = 1; /* marking pgh seen. */
wait_list.ev_chan(1) = write_status.ev_chan;
call ipc_$block (addr(wait_list), addr(event_info), code);
end;
unit.S.seen_by_user = TRUE; /* Keep track of what we've seen. */
if unit.Icommon_unit > 0 then
common_units(unit.Icommon_unit).S.seen_by_user = TRUE;
end print_pgh_2nl;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
seen_pgh: proc (unit) returns (bit(1) aligned); /* Returns TRUE if pgh has been seen by user. */
dcl 1 unit aligned like Dlinfo.unit,
Sseen bit(1) aligned;
if unit.Icommon_unit > 0 then
Sseen = common_units(unit.Icommon_unit).S.seen_by_user;
else Sseen = unit.S.seen_by_user;
return (Sseen);
end seen_pgh;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
end process_info_seg;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
init: entry (procedure_name, search_list_name, search_list_ref_dir, Vrequired, Phelp_args, Acode);
dcl search_list_name char(*), /* Name of search list used in finding infos. */
/* (input) */
search_list_ref_dir char(*), /* Referencing dir used in search rules. */
/* (input) */
Vrequired fixed bin; /* Required version of help_args structure. */
/* (input) */
dcl Parea ptr,
area area (25000) based(Parea);
if Vrequired ^= Vhelp_args_1 then do;
Acode = error_table_$unimplemented_version;
return;
end;
call get_temp_segment_ (procedure_name, Phelp_args, Acode);
if Acode ^= 0 then /* Obtain a temporary segment. */
Phelp_args = null;
else do;
help_args.version = Vhelp_args_1; /* Initialize the help argument structure. */
string(help_args.Sctl) = "0"b;
help_args.min_Lpgh = 4;
help_args.max_Lpgh = 15;
help_args.Lspace_between_infos = 2;
help_args.min_date_time = -1;
help_args.Npaths = 0;
help_args.Ncas = 0;
help_args.Nsrhs = 0;
if search_list_name ^= "" then do;
help_args.Nsearch_dirs = 1000; /* Allow room for up to 1000 search dirs. */
Parea = set_space_used (Phelp_args, currentsize(help_args));
area = empty();
call search_paths_$get (search_list_name, sl_control_default, search_list_ref_dir, null, Parea,
sl_info_version_1, sl_info_p, Acode);
if Acode = 0 then do;
help_args.Nsearch_dirs = sl_info.num_paths;
if help_args.Nsearch_dirs > 0 then
help_args.search_dirs(*) = sl_info.paths(*).pathname;
end;
else help_args.Nsearch_dirs = 0;
end;
else help_args.Nsearch_dirs = 0;
call hcs_$truncate_seg (Phelp_args, currentsize(help_args), 0);
end;
return;
\014
%include sl_info;
%include sl_control_s;
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
\014
/* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */
term: entry (procedure_name, Phelp_args, Acode);
call release_temp_segment_ (procedure_name, Phelp_args, Acode);
return;
end help_;
\014
list_help.pl1 08/12/83 1303.1r 08/12/83 1136.7 113202
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
list_help:
lh: procedure;
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* */
/* Command to list names of "help" files: */
/* if no args are given, a usage message is printed, */
/* arguments are taken as "topics" to be searched for, */
/* only names which contain one of the topics will be listed */
/* */
/* 0) June 1974 by John W. Dean III MITIPC */
/* */
/* 1) Modified October 1978 by Bernie S. Greenburg for new search facility etc. */
/* */
/* 2) Implement [list_help] and add -absolute_pathname 06/11/80 S.Herbst */
/* */
/* 3) Modified September, 1978 by Gary E. Johnson: */
/* - increase printed output limit to 4092 characters */
/* - no error message when empty dir encountered */
/* - ignore ".info" suffix */
/* - allow multiple -pn arguments */
/* - allow -brief on active function invocation */
/* - implement case insensitivity */
/* - add -long control argument */
/* */
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/* LIST OF AUTOMATIC VARIABLES */
declare absp_sw bit (1), /* -absolute_pathname specified */
af_sw bit (1), /* invoked as an active function */
(alp, eptr, nptr) pointer,
arglen fixed binary (21),
(argptr, return_ptr) ptr,
arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr) variable,
brief bit (1), /* controls output format */
complain entry variable options (variable),
code fixed bin (35), /* general code variable */
ecount fixed bin,
entryname char (32) varying,
xentryname char (32) varying,
\014
(numpath, return_len) fixed binary,
found bit (1), /* topic found in file name */
(i, iname, narg, nargs, nentry, nname) fixed bin,
list_all bit (1), /* -all option */
link_target_type fixed binary (2),
long_sw bit (1), /* -long option */
ndir fixed bin, /* directory counter */
ntopics fixed bin, /* number of topics given as arguments */
number_printed fixed bin, /* number of files listed */
outstring char (4092) varying,
pn_flag bit (1); /* user has specified the dir */
/* LIST OF BASED VARIABLES */
declare area area based (areap),
arg char (arglen) based (argptr),
return_arg char (return_len) varying based (return_ptr);
declare 1 entry (ecount) aligned based (eptr),
2 type bit (2) unaligned,
2 nnames fixed bin (15) unaligned,
2 nindex fixed bin (17) unaligned,
names (iname) char (32) based (nptr);
/* LIST OF CONDITIONS */
declare cleanup condition;
declare absolute_pathname_ entry (char (*), char (*), fixed bin (35)),
active_fnc_err_ entry options (variable),
com_err_ entry options (variable),
check_star_name_$path entry (char (*), fixed bin (35)),
cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
cu_$arg_list_ptr entry (pointer),
cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr),
get_system_free_area_ entry returns (pointer),
hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24),
fixed bin (35)),
ioa_ entry options (variable),
search_paths_$get entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));
/* LIST OF STATIC VARIABLES */
declare areap ptr int static init (null),
error_table_$badopt fixed bin (35) external, /* illegal control argument */
error_table_$inconsistent fixed bin (35) external,
error_table_$incorrect_access fixed bin (35) external,
error_table_$noentry fixed bin(35) ext static,
error_table_$nomatch fixed bin (35) external,
error_table_$nostars fixed bin (35) external,
error_table_$wrong_no_of_args fixed bin (35) external,
myname char (32) options (constant) static init ("list_help"),
(upper_case char (26) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
lower_case char (26) init ("abcdefghijklmnopqrstuvwxyz")) static options (constant);
declare (divide, index, length, null, rtrim, substr, translate) builtin;
/* initialization and argument handling */
call cu_$af_return_arg (nargs, return_ptr, return_len, code);
if code ^= 0 then do;
af_sw = "0"b;
complain = com_err_;
arg_ptr = cu_$arg_ptr_rel;
end;
else do;
af_sw = "1"b;
complain = active_fnc_err_;
return_arg = "";
arg_ptr = cu_$af_arg_ptr_rel;
end;
call cu_$arg_list_ptr (alp);
BLOCK: begin;
declare user_dir (divide (nargs, 2, 17, 0)) char (168); /* for user specified directory */
declare topic (nargs) char (32) varying; /* can't be more topics than arguments */
numpath = 0; /* for pathname count */
list_all = "0"b;
number_printed = 0;
ntopics = 0;
absp_sw = "0"b;
pn_flag = "0"b;
brief = af_sw;
do narg = 1 to nargs;
call arg_ptr (narg, argptr, arglen, code, alp);
if index (arg, "-") = 1 then do;
if arg = "-long" | arg = "-lg" then brief = "0"b;
else if arg = "-brief" | arg = "-bf" then brief = "1"b;
else if arg = "-a" | arg = "-all" then list_all = "1"b;
else if arg = "-absolute_pathname" | arg = "-absp" then absp_sw = "1"b;
else if arg = "-pathname" | arg = "-pn" then do;
pn_flag = "1"b;
narg = narg + 1;
call arg_ptr (narg, argptr, arglen, code, alp);
/* get user specified dir path */
if code ^= 0 then do;
call complain (code, myname, "
The -pn control argument must be followed by a pathname.");
return;
end;
\014
numpath = numpath + 1;
call absolute_pathname_ (arg, user_dir (numpath), code);
/* get absolute path of dir */
if code ^= 0 then do;
call complain (code, myname, "^a", arg);
return;
end_path: end;
call check_star_name_$path (user_dir (numpath), code);
if code ^= 0 then do;
if code = 1 | code = 2 then code = error_table_$nostars;
else call complain (code, myname, "^a", arg);
return;
end;
end;
else do;
BAD_OPT: call complain (error_table_$badopt, myname, """^a""", arg);
return;
end;
end;
else do;
ntopics = ntopics+1;
topic (ntopics) = translate (arg, lower_case, upper_case);
end;
end; /* of arg getting loop */
if ntopics > 0 then do; /* both topics and -all in same command */
if list_all then do;
call complain (error_table_$inconsistent, myname, "
Topics cannot be specified with -all.");
return;
end;
end;
if af_sw then if ^brief then do;
call complain (error_table_$badopt, myname, "
The -long control arg is not accepted for active function.");
return;
end;
if ntopics = 0 then do; /* ntopics=0 and -all not specified is wrong */
if ^list_all then do;
call complain (error_table_$wrong_no_of_args, myname, "
You must specify topics or use the -all control_arg. For details, type,
help lh");
return;
end;
end;
\014
areap = get_system_free_area_ (); /* for allocating star info */
sl_info_p = null;
eptr, nptr = null;
on cleanup begin;
if sl_info_p ^= null then free sl_info in (area);
call clean_up;
end;
if ^pn_flag then do;
call search_paths_$get ("info_segments", sl_control_default,
"", null, areap, sl_info_version_1, sl_info_p, code);
if code ^= 0 then do;
call complain (code, myname, "Getting search list for info segments.");
return;
end;
end;
/* searching and printing of file names */
if pn_flag then do ndir = 1 to numpath; /* specified by -pn option */
call scan_dir (user_dir (ndir));
end;
/* default directories */
else do ndir = 1 to sl_info.num_paths;
call scan_dir (sl_info.pathname (ndir));
end;
if number_printed = 0 & ^af_sw then call ioa_ ("No files found.");
if sl_info_p ^= null then free sl_info in (area);
return;
\014 /* internal proc to do searching and listing */
scan_dir: procedure (dirname);
declare dirname char (168) parameter;
call hcs_$star_ (dirname, "**.info", 3, areap, ecount, eptr, nptr, code);
/* use "**" to avoid duplication of effort */
/* get all segs and links in specified dir */
if code ^= 0 then do; /* problem getting info */
if code ^= error_table_$nomatch then do;
call complain (code, myname, "Listing files in ^a.", dirname);
return;
end;
end;
\014
do nentry = 1 to ecount; /* scan all entries */
if entry.type (nentry) = "10"b then go to NEXT_ENTRY; /* ignore directories */
iname = entry.nindex (nentry);
if entry.type (nentry) = "00"b then do;
call hcs_$status_minf (dirname, names(iname), 1, link_target_type,
0, code);
if code = error_table_$noentry then go to NEXT_ENTRY;
else if code = error_table_$incorrect_access then go to NEXT_ENTRY;
else if code ^= 0 then do;
call complain (code, myname, "^a^[>^]^a",
dirname, dirname ^= ">", names (iname));
go to NEXT_ENTRY;
end;
if link_target_type = 00b | link_target_type = 10b then go to NEXT_ENTRY;
end;
nname = 1; /* nname is the number+1 of names with ".info" */
found = list_all; /* no topics matched for this seg yet */
do nname = 1 to entry.nnames (nentry);
/* go through all names */
entryname = rtrim (names (iname));
if substr (entryname, length (entryname) - length (".info") + 1) = ".info" then do;
entryname = substr (entryname, 1, length (entryname) - length (".info"));
xentryname = translate (entryname, lower_case, upper_case);
end;
else go to NEXT_ENTRY;
if ^found then do; /* topics specified and not matched yet */
do i = 1 to ntopics
while (index (xentryname, topic (i)) = 0);
end;
found = (i <= ntopics);
end;
if nname = 1 then do; /* first name */
if absp_sw then do;
outstring = rtrim (dirname);
if dirname ^= ">" then
outstring = outstring || ">";
end;
else outstring = "";
outstring = outstring || entryname;
end;
if ^brief & nname > 1 then do; /* additional names */
if nname = 2 then outstring = outstring || " (";
else outstring = outstring || ", ";
outstring = outstring || entryname;
end;
iname = iname+1;
end; /* end of loop for names of one entry */
if found then do; /* there is something to print */
if ^brief & nname > 2 then /* add closing paren */
outstring = outstring||")";
if af_sw then do;
if number_printed > 0 then return_arg = return_arg || " ";
return_arg = return_arg || outstring;
end;
else call ioa_ ("^a", outstring);
number_printed = number_printed+1;
end;
NEXT_ENTRY:
end; /* end of processing for one entry */
call clean_up;
end scan_dir; /* end of processing for one directory */
end BLOCK; /* end of begin block for topic allocation */
/* procedure to free things allocated by hcs_$star_ */
clean_up: proc;
if nptr ^= null () then do; free names in (area); nptr = null (); end;
if eptr ^= null () then do; free entry in (area); eptr = null (); end;
end clean_up;
%include sl_info;
%include sl_control_s;
end;
\014
list_ref_names.pl1 04/09/80 1314.1rew 04/09/80 1313.5 89685
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
list_ref_names: lrn: proc;
/* This command lists the reference names of segments */
/* initially coded Jan 1971 by Dan Bricklin */
/* last modified by Dan B. March 1971 */
/* fixed to abort for invalid -from and -to, Steve Herbst 11/8/77 */
/* fixed to not make copy in [pd] if copy switch is on 03/20/80 S. Herbst */
dcl
(i, alen, from_seg, to_seg, argno, seg_no, num_null) fixed bin,
code fixed bin (35),
error_table_$badopt fixed bin (35) ext,
error_table_$segknown fixed bin (35) ext,
(aptr, segptr) ptr,
(brief, prt, allsw, no_zero) bit (1) aligned,
which char (16) init ("list_ref_names") int static aligned,
dirname char (168) aligned,
ename char (32) aligned,
arg char (alen) based (aptr),
ret label init (end_loop),
plural char (1) aligned,
1 p aligned,
2 ignore char (31) unaligned,
2 rname char (32) unaligned,
2 nl char (1) unaligned,
cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
cv_oct_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
expand_pathname_ ext entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)),
hcs_$initiate ext entry (char (*)aligned, char (*)aligned, char (*)aligned, fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
com_err_ ext entry options (variable),
ioa_ ext entry options (variable),
hcs_$terminate_noname ext entry (ptr, fixed bin (35)),
hcs_$fs_get_path_name ext entry (ptr, char (*)aligned, fixed bin, char (*)aligned, fixed bin (35)),
hcs_$high_low_seg_count ext entry (fixed bin, fixed bin),
hcs_$fs_get_ref_name ext entry (ptr, fixed bin, char (*), fixed bin (35)),
ring0_get_$name ext entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35)),
iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)),
iox_$user_output ptr ext;
dcl (addr, baseno, baseptr, fixed, substr) builtin;
allsw, brief, no_zero = "0"b; /* assume print ring-0, and not all and brief options */
nl = "
"; /* set nl equal to a newline char */
argno = 1; /* start with first argument */
do i = 1 by 1; /* look at all arguments */
call cu_$arg_ptr (i, aptr, alen, code); /* for the -all and -brief options */
if code ^= 0 then go to next; /* end of argument list */
if arg = "-brief" | arg = "-bf" then brief = "1"b; /* found a brief option */
if arg = "-all" | arg = "-a" then allsw = "1"b; /* found an all option, so set switch to remember */
end;
next: from_seg = 0; /* default from segment number is zero */
call cu_$arg_ptr (argno, aptr, alen, code); /* get next argument */
if code ^= 0 then do; /* end of argument list */
if argno = 1 | argno = 2 & brief then do; /* if nothing was given, print all non-ring zero */
no_zero = "1"b; /* don't print ring zero ones */
go to all;
end;
return; /* else return to caller */
end;
if arg = "-to" then do; /* if the -to option is encountered, do */
argno = argno + 1; /* look at next argument */
to_sec: call cu_$arg_ptr (argno, aptr, alen, code);
if code ^= 0 then do; /* if not there then it is an error */
error: call com_err_ (code, which); /* print message */
return; /* end of arg list, so return */
end;
to_seg = cv_oct_check_ (arg, code); /* convert to number */
if code ^= 0 | to_seg < 0 then do;
call com_err_ (0, which, "Invalid -to argument ^a", arg);
return;
end;
got_to: if from_seg>to_seg then do; /* if lower bound > upper bound then error */
call com_err_ (0, which, "Lower segment number bound ^o greater than upper bound ^o",
from_seg, to_seg);
return;
end;
num_print: /* given segment number, print info */
prt = "0"b; /* nothing printed yet */
do seg_no = from_seg to to_seg; /* do for each segment number in range */
call hcs_$fs_get_path_name (baseptr (seg_no), dirname, i, ename, code); /* get path name */
if code ^= 0 then do; /* if unable then try the following */
if no_zero then go to end_loop; /* if no ring-0 ones to be printed, don't even check */
call ring0_get_$name (dirname, ename, baseptr (seg_no), code); /* is it in ring 0 ? */
if code ^= 0 then go to end_loop; /* if not, then ignore it for now */
if dirname = "" then call ioa_ (" ^o ^a (ring 0)", seg_no, ename); /* no dir */
else do;
if dirname = ">" then dirname = ""; /* don't have two >'s on root */
call ioa_ (" ^o ^a>^a (ring 0)", seg_no, dirname, ename); /* print info */
end;
prt = "1"b;
go to printed; /* skip around regular print routine */
end;
if i = 1 then dirname = ""; /* if name is only >, then remove it, since we have one */
prt = "1"b; /* we printed something */
call ioa_ ("^/ ^o ^a>^a", seg_no, dirname, ename); /* print number and path */
printed: if ^brief then do; /* print reference names, if not brief */
ret = end_loop; /* pseudo call */
go to ref_print;
end;
end_loop: end; /* end of loop for each segment number */
if ^prt then
if to_seg = from_seg then call com_err_ (0, which, "Invalid segment number ^o", from_seg);
else call com_err_ (0, which, "Invalid segment numbers ^o and ^o", from_seg, to_seg);
argno = argno + 1;
go to next;
end;
if arg = "-from" | arg = "-fm" then do; /* if -from option encountered */
argno = argno + 1; /* look for number after it */
call cu_$arg_ptr (argno, aptr, alen, code);
if code ^= 0 then go to error; /* not found is an error */
from_seg = cv_oct_check_ (arg, code); /* make it a number */
if code ^= 0 | from_seg < 0 then do;
call com_err_ (0, which, "Invalid -from argument ^a", arg);
return;
end;
call cu_$arg_ptr (argno + 1, aptr, alen, code); /* look for a "-to" after the from number */
all: call hcs_$high_low_seg_count (to_seg, i); /* get last allocated segment number */
to_seg = to_seg + i; /* by adding high hc to number after hardcore */
if from_seg>to_seg then do; /* starting after last seg */
call com_err_ (0, which, "Lower bound ^o greater than highest segment number ^o.",
from_seg, to_seg);
return;
end;
if code = 0 then if arg = "-to" then do;
argno = argno + 2;
go to to_sec;
end;
go to got_to;
end;
if arg = "-name" | arg = "-nm" then do; /* if name option */
argno = argno + 1; /* get next argument */
call cu_$arg_ptr (argno, aptr, alen, code); /* and treat it as a character string */
if code = 0 then go to no_num; /* regardless of how it looks */
else go to error; /* if none there, then error */
end;
if arg = "-brief" | arg = "-bf" then do; /* ignore brief options since we already processed it */
argno = argno + 1;
go to next;
end;
if allsw then do; /* if all option was present */
from_seg = 0; /* simulate -from 0 */
go to all;
end;
if substr (arg, 1, 1) = "-" then do; /* look for option type args which we can't identify */
call com_err_ (error_table_$badopt, which, "^a", arg);
return;
end;
seg_no = cv_oct_check_ (arg, code); /* see if argument can be seen as a number */
if code = 0 then do; /* if so, then do */
to_seg, from_seg = seg_no; /* pretend that it is: -from num -to num */
go to num_print; /* go to numbered segment printing routine */
end;
no_num: call expand_pathname_ (arg, dirname, ename, code);
if code ^= 0 then go to error;
call hcs_$initiate (dirname, ename, "", 0, 1, segptr, code); /* see if it is there already and where */
if code = 0 then do; /* wasn't known in advance, no good */
call com_err_ (0, which, "Segment not known. ^a^[>^]^a", dirname, dirname ^= ">", ename);
call hcs_$terminate_noname (segptr, code); /* terminate the reference */
argno = argno + 1; /* try next argument */
go to next;
end;
if code ^= error_table_$segknown then do; /* if it wasn't known, another error */
call com_err_ (code, which, "^a^[>^]^a", dirname, dirname ^= ">", ename);
argno = argno + 1; /* try again */
go to next;
end;
seg_no = fixed (baseno (segptr)); /* get segment number part of pointer */
call hcs_$terminate_noname (segptr, code); /* this reference dosn't count, so end it */
call ioa_ ("^/ ^o", seg_no); /* print segment number */
argno = argno + 1; /* get ready for next argument */
if brief then go to next; /* skip ref name printing */
ret = next; /* pseudo call */
ref_print:
num_null = 0; /* no null reference names found so far for this segment */
do i = 1 by 1; /* look at all reference names */
call hcs_$fs_get_ref_name (baseptr (seg_no), i, p.rname, code); /* get reference names from this entry */
if code ^= 0 then go to fin; /* when ended, then go to fin */
/* if not null, write structure with it and newline */
if p.rname ^= "" then call iox_$put_chars (iox_$user_output, addr (p.rname), 33, code);
else num_null = num_null + 1; /* else count number of null refs */
end;
fin: if num_null>0 then do; /* print number of null refs if > zero */
if num_null = 1 then plural = " "; /* de-pluralize word */
else plural = "s"; /* pluralize word */
call ioa_ ("^d null reference name^a", num_null, plural);
end;
go to ret; /* pseudo return */
end;
\014
print_motd.pl1 04/13/82 1454.5rew 04/13/82 1453.8 115119
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
*********************************************************** */
/* Prints all lines in the message-of-the-day (MOTD) segment which have been changed or added since the user last used
this command */
/* Created: 28 July 1971 by Peter R. Bos */
/* Modified: 14 December 1972 by R. Mullen to convert to version 2 PL/I */
/* Modified: 29 March 1977 by S. Herbst to convert to iox_ */
/* Modified: 14 July 1978 by S. Herbst to use Person_id.motd rather than anonymous.motd for anonymous users */
/* Modified: 12 December 1979 by S. Herbst to fix no_s_permission bug when obtaining date-time-contents-modified */
/* Modified: 23 March 1982 by G. Palter to convert to use the user's value segment */
/* format: style4,delnl,insnl,ifthenstmt,ifthen */
print_motd:
pmotd:
procedure () options (variable);
/* DECLARATIONS */
dcl 1 user_motd aligned based (user_motd_ptr),
2 dtcm fixed binary (71),
2 lth fixed binary (21),
2 motd character (user_motd_lth refer (user_motd.lth));
dcl user_motd_ptr pointer;
dcl user_motd_lth fixed binary (21);
dcl system_motd character (system_motd_lth) based (system_motd_ptr);
dcl system_motd_lth fixed binary (21);
dcl system_motd_ptr pointer;
dcl system_motd_dtcm fixed binary (71);
dcl system_area area based (system_area_ptr);
dcl system_area_ptr pointer;
dcl code fixed binary (35);
dcl (used, next_nl) fixed binary (21);
dcl n_arguments fixed binary;
dcl PRINT_MOTD character (32) static options (constant) initial ("print_motd");
dcl NL character (1) static options (constant) initial ("
");
dcl CHASE fixed binary (1) static options (constant) initial (1);
dcl DELETE_OR_UNLINK bit (6) static options (constant) initial ("010110"b);
dcl SYSTEM_CONTROL_DIR character (168) static /* options (constant) */ initial (">system_control_dir");
dcl MOTD_ENAME character (32) static options (constant) initial ("message_of_the_day");
dcl DEFAULT_VALUE_SEGMENT pointer static options (constant) initial (null ());
dcl PERMANENT_VALUE bit (36) aligned static options (constant) initial ("01"b);
dcl PMOTD_VALUE_NAME character (12) static options (constant) initial ("print_motd._");
dcl error_table_$action_not_performed fixed binary (35) external;
dcl error_table_$no_s_permission fixed binary (35) external;
dcl error_table_$noentry fixed binary (35) external;
dcl error_table_$oldnamerr fixed binary (35) external;
dcl error_table_$wrong_no_of_args fixed binary (35) external;
dcl iox_$user_output pointer external;
dcl cu_$arg_count entry (fixed binary, fixed binary (35));
dcl com_err_ entry () options (variable);
dcl delete_$path entry (character (*), character (*), bit (6), character (*), fixed binary (35));
dcl get_system_free_area_ entry () returns (pointer);
dcl hcs_$status_ entry (character (*), character (*), fixed binary (1), pointer, pointer, fixed binary (35));
dcl initiate_file_ entry (character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
dcl iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl pathname_ entry (character (*), character (*)) returns (character (168));
dcl terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
dcl user_info_ entry (character (*));
dcl user_info_$homedir entry (character (*));
dcl value_$get_data
entry (pointer, bit (36) aligned, character (*), pointer, pointer, fixed binary (18), fixed binary (35));
dcl value_$get_path entry (character (*), fixed binary (35));
dcl value_$set_data
entry (pointer, bit (36) aligned, character (*), pointer, fixed binary (18), pointer, pointer,
fixed binary (18), fixed binary (35));
dcl value_$set_path entry (character (*), bit (1), fixed binary (35));
dcl cleanup condition;
dcl (addr, currentsize, divide, index, null, rtrim, unspec) builtin;
/*\014*/
call cu_$arg_count (n_arguments, code); /* insure we are invoked properly */
if code ^= 0 then do;
call com_err_ (code, PRINT_MOTD);
return;
end;
if n_arguments ^= 0 then do;
call com_err_ (error_table_$wrong_no_of_args, PRINT_MOTD, "No arguments are allowed.");
return;
end;
system_area_ptr = get_system_free_area_ ();
user_motd_ptr, system_motd_ptr = null (); /* for cleanup handler */
on condition (cleanup)
begin;
if user_motd_ptr ^= null () then free user_motd in (system_area);
if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));
end;
call get_user_motd (); /* fetch user's MOTD data from the value segment */
call get_system_motd (); /* "fetch" system's MOTD data */
if user_motd.dtcm >= system_motd_dtcm then go to RETURN_FROM_PRINT_MOTD;
/* nothing new added to system MOTD yet */
/* System MOTD has changed since this user last checked it: print any lines which do not appear in the old MOTD */
if system_motd_lth > 0 then /* don't bother if there's nothing in it */
if user_motd.lth = 0 then /* ... user hasn't seen any of it yet */
call iox_$put_chars (iox_$user_output, system_motd_ptr, system_motd_lth, (0));
else do;
used = 0;
do while (used < system_motd_lth);
begin;
dcl rest_of_system_motd character (system_motd_lth - used) unaligned defined (system_motd) position (used + 1);
next_nl = index (rest_of_system_motd, NL);
if next_nl = 0 then /* use reset of segment */
next_nl = length (rest_of_system_motd);
begin;
dcl system_motd_line character (next_nl) unaligned defined (system_motd) position (used + 1);
if index (user_motd.motd, system_motd_line) = 0 then
call iox_$put_chars (iox_$user_output, addr (system_motd_line),
length (system_motd_line), (0));
end;
used = used + next_nl;
end;
end;
end;
/* Update user's MOTD to be a copy of the current system MOTD */
free user_motd in (system_area); /* get rid of current one */
user_motd_lth = system_motd_lth;
allocate user_motd in (system_area) set (user_motd_ptr);
user_motd.dtcm = system_motd_dtcm;
user_motd.motd = system_motd;
call put_user_motd (); /* put it back into the value segment */
RETURN_FROM_PRINT_MOTD:
if user_motd_ptr ^= null () then free user_motd in (system_area);
if system_motd_ptr ^= null () then call terminate_file_ (system_motd_ptr, 0, TERM_FILE_TERM, (0));
return;
/*\014*/
/* Get the system's MOTD */
get_system_motd:
procedure ();
dcl 1 short_status aligned like status_branch.short;
dcl system_motd_bc fixed binary (24);
call initiate_file_ (SYSTEM_CONTROL_DIR, MOTD_ENAME, R_ACCESS, system_motd_ptr, system_motd_bc, code);
if code ^= 0 then do;
call com_err_ (code, PRINT_MOTD, "^a", pathname_ (SYSTEM_CONTROL_DIR, MOTD_ENAME));
go to RETURN_FROM_PRINT_MOTD;
end;
call hcs_$status_ (SYSTEM_CONTROL_DIR, MOTD_ENAME, CHASE, addr (short_status), null (), code);
if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
pathname_ (SYSTEM_CONTROL_DIR, MOTD_ENAME));
go to RETURN_FROM_PRINT_MOTD;
end;
system_motd_lth = divide ((system_motd_bc + 8), 9, 21, 0);
system_motd_dtcm = cv_fs_time (short_status.dtcm);
return;
end get_system_motd;
/* Convert a file-system date/time to a normal clock reading */
cv_fs_time:
procedure (p_time_bits) returns (fixed binary (71));
dcl p_time_bits bit (36) parameter;
dcl time fixed binary (71);
unspec (time) = (20)"0"b || p_time_bits || (16)"0"b;
return (time);
end cv_fs_time;
/*\014*/
/* Get the user's MOTD data from the value segment */
get_user_motd:
procedure ();
call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, system_area_ptr, user_motd_ptr,
(0), code);
if (code = error_table_$oldnamerr) | (code = error_table_$noentry) then do;
call convert_motd_segment ();
call value_$get_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, system_area_ptr,
user_motd_ptr, (0), code);
end;
if code ^= 0 then do; /* couldn't find it anywhere: first use of print_motd */
user_motd_lth = 0;
allocate user_motd in (system_area) set (user_motd_ptr);
user_motd.dtcm = 0;
end;
return;
/*\014*/
/* Internal to get_user_motd: converts from the old mechanism used to store per-user MOTD data to the value segment. The
old mechanism was a segment named Person_id.motd in the user's home directory which contained the text of the last MOTD
seen; the DTCM of the segment was used to compare against that of the system MOTD */
convert_motd_segment:
procedure ();
dcl 1 short_status aligned like status_branch.short;
dcl home_dir character (168);
dcl person_id character (24);
dcl old_user_motd character (user_motd_lth) based (old_user_motd_ptr);
dcl old_user_motd_bc fixed binary (24);
dcl old_user_motd_ptr pointer;
dcl old_user_motd_ename character (32);
call user_info_$homedir (home_dir);
call user_info_ (person_id);
old_user_motd_ename = rtrim (person_id) || ".motd";
old_user_motd_ptr = null (); /* for cleanup handler */
on condition (cleanup)
begin;
if old_user_motd_ptr ^= null () then
call terminate_file_ (old_user_motd_ptr, 0, TERM_FILE_TERM, (0));
end;
call initiate_file_ (home_dir, old_user_motd_ename, R_ACCESS, old_user_motd_ptr, old_user_motd_bc, code);
if code ^= 0 then return; /* no old-style MOTD segment */
call hcs_$status_ (home_dir, old_user_motd_ename, CHASE, addr (short_status), null (), code);
if (code ^= 0) & (code ^= error_table_$no_s_permission) then do;
call com_err_ (code, PRINT_MOTD, "Determining date-time modified of ^a.",
pathname_ (home_dir, old_user_motd_ename));
short_status.dtcm = ""b; /* assume it's very old */
end;
user_motd_lth = divide ((old_user_motd_bc + 8), 9, 21, 0);
allocate user_motd in (system_area) set (user_motd_ptr);
user_motd.dtcm = cv_fs_time (short_status.dtcm);
user_motd.motd = old_user_motd;
call put_user_motd (); /* returns only if OK */
call delete_$path (home_dir, old_user_motd_ename, DELETE_OR_UNLINK, PRINT_MOTD, code);
if code = 0 then old_user_motd_ptr = null ();/* no longer exists */
else if code = error_table_$action_not_performed then
call com_err_ (0, PRINT_MOTD, "^a is no longer used by this command and should be deleted.",
pathname_ (home_dir, old_user_motd_ename));
else call com_err_ (code, PRINT_MOTD, "Deleting ^a.", pathname_ (home_dir, old_user_motd_ename));
return;
end convert_motd_segment;
end get_user_motd;
/*\014*/
/* Put the updated MOTD data into the user's value segment */
put_user_motd:
procedure ();
call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, user_motd_ptr,
currentsize (user_motd), null (), (null ()), (0), code);
if code = error_table_$noentry then do; /* value segment not present: try to create it */
call create_default_value_segment ();
call value_$set_data (DEFAULT_VALUE_SEGMENT, PERMANENT_VALUE, PMOTD_VALUE_NAME, user_motd_ptr,
currentsize (user_motd), null (), (null ()), (0), code);
end;
if code ^= 0 then do; /* abort the whole thing if this fails */
call com_err_ (code, PRINT_MOTD,
"Attempting to update message-of-the-day information in default value segment.");
go to RETURN_FROM_PRINT_MOTD;
end;
return;
/* Internal to put_user_motd: create the default value segment (if possible) */
create_default_value_segment:
procedure ();
dcl value_segment_path character (168);
call value_$set_path ("", "1"b, code);
if code = 0 then do; /* created it */
call value_$get_path (value_segment_path, (0));
call com_err_ (0, PRINT_MOTD, "Created ^a.", value_segment_path);
end;
return;
end create_default_value_segment;
end put_user_motd;
/*\014*/
%include access_mode_values;
%include terminate_file;
%page;
%include status_structures;
end print_motd;
\014
resource_usage.pl1 03/24/82 1351.3rew 03/24/82 1338.7 147411
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
/* RESOURCE_USAGE - Procedure to print user's monthly (to date) resource usage and resource limits.
This procedure gets this info from the user's PIT, where cpg_ put it.
This procedure is called in any of four modes:
1) long mode (specify the control_arg -long or -lg);
this prints the month-to-date charges, resource limits, interactive usage for all shifts,
absentee usage in all queues, and io daemon usage in all queues.
2) default mode (called with no control_arg)
this lists the month-to-date charge, the resource limit, the interactive usage for all shifts, and the
absentee and io daemon usage for all queues.
3) brief mode (called specifying the control_arg -brief or -bf)
this lists the month-to-date charge, the resource limit, and totals for interactive,
absentee and io daemon usage.
4) totals mode (called specifying the control_arg -totals or -tt )
this lists just the month-to-date charge and the resource limit.
J. Phillipps and THVV - June 1972
J. Phillipps - revised and upgraded for version 2 PL/1 September 1972
. - revised for memory and virtual cpu charging on 6180 March 1973
. - updated headers and added absolute limit reporting a la sipb April 1976.
T. Casey - August 1977 - to only print nonzero device charges and to print some new ones.
C. Hornig - June 1979 - to print usage even if charge was zero.
E. N. Kittlitz - June 1981 - UNCA rate structure changes
*/
resource_usage: ru: procedure;
dcl crashes char (8) aligned,
answer char (46) varying,
answer1 char (47) varying,
answer2 char (29) varying,
answer3 char (18) varying,
j fixed bin,
logins char (7) aligned,
datestr char (16) aligned,
pit_name char (32) int static init ("pit"),
reset char (16) aligned; /* formatted string for time last reset PDT */
dcl an fixed bin init (1),
al fixed bin (21),
nargs fixed bin,
absolute bit (1) init ("0"b),
cutoff bit (1) init ("0"b),
month bit (1) init ("0"b),
ec fixed bin (35),
(i, ii) fixed bin,
mode fixed bin init (3),
temp float bin init (0e0);
dcl (pp, ap) ptr;
dcl bchr char (al) unaligned based (ap);
dcl dev_usage_buffer char (160); /* stuff for printing device usage */
dcl dub_array (160) char (1) unal based (addr (dev_usage_buffer));
dcl dubp ptr;
dcl dubl fixed bin;
dcl based_dub char (dubl) based (dubp);
dcl (dubi, retlen) fixed bin;
dcl devh char (8) varying;
dcl dusw (16) bit (1) aligned;
dcl rs_name char (32) aligned;
dcl max_rs_number fixed bin;
dcl ndevices fixed bin;
dcl 1 dvt (16) aligned,
2 device_id char (8),
2 device_price (0:7) float bin;
dcl MILLION fixed bin (35) internal static init (1000000),
prettybigfloat float bin int static init (1e36);
dcl increment (0:5) char (12) aligned initial
("never", "daily", "monthly", "yearly", "calendar_yr", "fiscal_yr");
dcl (addr, divide, float, length, mod, null, rtrim, substr) builtin;
/* procedures called by this program */
dcl com_err_ entry options (variable),
cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
cu_$arg_count entry (fixed bin, fixed bin (35)),
date_time_ entry (fixed bin (71), char (*) aligned),
get_pdir_ entry () returns (char (168)),
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),
ioa_$rsnnl entry options (variable); /* ctl,retstr,retlen,args */
dcl system_info_$device_prices entry (fixed bin, ptr);
dcl system_info_$rs_name entry (fixed bin, char (*) aligned, fixed bin (35));
dcl system_info_$max_rs_number entry (fixed bin);
dcl error_table_$badopt fixed bin (35) ext;
dcl error_table_$too_many_args fixed bin (35) ext;
%include user_attributes;
%include pit;
\014
/* ====================================================== */
call system_info_$max_rs_number (max_rs_number);
call hcs_$initiate ((get_pdir_ ()), pit_name, "", 0, 1, pp, ec); /* get ptr to PIT in process dir */
if pp = null then do;
call com_err_ (ec, "resource_usage", "pit");
return;
end;
call cu_$arg_count (nargs, ec);
if ec ^= 0 then go to argerr;
if nargs > 1 then do;
call com_err_ (error_table_$too_many_args, "resource_usage", "This command only takes one argument.");
return;
end;
do an = 1 to nargs;
call cu_$arg_ptr (an, ap, al, ec); /* see which option was specified */
if ec ^= 0 then go to argerr;
/* default mode = 3 */
else if bchr = "-long" then mode = 2; /* if arg specifies long option, set mode */
else if bchr = "-lg" then mode = 2;
else if bchr = "-brief" then mode = 1; /* if arg specifies brief option, set mode accordingly */
else if bchr = "-bf" then mode = 1;
else if bchr = "-tt" | bchr = "-totals" | bchr = "-total" then mode = 0;
/* if no arg, default mode is an expanded form of brief */
else do;
call com_err_ (error_table_$badopt, "resource_usage", """^a""", bchr);
return;
end;
end;
if mode = 0 then do; /* total mode is specified */
call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
/* if cutoff set by proj administrator, print it also */
if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
call ioa_ ("^/^a", answer || answer3);
end;
else do;
call ioa_$rsnnl ("Total: $^9.2f; Absolute Limit: $^9a; ",
answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
call date_time_ (pp -> pit.absolute_cutoff, datestr);
call ioa_$rsnnl ("Reset: ^a, ^a;",
answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
call ioa_ ("^/^a", answer);
call ioa_ (answer1 || answer2);
end;
goto endit1;
end;
call date_time_ (pp -> pit.proc_creation_time, datestr); /* usage from beginning of mo. to time process created */
call date_time_ (pp -> pit.time_last_reset, reset); /* format time last reset PDT */
call ioa_ ("^/^a.^a Report from ^a to ^a", pp -> pit.login_name, pp -> pit.project, reset, datestr);
if max_rs_number > 0 then do;
call system_info_$rs_name ((pp -> pit.rs_number), rs_name, ec);
if ec ^= 0 then call com_err_ (ec, "resource_usage",
"For rate structure ^d. Contact your system administrator.", pp -> pit.rs_number);
call ioa_ ("^5xRate Structure -- ^a", rs_name);
end;
quick:
if mode = 2 then do; /* long mode */
if substr ((cv_limit (pp -> pit.absolute_limit)), 6) = "open" then do;
call ioa_$rsnnl ("Month-to-Date: $^9.2f; Limit: $^9a; ",
answer, j, pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
call ioa_$rsnnl ("Total: $^9.2f;", answer3, j, pp -> pit.absolute_spent);
call ioa_ (answer || answer3);
end;
else do;
call ioa_$rsnnl ("Total: $^9.2f, Absolute Limit: $^9a; ",
answer1, j, pp -> pit.absolute_spent, (cv_limit (pp -> pit.absolute_limit)));
call date_time_ (pp -> pit.absolute_cutoff, datestr);
call ioa_$rsnnl ("Reset: ^a, ^a;",
answer2, j, substr (datestr, 1, 8), increment (pp -> pit.absolute_increm));
call ioa_ (answer1 || answer2);
end;
end;
else do;
call ioa_ ("Month-To-Date: $^9.2f; Limit: $^9a;",
pp -> pit.dollar_charge, (cv_limit (pp -> pit.dollar_limit)));
end;
do i = 1 to 7, 0; /* sum interactive charge */
temp = temp + pp -> pit.interactive (i).charge;
end;
if temp = 0e0 then do; /* if no usage, don't print header */
call ioa_ ("^/Interactive Usage: none;");
go to abstee;
end;
/* P R I N T H E A D E R S */
if pp -> pit.crashes = 1 then
crashes = "crash. "; /* do singular and plural parse */
else crashes = "crashes.";
if pp -> pit.logins = 1 then
logins = "login, ";
else logins = "logins,";
if mode = 2 then do; /* long mode header for interactive usage */
call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
call ioa_ ("^4xshift^2x$charge^4x$limit^8xvcpu^4xconnect^4xterminal i/o^2xmemory/kmu");
end;
else if mode = 1 then do; /* brief mode header for interactive usage */
call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
go to abstee;
end;
else if mode = 3 then do; /* default mode */
call ioa_ ("^/Interactive Usage: $^8.2f;^2x^2d^1x^8a^2d^1x^7a",
temp, pp -> pit.logins, logins, pp -> pit.crashes, crashes);
call ioa_ ("^4xshift^2x$charge^4x$limit");
end;
temp = 0e0; /* clear temp */
/* P R I N T R E S O U R C E U S A G E */
/* print out resource usage */
do i = 1 to 7, 0;
if pp -> pit.shift_limit (i) > prettybigfloat
then if pp -> pit.interactive (i).charge = 0e0
& pp -> pit.interactive (i).cpu = 0
& pp -> pit.interactive (i).connect = 0
& pp -> pit.interactive (i).core = 0
& pp -> pit.interactive (i).io_ops = 0
then goto skip; /* don't print useless lines */
if mode = 2 then do; /* long mode */
call ioa_ ("^5x^1d^4x^8.2f^1x^9a^3x^9a^2x^9a^5x^11.1f^1x^11.1f", i,
pp -> pit.interactive (i).charge, (cv_limit (pp -> pit.shift_limit (i))),
(cv_time (pp -> pit.interactive (i).cpu)), (cv_time (pp -> pit.interactive (i).connect)),
float (pp -> pit.interactive (i).io_ops/1e3), float (pp -> pit.interactive (i).core/1e6));
end;
else if mode = 3 then do; /* default mode */
call ioa_ ("^5x^1d^4x^8.2f^1x^9a", i, pp -> pit.interactive (i).charge,
(cv_limit (pp -> pit.shift_limit (i))));
skip2: end;
skip: end;
abstee: temp = 0e0; /* clear temp */
do ii = 1 to 4; /* scan for absentee usage */
temp = temp + pp -> pit.absentee (ii).charge;
end;
if temp = 0e0 then do;
call ioa_ ("^/Absentee Usage: none;");
go to iod;
end;
else call ioa_ ("^/Absentee Usage: $^8.2f;", temp);
if mode = 1 then go to iod; /* brief mode exit here */
else if mode = 3 then do; /* default mode */
call ioa_ ("^4xqueue^2x$charge^6xjobs");
do ii = 1 to 4;
if pp -> pit.absentee (ii).charge = 0e0 then go to next;
call ioa_ ("^5x^1d^4x^8.2f^6x^4d", ii, pp -> pit.absentee (ii).charge, pp -> pit.absentee (ii).jobs);
next: end;
end;
if mode = 2 then do; /* long mode */
call ioa_ ("^4xqueue^2x$charge^6xjobs^8xvcpu^2xmemory/kmu");
do ii = 1 to 4;
if pp -> pit.absentee (ii).charge = 0e0 then go to skip3;
call ioa_ ("^5x^1d^4x^8.2f^6x^4d^3x^9a^2x^10.1f", ii, pp -> pit.absentee (ii).charge,
pp -> pit.absentee (ii).jobs, cv_time (pp -> absentee (ii).cpu),
float (pp -> pit.absentee (ii).memory/1e6));
skip3: end;
end;
iod: temp = 0e0;
do ii = 1 to 4;
temp = temp + pp -> pit.iod (ii).charge;
end;
if temp = 0e0 then do;
call ioa_ ("^/IO Daemon Usage: none;");
go to device;
end;
else call ioa_ ("^/IO Daemon Usage: $^8.2f;", temp);
if mode = 1 then go to device; /* brief mode exit here */
else if mode = 3 then do; /* default mode */
call ioa_ ("^4xqueue^2x$charge^6xlines");
do ii = 1 to 4;
if pp -> pit.iod (ii).charge = 0e0 then go to next2;
call ioa_ ("^4x^1x^1d^4x^8.2f^x^10d",
ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).lines);
next2: end;
end;
if mode = 2 then do; /* long mode */
call ioa_ ("^4xqueue^2x$charge^4xpieces^7xpages^8xlines");
do ii = 1 to 4;
if pp -> pit.iod (ii).charge = 0e0 then go to skip4;
call ioa_ ("^4x^1x^1d^4x^8.2f^6x^4d^3x^9d^x^12d",
ii, pp -> pit.iod (ii).charge, pp -> pit.iod (ii).pieces,
pp -> pit.iod (ii).pages, pp -> pit.iod (ii).lines);
skip4: end;
end;
device: temp = 0e0; /* clear temp */
do ii = 1 to 16; /* scan for device usage */
if pp -> pit.devices (ii) = 0e0
then dusw (ii) = ""b;
else dusw (ii) = "1"b;
temp = temp + pp -> pit.devices (ii);
end;
if temp = 0e0 then do;
if mode = 2 then
call ioa_ ("^/Device Usage: none;"); /* only print in long mode */
end;
else do;
call ioa_ ("^/Device Usage: $^8.2f;", temp);
/* The purpose of the following code is to print a column only for devices with nonzero usage. */
call system_info_$device_prices (ndevices, addr (dvt)); /* get device names and prices (but only use names) */
dev_usage_buffer = ""; /* clear buffer before making heading */
dubi = 1; /* set index to first character position in buffer */
do i = 1 to 16; /* put each device name in heading */
if dusw (i) then do; /* but only if it has nonzero usage */
devh = rtrim (device_id (i)); /* copy name and see how long it really is */
dubi = dubi + 9 - length (devh); /* compute how far to skip to right-adjust name */
substr (dev_usage_buffer, dubi, 1) = "$"; /* put in leading dollar sign */
substr (dev_usage_buffer, dubi+1, length (devh)) = devh; /* put in the name */
dubi = dubi + 1 + length (devh); /* advance char index past name */
end;
end;
call ioa_ ("^a", dev_usage_buffer); /* print the heading */
dev_usage_buffer = ""; /* clear buffer before formatting usage figures */
dubl = length (dev_usage_buffer); /* initialize char counters */
dubi = 1;
do i = 1 to 16; /* print usage for each device */
if dusw (i) then do; /* only if it is nonzero */
dubp = addr (dub_array (dubi)); /* get addr of where to put next usage field */
call ioa_$rsnnl ("^3x^7.2f", based_dub, retlen, pp -> pit.devices (i)); /* format the usage figure */
dubl = dubl - retlen; /* decrement remaining length of buffer */
dubi = dubi + retlen; /* advance index to next available character position */
end;
end;
call ioa_ ("^a", dev_usage_buffer); /* print the usage figures */
end;
endit: call ioa_ ("");
endit1: call hcs_$terminate_noname (pp, ec);
return;
argerr: call com_err_ (ec, "resource_usage");
return;
\014
/* =========================================================== */
cv_time: procedure (time) returns (char (9) aligned);
/* procedure to convert from fixed bin (71) to a nice formatted string of hrs: mins: secs */
dcl time fixed bin (71),
j fixed bin,
hours fixed bin,
minutes fixed bin,
seconds fixed bin,
answer char (9) aligned;
seconds = divide (time, MILLION, 35, 0);
minutes = divide (seconds, 60, 35, 0);
seconds = mod (seconds, 60); /* get rid of the remainder */
hours = divide (minutes, 60, 35, 0);
minutes = mod (minutes, 60); /* get rid of the remainder */
call ioa_$rsnnl ("^3d:^2d:^2d", answer, j, hours, minutes, seconds);
if substr (answer, 5, 1) = " " then substr (answer, 5, 1) = "0";
if substr (answer, 8, 1) = " " then substr (answer, 8, 1) = "0";
return (answer);
end;
\014
/* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = */
cv_limit: procedure (limit) returns (char (9) aligned);
/* procedure to convert a float bin $limit into either the string, "open", if $limit is >= 1e37,
or to convert a float bin $limit into an integer $limit */
dcl limit float bin,
lim char (9) aligned,
jj fixed bin,
itemp fixed bin;
if limit >= prettybigfloat then do;
lim = " open";
go to char;
end;
else do;
itemp = limit;
call ioa_$rsnnl ("^6d.00", lim, jj, itemp);
end;
char: return (lim);
end;
test_ru: entry (xpit); /* enter here if using an experimental PIT */
dcl xpit char (*);
pit_name = xpit;
end resource_usage;
\014
ring0_get_.pl1 11/28/77 1537.3rew 11/28/77 1516.6 52101
/* ******************************************************
* *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
* *
****************************************************** */
ring0_get_: proc;
/* "Adjusted" by Bernard Greenberg, for hc def seg 07/22/76 */
dcl (sltp1, names_ptr1, defs_ptr1) ptr static init (null),
(names_ptr2, defs_ptr2) ptr,
(a_defsp, a_sltp, a_namep, defp, defsp) ptr,
(i, j) fixed bin,
hcs_$initiate ext entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin),
get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin);
dcl based_bit18 bit (18) aligned based dim (0:511);
dcl a_defname char (*),
a_offset fixed bin (18),
a_type fixed bin;
dcl (error_table_$no_defs, error_table_$noentry) fixed bin (35) ext;
dcl error_table_$invalidsegno fixed bin (35) ext;
dcl segptr ptr,
code fixed bin,
entryptr ptr,
dir char (*),
entry char (*);
dcl SLDIR char (55) init (">system_library_1") static options (constant);
dcl (addr, addrel, baseno, baseptr, fixed, length, null, reverse, verify) builtin;
/* \014 */
segptr: entry (dir, entry, segptr, code); /* entry to return segment pointer */
call get_static_ptrs ("0"b);
segptr = get_segptr ();
return;
name: entry (dir, entry, segptr, code); /* entry to return segment name */
call get_static_ptrs ("0"b);
call get_name (segptr, "0"b); /* 0 => one */
return;
names: entry (dir, entryptr, segptr, code); /* entry to return pointer to names */
call get_static_ptrs ("0"b);
call get_name (segptr, "1"b); /* 1 => many */
return;
definition: entry (segptr, entry, a_defname, a_offset, a_type, code);
call get_static_ptrs ("1"b); /* 1 => get defs ptr */
if segptr = null then segptr = get_segptr ();
call get_definition (segptr);
return;
/* The following entries are the same as the above except that the caller
supplies a pointer to the SLT and NAME TABLE to use */
segptr_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);
call get_param_ptrs ("0"b);
segptr = get_segptr ();
return;
name_given_slt: entry (dir, entry, segptr, code, a_sltp, a_namep);
call get_param_ptrs ("0"b);
call get_name (segptr, "0"b);
return;
definition_given_slt: entry (segptr, entry, a_defname, a_offset, a_type, code, a_sltp, a_namep, a_defsp);
call get_param_ptrs ("1"b);
if segptr = null then segptr = get_segptr (); /* Look up entry if needed */
call get_definition (segptr);
return;
/* \014 */
get_static_ptrs: proc (we_want_defs);
dcl we_want_defs bit (1) aligned; /* T => call for defs */
code = 0;
if we_want_defs & defs_ptr1 = null then call init_static_ptrs;
else if names_ptr1 = null then call init_static_ptrs;
if code ^= 0 then go to error;
sltp = sltp1;
names_ptr2 = names_ptr1;
defs_ptr2 = defs_ptr1;
return;
init_static_ptrs: proc;
call hcs_$initiate (SLDIR, "slt", "", 0, 1, sltp1, code);
if sltp1 = null then return;
call hcs_$initiate (SLDIR, "name_table", "", 0, 1, names_ptr1, code);
if names_ptr1 = null then return;
if we_want_defs then do;
call hcs_$initiate (SLDIR, "definitions_", "", 0, 1, defs_ptr1, code);
if defs_ptr1 = null then return;
end;
code = 0; /* Let's hear it for hcs_$initiate! */
end init_static_ptrs;
end get_static_ptrs;
get_param_ptrs: proc (we_want_defs);
dcl we_want_defs bit (1) aligned; /* We want definitions */
sltp = a_sltp;
names_ptr2 = a_namep;
if we_want_defs then defs_ptr2 = a_defsp;
end get_param_ptrs;
get_segptr: procedure returns (ptr);
do i = slt.first_sup_seg to slt.last_sup_seg; /* loop through sup segs searching */
sltep = addr (slt.seg (i)); /* get pointer to SLT entry */
namep = addrel (names_ptr2, slte.names_ptr); /* get pointer to names for this segment */
do j = 1 to namep -> segnam.count; /* search all names */
if entry = namep -> segnam.names (j).name then do; /* found it */
code = 0;
return (baseptr (i));
end;
end;
end;
code = error_table_$noentry;
go to error_segptr;
end get_segptr;
get_name: procedure (sp, many);
dcl many bit (1) aligned, sp ptr;
i = bin (baseno (sp)); /* get input segment number */
if i > slt.last_sup_seg | i < slt.first_sup_seg then do; /* bad input segment number */
code = error_table_$invalidsegno;
return;
end;
sltep = addr (slt.seg (i)); /* get pointer to SLT entry */
pathp = addrel (names_ptr2, slte.path_ptr);
namep = addrel (names_ptr2, slte.names_ptr);
if pathp ^= names_ptr2 then dir = pathp -> path.name; else dir = ""; /* return path name */
if many then entryptr = namep;
else entry = namep -> segnam.names (1).name; /* return only one name */
code = 0;
end get_name;
get_definition: procedure (textp);
dcl textp ptr;
code = 0;
i = bin (baseno (textp));
if i < 4 | i > 511 then code = error_table_$no_defs;
else do;
defsp = addrel (defs_ptr2, defs_ptr2 -> based_bit18 (i));
if defsp = defs_ptr2 then code = error_table_$no_defs;
else do;
call get_definition_ (defsp, entry, a_defname, defp, code);
if code = 0 then do;
a_type = fixed (defp -> definition.class, 3);
a_offset = fixed (defp -> definition.value, 18);
end;
end;
end;
end get_definition;
error_segptr: segptr = null;
error: return;
/* \014 */
% include slt;
% include slte;
% include definition;
end;
\014
system_info_.pl1 08/12/83 1303.1r 08/12/83 1136.7 175644
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
system_info_: proc;
/* SYSTEM_INFO_ - return various information to user about Multics.
The information is obtained from the header of "whotab"
or from "installation_parms" or from the correct "rate_structure_x" seg.
See AG93 (Multics Subroutines and Input/Output Modules) for documentation
of the following entries:
$id (installation_id)
$sysid (sysid)
$version_id
$titles (company, dept, companyds, deptds)
$users (maxusers, nusers, maxunits, nunits)
$timeup (time)
$prices (cpu, log, process, core, disk, registration)
$prices_rs (rs_number, cpu, log, process, core, disk, registration)
$device_prices (ndevices, addr (dvt))
$device_prices_rs (rs_number, ndevices, addr (dvt))
$abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits)
$abs_prices (farray)
$default_absentee_queue (default_queue)
$abs_prices_rs (rs_number, farray)
$io_prices (farray)
$io_prices_rs (rs_number, farray)
$next_shutdown (time, reason, until)
$last_shutdown (time, erfno)
$shift_table (stt)
$access_ceiling (access_ceiling)
$level_names (long_names, short_names)
$category_names (long_names, short_names)
$log_threshold (state, npages)
$next_shift_change (cur_shift, change_time, new_shift, start_time)
$ARPANET_host_number (host_num)
$resource_price (price_name, price, code)
$resource_price_rs (rs_number, price_name, price, code)
$rs_name (rs_number, rs_name, code)
$rs_number (rs_name, rs_number, code)
$max_rs_number (rs_count)
See AN-66 (AS PLM) for documentation of the following internal interfaces:
$abs_chn (evchn, pid)
$request_chn (pid, event_channel, mseg_dname, mseg_ename)
Written by THVV
Modified 741231 by PG to add entries for new AIM fields.
Modified 750324 by PG to rename $dial_chn to $request_chn.
Modified 750912 by PG to give request facility its own process id.
Modified 751103 by PG to complain if can't initiate whotab/installation_parms.
Modified April 1976 by T. Casey to return shift start time as fourth argument to next_shift_change entry point.
Modified 761229 by D. M. Wells to add $ARPANET_host_number entry point.
Modified May 1978 by T. Casey to add resource_price entry point.
Modified November 1978 by T. Casey for MR7.0 to add arguments to abs_limits entry point.
Modified July 1979 by J. N. R. Barnecut for MR8.0 to add rate_structure entry points. (UNCA)
Modified Feb 1980 by M. B. Armstrong for further changes re rate_structure. (UNCA)
Modified 17 September 1980 by G. Palter to add default_absentee_queue entrypoint.
Modified June 1981 by E. N. Kittlitz for UNCA rate structures.
Modified May 1983 by Art Beattie to add version_id entry.
*/
return;
/* parameters */
dcl rs_number fixed bin,
rs_name char (*),
ndev fixed bin,
devp ptr;
/* external variables */
dcl error_table_$no_entry ext fixed bin (35);
/* entries */
dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35));
dcl active_all_rings_data$version_id ext char (8);
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 datebin_$next_shift_change entry (fixed bin (71), fixed bin (71), fixed bin, fixed bin);
dcl get_pdir_ entry () returns (char (168));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
/* automatic */
dcl ap ptr, /* ptr to arg */
al fixed bin, /* lth of arg */
arg_offset fixed bin,
cur_rs_ptr ptr init (null),
ec fixed bin (35),
nargs fixed bin,
(i, j) fixed bin,
t71 fixed bin (71),
(t1, t2) fixed bin;
/* based */
dcl bchr char (al) based (ap), /* character arg */
bfix fixed bin (35) based (ap), /* fixed bin arg */
bflo float bin (27) based (ap), /* float bin arg */
b71 fixed bin (71) based (ap), /* dbl prec arg */
b36 bit (36) aligned based (ap), /* bit (36) arg */
bfa (0: 7) float bin (27) based (ap), /* float array arg */
based_fixed_array (4) fixed bin (35) based (ap), /* fixed array arg */
based_shift_queue_array (0:7, 4) fixed bin (35) based (ap); /* array arg for per-shift-and-queue absentee parms */
/* internal static */
dcl (whoptr, pp) ptr int static init (null);
dcl rs_ptrs (0:9) ptr int static init ((10) null);
dcl ip ptr defined (rs_ptrs (0));
dcl sysdir char (168) int static init (">system_control_1");
/* builtins */
dcl (char, clock, fixed, hbound, ltrim, max, null) builtin;
/* include files */
%include installation_parms;
%include rate_structure;
%include whotab;
%include pitmsg;
%include user_attributes;
/* ======================================================== */
installation_id: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec); /* Get ptr to string argument. */
if ec ^= 0 then return;
bchr = installation_parms.installation_id;
return;
/* -------------------------------------------------------- */
sysid: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bchr = whotab.sysid;
return;
/* -------------------------------------------------------- */
version_id:
entry;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bchr = active_all_rings_data$version_id;
return;
/* -------------------------------------------------------- */
titles: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bchr = installation_parms.company;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
bchr = installation_parms.department;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0 then return;
bchr = installation_parms.companyds;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0 then return;
bchr = installation_parms.departmentds;
return;
/* -------------------------------------------------------- */
users: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bfix = whotab.mxusers;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
bfix = whotab.n_users;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0 then return;
bfix = whotab.mxunits;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0 then return;
bfix = whotab.n_units;
return;
/* -------------------------------------------------------- */
timeup: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
b71 = whotab.timeup;
return;
/* -------------------------------------------------------- */
next_shutdown: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
b71 = whotab.nextsd;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
if whotab.why < "" then bchr = "";
else bchr = whotab.why;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0 then return;
b71 = whotab.until;
return;
/* -------------------------------------------------------- */
last_shutdown: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
b71 = whotab.lastsd;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
bchr = whotab.erfno;
return;
/* -------------------------------------------------------- */
rates:
prices: entry;
call setup_user_rs;
arg_offset = 0;
rates_join:
call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
if ec ^= 0 then return;
do i = 0 to 7;
bfa (i) = rate_structure.cpu_price (i);
end;
call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
if ec ^= 0 then return;
do i = 0 to 7;
bfa (i) = rate_structure.log_base_price (i);
end;
call cu_$arg_ptr (arg_offset + 3, ap, al, ec);
if ec ^= 0 then return;
do i = 0 to 7;
bfa (i) = rate_structure.io_ops_price (i);
end;
call cu_$arg_ptr (arg_offset + 4, ap, al, ec);
if ec ^= 0 then return;
do i = 0 to 7;
bfa (i) = rate_structure.core_price (i);
end;
call cu_$arg_ptr (arg_offset + 5, ap, al, ec);
if ec ^= 0 then return;
bflo = rate_structure.disk_price;
call cu_$arg_ptr (arg_offset + 6, ap, al, ec);
if ec ^= 0 then return;
bflo = rate_structure.registration_price;
return;
/* -------------------------------------------------------- */
rates_rs:
prices_rs: entry (rs_number);
call setup_rs (rs_number);
arg_offset = 1;
go to rates_join;
/* -------------------------------------------------------- */
device_rates:
device_prices: entry (ndev, devp);
dcl 1 dvt (16) aligned based,
2 device_id char (8),
2 device_price (0: 7) float bin;
call setup_user_rs;
arg_offset = 0;
device_rates_join:
ndev = rate_structure.ndevices;
call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
if ec ^= 0 then return;
if devp ^= null then do i = 1 to rate_structure.ndevices;
devp -> dvt.device_id (i) = rate_structure.devtab.device_id (i);
do j = 0 to 7;
devp -> dvt.device_price (i, j) = rate_structure.devtab.device_price (i, j);
end;
end;
return;
/* -------------------------------------------------------- */
device_rates_rs:
device_prices_rs: entry (rs_number, ndev, devp);
call setup_rs (rs_number);
arg_offset = 1;
go to device_rates_join;
/* -------------------------------------------------------- */
/* dcl system_info_$abs_limits ((4) fixed bin (35), fixed bin (35), (0:7,4) fixed bin (35));
call system_info_$abs_limits (default_cpu_limits, default_foreground_cpu_limit, max_cpu_limits); */
abs_limits:
entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
based_fixed_array (*) = installation_parms.abs_cpu_default_limit (*);
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
bfix = installation_parms.foreground_cpu_default_limit;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0 then return;
based_shift_queue_array (*, *) = installation_parms.abs_cpu_max_limit (*, *);
return;
/* -------------------------------------------------------- */
default_absentee_queue: entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bfix = installation_parms.default_absentee_queue;
return;
/* -------------------------------------------------------- */
abs_prices: entry;
call setup_user_rs;
arg_offset = 0;
abs_prices_join:
call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
if ec ^= 0 then return;
do i = 1 to 4;
bfa (i-1) = rate_structure.abs_cpu_price (i);
end;
call cu_$arg_ptr (arg_offset + 2, ap, al, ec);
if ec ^= 0 then return;
do i = 1 to 4;
bfa (i-1) = rate_structure.abs_mem_price (i);
end;
return;
/* -------------------------------------------------------- */
abs_prices_rs: entry (rs_number);
call setup_rs (rs_number);
arg_offset = 1;
go to abs_prices_join;
/* -------------------------------------------------------- */
io_prices: entry;
call setup_user_rs;
arg_offset = 0;
io_prices_join:
call cu_$arg_ptr (arg_offset + 1, ap, al, ec);
if ec ^= 0 then return;
do i = 1 to 4;
bfa (i-1) = rate_structure.iod_rec_price (i);
end;
return;
/* --------------------------------------------------------- */
io_prices_rs: entry (rs_number);
call setup_rs (rs_number);
arg_offset = 1;
go to io_prices_join;
/* ------------------------------------------------------- */
abs_chn: entry (ev, pid);
dcl ev fixed bin (71), pid bit (36);
if whoptr = null then call setup;
call cu_$arg_count (nargs);
ev = whotab.abs_event;
if nargs > 1 then pid = whotab.abs_procid;
return;
/* ------------------------------------------------------ */
next_shift_change: entry (curshft, shftime, newshft, starttime);
dcl (curshft, newshft) fixed bin, (shftime, starttime) fixed bin (71);
call cu_$arg_count (nargs);
call datebin_$next_shift_change ((clock ()), t71, t1, t2);
curshft = t1;
if nargs > 1 then shftime = t71;
if nargs > 2 then newshft = t2;
if nargs > 3 then do;
if whoptr = null then call setup;
starttime = whotab.last_shift_change_time;
end;
return;
/* -------------------------------------------------------- */
shift_table: entry (stt);
dcl stt (336) fixed bin;
if whoptr = null then call setup;
do i = 1 to 336;
stt (i) = fixed (installation_parms.shifttab (i), 3);
end;
return;
/* -------------------------------------------------------- */
request_chn:
entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
b36 = whotab.request_process_id;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0 then return;
b71 = whotab.request_channel;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0 then return;
bchr = sysdir;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0 then return;
bchr = "as_request.ms";
return;
/* -------------------------------------------------------- */
access_ceiling:
entry (access_ceiling);
dcl access_ceiling bit (72) aligned;
if whoptr = null then call setup;
access_ceiling = installation_parms.access_authorization_ceiling;
return;
/* -------------------------------------------------------- */
log_threshold:
entry;
dcl (state char (al), npages fixed bin) based (ap);
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
i = installation_parms.syserr_log_copy_threshold;
if i < 0 then state = "off";
else if i = 0 then state = "default";
else state = "on";
call cu_$arg_ptr (2, ap, al, ec);
if ec = 0 then npages = max (i, 0);
return;
/* -------------------------------------------------------- */
level_names:
entry;
dcl (long_level_names char (32), short_level_names char (8)) dim (0:7) based (ap);
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
long_level_names (*) = installation_parms.level_names (*);
call cu_$arg_ptr (2, ap, al, ec);
if ec = 0 then short_level_names (*) = installation_parms.short_level_names (*);
return;
/* -------------------------------------------------------- */
category_names:
entry;
dcl (long_category_names char (32), short_category_names char (8)) dim (18) based (ap);
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
long_category_names (*) = installation_parms.category_names (*);
call cu_$arg_ptr (2, ap, al, ec);
if ec = 0 then short_category_names (*) = installation_parms.short_category_names (*);
return;
/* -------------------------------------------------------- */
ARPANET_host_number:
entry;
if whoptr = null then call setup;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0 then return;
bfix = installation_parms.ARPANET_host_number;
return;
/* -------------------------------------------------------- */
resource_price: entry (a_price_name, a_price, a_code);
dcl a_price_name char (*);
dcl a_price float bin;
dcl a_code fixed bin (35);
dcl error_table_$noentry ext fixed bin (35);
call setup_user_rs;
resource_price_join:
do i = 1 to rate_structure.nrscp;
if a_price_name = rate_structure.resource (i).name then do;
a_price = rate_structure.resource (i).price;
a_code = 0;
return;
end;
end;
a_code = error_table_$noentry;
a_price = 0;
return;
/* -------------------------------------------------------- */
resource_price_rs: entry (rs_number, a_price_name, a_price, a_code);
call setup_rs (rs_number);
go to resource_price_join;
/* -------------------------------------------------------- */
rs_name: entry (rs_number, rs_name, a_code);
if whoptr = null then call setup;
if rs_number < 0 | rs_number > whotab.n_rate_structures then do;
a_code = error_table_$noentry;
rs_name = " INVALID_RS_" || ltrim (char (rs_number)); /* leading space so it won't match any name */
end;
else do;
a_code = 0;
rs_name = installation_parms.rate_structures (rs_number);
end;
return;
/* --------------------------------------------------------- */
rs_number: entry (rs_name, rs_number, a_code);
if whoptr = null then call setup;
do i = 0 to whotab.n_rate_structures;
if installation_parms.rate_structures (i) = rs_name then do;
rs_number = i;
a_code = 0;
return;
end;
end;
a_code = error_table_$noentry;
rs_number = 0;
return;
/* --------------------------------------------------------- */
max_rs_number: entry (rs_count);
dcl rs_count fixed bin;
if whoptr = null then call setup;
rs_count = whotab.n_rate_structures;
return;
/* --------------------------------------------------------- */
setup: proc;
dcl ec fixed bin (35);
call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
if whoptr = null
then call com_err_ (ec, "system_info_", "^a>whotab", sysdir);
call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);
if ip = null
then call com_err_ (ec, "system_info_", "^a>installation_parms", sysdir);
end setup;
/* --------------------------------------------- */
setup_rs: proc (rsnum);
dcl ec fixed bin (35);
dcl rsnum fixed bin;
dcl rsn fixed bin;
dcl en char (32);
if whoptr = null then call setup;
if rsnum < 0 | rsnum > whotab.n_rate_structures then do;
call com_err_ (0, "system_info_", "Invalid rate_structure number ^d. Default rates will be used.", rsnum);
rsn = 0;
end;
else rsn = rsnum;
if rs_ptrs (rsn) = null then do;
en = "rate_structure_" || ltrim (char (rsn));
call hcs_$initiate (sysdir, en, "", 0, 0, rs_ptrs (rsn), ec);
if rs_ptrs (rsn) = null then do;
call com_err_ (ec, "system_info_", "^a>^a. Default rates will be used.", sysdir, en);
rsn = 0; /* user loses if rsn already 0 */
end;
end;
cur_rs_ptr = rs_ptrs (rsn);
end setup_rs;
/* --------------------------------------------- */
setup_user_rs: proc;
dcl ec fixed bin (35);
dcl rsn fixed bin;
if pp = null then call hcs_$initiate (get_pdir_ (), "pit", "", 0, 1, pp, ec);
if pp = null then do;
call com_err_ (ec, "system_info_", "pit");
rsn = 0;
end;
else rsn = pp -> pit.rs_number;
call setup_rs (rsn);
end setup_user_rs;
/* --------------------------------------------- */
test_system_info: entry (xdirn);
dcl xdirn char (*) parameter;
dcl nsd char (168);
call absolute_pathname_ (xdirn, nsd, ec);
if ec ^= 0 then do;
call com_err_ (ec, "system_info_$test_system_info", xdirn);
return;
end;
sysdir = nsd;
if whoptr ^= null then /* need to cleanup? */
call hcs_$terminate_noname (whoptr, ec);
whoptr = null; /* re-initiate whotab and installation_parms */
do i = 0 to hbound (rs_ptrs, 1); /* more tidying? */
if rs_ptrs (i) ^= null then do;
call hcs_$terminate_noname (rs_ptrs (i), ec);
rs_ptrs (i) = null;
end;
end;
return;
end system_info_;
\014
user_info_.pl1 11/03/82 1450.9rew 11/03/82 1430.8 142425
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
/* format: style2 */
user_info_:
proc;
/* USER_INFO_ - procedure to return selected information from the PIT
The information returned was put there by the procedure "cpg_"
when the process was created.
The following entries exist:
. user_info_$user_info_ (name, proj, acct)
. user_info_$whoami (name, proj, acct)
. user_info_$login_data (name, proj, acct, anon, stby, weight, time_login, login_word)
. user_info_$usage_data (n_processes, cputime_old_procs, time_login, time_proc_create,core_old_procs,io_old_procs)
. user_info_$homedir (home_directory)
. user_info_$responder (login_responder)
. user_info_$tty_data (terminal_id, terminal_type, channel_id, line_type)
. user_info_$terminal_data (terminal_id, terminal_type_name, channel_id, line_type, charge_type)
. user_info_$service_type (service_type)
. user_info_$process_type (process_type)
. user_info_$logout_data (logout_channel, logout_processid)
. user_info_$login_line (login_string)
. user_info_$absentee_queue (q)
. user_info_$absin (path)
. user_info_$absout (path)
. user_info_$outer_module (om)
. user_info_$load_ctl_info (group, sb, bumpclock, weight)
. user_info_$attributes (att)
. user_info_$limits (mlim, clim, cdate, crf, shlim, msp, csp, shsp)
. user_info_$rs_name (rs_name)
. user_info_$rs_number (rs_number)
. user_info_$absentee_request_id (request_id)
If an entry which takes multiple arguments is called with too few arguments,
only those supplied will be set.
THVV 9/70
Modified 761229 by D. M. Wells to add $service_type and $process_type entry
points, to add line_type parameter to $tty_data, and to get info for
$tty_data from PIT rather than the user_i/o IOSIM.
Modified 6/20/77 by J. Stern to add $terminal_data (obsoletes $tty_data)
Modified April 1979 by T. Casey to return correct information in foreground absentee jobs.
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 December 1981 by E. N. Kittlitz for login_arg_ptr, login_arg_count.
Modified 11/81 by B. Margulies for sub_err_ vs. com_err_.
Modified 10/82 by E. N. Kittlitz for absentee_request_id.
*/
dcl arg_infop pointer;
dcl arg_offset fixed bin;
dcl (pp, whoptr) pointer,
i fixed bin,
ii fixed bin,
hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr,
fixed bin (35)),
current_validation fixed bin (3),
hcs_$level_set entry (fixed bin (3)),
hcs_$level_get entry (fixed bin (3)),
get_ring_ entry() returns(fixed bin(3)),
get_pdir_ entry returns (char (168)),
format_attributes_ entry (ptr, char (*) var),
ec fixed bin (35),
sub_err_ entry options (variable),
sysdir char (64) int static init (">system_control_dir") options (constant),
system_info_$device_prices
entry (fixed bin, ptr),
system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
cu_$arg_count entry (fixed bin, fixed bin (35)),
cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl error_table_$noarg fixed bin (35) ext static;
declare n_args fixed bin;
dcl 1 dvt (16),
2 device_id char (8),
2 device_price (0:7) float bin;
dcl ndev fixed bin;
dcl ap ptr,
al fixed bin,
bchr char (al) based (ap) unaligned,
bfix fixed bin (35) based (ap),
bf17 fixed bin based (ap),
bf21 fixed bin (21) based (ap),
bf71 fixed bin (71) based (ap),
bflt float bin based (ap),
bb36 bit (36) based (ap),
bptr ptr based (ap),
tvcs char (512) var,
bftary (0:7) float bin based (ap);
dcl (addr, null, index, substr)
builtin;
%include pit;
%include user_attributes;
%include whotab;
%page;
fillpp:
proc; /* internal proc to fill in PIT ptr on first call */
declare whotab_$ bit (36) aligned external static;
declare linkage_error condition;
on linkage_error /* AS12.0 INSTALLATION KLUGE */
begin; /* to be removed after hardcore is installed */
call hcs_$level_get (current_validation);
call hcs_$level_set (get_ring_ ());
call hcs_$initiate ((get_pdir_ ()), "pit", "pit_", 0, 1, pp, ec);
call hcs_$level_set (current_validation);
if pp = null
then call sub_err_ (ec, "user_info_", "s", null (), "pit");
end; /* END OF KLUGE */
pp = addr (pit_$); /* we depend on this refname being in the environment */
on linkage_error
begin;
call hcs_$level_get (current_validation);
call hcs_$level_set (get_ring_ ());
call hcs_$initiate (sysdir, "whotab", "whotab_", 0, 1, whoptr, ec);
call hcs_$level_set (current_validation);
if whoptr = null
then call sub_err_ (ec, "user_info_", "s", null (), "whotab");
end;
whoptr = addr (whotab_$);
end fillpp;
%page;
whoami:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.login_name;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.project;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.account;
return;
login_data:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.login_name;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.project;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.account;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.anonymous;
call cu_$arg_ptr (5, ap, al, ec);
if ec ^= 0
then return;
i = pp -> pit.whox; /* use current data from whotab */
if i = 0
then bfix = pp -> pit.standby; /* oof. unlisted users */
else bfix = whotab.e (i).stby; /* user may have been promoted since login */
call cu_$arg_ptr (6, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.user_weight;
call cu_$arg_ptr (7, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.login_time;
call cu_$arg_ptr (8, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.anonymous = 1
then bchr = "enter";
else bchr = "login";
return;
usage_data:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.n_processes;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.old_proc_cpu;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.login_time;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.proc_creation_time;
call cu_$arg_ptr (5, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.old_proc_core;
call cu_$arg_ptr (6, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.old_proc_io_ops;
return;
homedir:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.homedir;
return;
responder:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.login_responder;
return;
tty_data:
entry;
call fillpp;
if pp -> pit.process_type = 2
then do;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = "abs";
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.tty_type;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.line_type;
end;
else do;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty_answerback;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.tty_type;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.line_type;
end;
return;
terminal_data:
entry;
call fillpp;
if pp -> pit.process_type = 2
then do;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = "abs";
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.term_type_name;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.line_type;
call cu_$arg_ptr (5, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.charge_type = 0
then bchr = "none";
else do;
call system_info_$device_prices (ndev, addr (dvt));
bchr = dvt (pp -> pit.charge_type).device_id;
end;
end;
else do;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty_answerback;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.term_type_name;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.tty;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.line_type;
call cu_$arg_ptr (5, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.charge_type = 0
then bchr = "none";
else do;
call system_info_$device_prices (ndev, addr (dvt));
bchr = dvt (pp -> pit.charge_type).device_id;
end;
end;
return;
service_type:
entry ();
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.service_type;
return;
process_type:
entry ();
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.process_type;
return;
logout_data:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.logout_channel;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bb36 = pp -> pit.logout_pid;
return;
login_line:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.login_line;
return;
absentee_queue:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.process_type = 2
then bfix = pp -> pit.abs_queue;
else bfix = -1;
return;
load_ctl_info:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.group;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
i = pp -> pit.whox; /* use current data from whotab */
if i = 0
then do; /* unlisted user? */
bfix = pp -> pit.standby;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.cant_bump_until;
end;
else do;
bfix = whotab.e (i).stby;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bf71 = whotab.e (i).cant_bump_until;
end;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.user_weight;
return;
attributes:
entry (atts);
dcl atts char (*) var;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
call format_attributes_ (addr (pp -> pit.at), tvcs);
atts = tvcs;
return;
absin:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.process_type ^= 2
then bchr = "";
else bchr = pp -> pit.input_seg;
return;
absout:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.process_type ^= 2
then bchr = "";
else do;
if pp -> pit.output_seg = ""
then do;
bchr = before (pp -> pit.input_seg, ".absin") || ".absout";
end;
else bchr = pp -> pit.output_seg;
end;
return;
outer_module:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bchr = pp -> pit.outer_module;
return;
limits:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bflt = pp -> pit.dollar_limit;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bflt = pp -> pit.absolute_limit;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
bf71 = pp -> pit.absolute_cutoff;
call cu_$arg_ptr (4, ap, al, ec);
if ec ^= 0
then return;
bfix = pp -> pit.absolute_increm;
call cu_$arg_ptr (5, ap, al, ec);
if ec ^= 0
then return;
do i = 0 to 7;
bftary (i) = pp -> pit.shift_limit (i);
end;
call cu_$arg_ptr (6, ap, al, ec);
if ec ^= 0
then return;
bflt = pp -> pit.dollar_charge;
call cu_$arg_ptr (7, ap, al, ec);
if ec ^= 0
then return;
bflt = pp -> pit.absolute_spent;
call cu_$arg_ptr (8, ap, al, ec);
if ec ^= 0
then return;
do i = 0 to 7;
bftary (i) = pp -> pit.interactive (i).charge;
end;
return;
rs_name:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
call system_info_$rs_name ((pp -> pit.rs_number), bchr, ec);
if ec ^= 0
then call sub_err_ (ec, "user_info_", "s", null (), (0), "Rate structure ^d invalid.
Contact your system administrator.", pp -> pit.rs_number);
return;
rs_number:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
bf17 = pp -> pit.rs_number;
return;
login_arg_count:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.arg_info_ptr = 0
then /* no login arguments */
bf17 = 0;
else bf17 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;
call cu_$arg_ptr (2, ap, al, ec);
if ec ^= 0
then return;
bf21 = 0;
if pp -> pit.arg_info_ptr = 0
then return;
else do ii = 1 to ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_count;
bf21 = max (ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.arg_lengths (ii), bf21);
end;
call cu_$arg_ptr (3, ap, al, ec);
if ec ^= 0
then return;
if pp -> pit.arg_info_ptr = 0
then bf21 = 0;
else bf21 = ptr (pp, pp -> pit.arg_info_ptr) -> arg_info.ln_args;
return;
login_arg_ptr:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec ^= 0
then return;
i = bf17; /* get argument number */
call cu_$arg_ptr (2, ap, al, ec); /* argument pointer */
if ec ^= 0
then return;
if pp -> pit.arg_info_ptr = 0
then do;
arg_infop = null;
i = -1;
end;
else arg_infop = ptr (pp, pp -> pit.arg_info_ptr);
if i < 1
then bptr = null;
else if i > arg_infop -> arg_info.arg_count
then do;
bptr = null;
i = -1;
end;
else do;
arg_offset = 1;
do ii = 1 to i - 1;
arg_offset = arg_offset + arg_infop -> arg_info.arg_lengths (ii);
end;
bptr = addr (substr (arg_infop -> arg_info.args, arg_offset, 1));
/* illegal pl1 */
end;
call cu_$arg_ptr (3, ap, al, ec); /* argument length */
if ec ^= 0
then return;
if i < 0
then bf21 = 0;
else bf21 = arg_infop -> arg_info.arg_lengths (i);
call cu_$arg_ptr (4, ap, al, ec); /* return code */
if ec ^= 0
then return;
if i < 0
then bfix = error_table_$noarg;
else bfix = 0;
return;
absentee_request_id:
entry;
call fillpp;
call cu_$arg_ptr (1, ap, al, ec);
if ec = 0
then bf71 = pp -> pit.request_id;
return;
end user_info_;
\014
where.pl1 10/12/82 1155.2rew 10/12/82 1155.0 148779
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
where: wh: procedure options (variable);
/* This command prints the primary pathname of the first segment or
entry point with a given name found using the object segment search rules.
Usage:
where names -control_args-
where control_args are:
-all, -a list all segments or entry points in the search path.
-inhibit_error, -ihe supress error message when segment not found and returns null string as AF.
-entry_point, -ep look for name$name when name does not contain a $.
-segment, -sm look for the segment named name even if name contains a $.
The default is to look for an entry point if name contains a $, segment otherwise.
Usage as an active function:
[where name -control_arg-]
where control_arg is either -entry_point (-ep) or -segment (-sm).
*/
/* Written 3/5/76 by Steve Herbst */
/* Entry point feature added 12/3/76 by S. Herbst */
/* fixed to show orig not copy if uninitiated seg has copysw on 03/20/80 S. Herbst */
/* Modified: 06/06/80, W. Olin Sibert, to add where -brief */
/* Fixed to work on gates 07/15/81 S. Herbst */
/* Fixed bugs and made -brief -all work 10/06/82 S. Herbst */
%include access_mode_values;
%include branch_status;
%include object_info;
dcl 1 obj_info like object_info;
dcl refnames (32) char (168);
dcl 1 search_rules aligned, /* from hcs_$get_search_rules */
2 rule_count fixed bin,
2 rule (21) char (168);
dcl 1 search_dirs (21), /* directories to search through */
2 dir char (168),
2 uid bit (36),
2 rule_number fixed bin;
dcl area area based (area_ptr);
dcl arg char (arg_len) based (arg_ptr);
dcl return_arg char (return_len) varying based (return_ptr); /* if called as active function */
dcl primary_name char (32) aligned based;
dcl (dn, entry_point_name, name) char (168);
dcl (en, unique_name) char (32);
dcl out_str char (256);
dcl (af_sw, all_sw, brief_sw, long_sw, all_entry_points, all_segments, entry_point, inhibit_error, printed_sw,
search_manually, some_output, some_segs, terminate, try_initiated_segs) bit (1) aligned;
dcl (area_ptr, arg_ptr, entry_point_ptr, names_ptr, return_ptr, seg_ptr) ptr;
dcl fmode fixed bin (5);
dcl (arg_count, arg_len, dir_count, refname_count, return_len) fixed bin;
dcl (argno, dir_idx, idx, refname_idx, uid_idx) fixed bin;
dcl bit_count fixed bin (24);
dcl code fixed bin (35);
dcl (error_table_$badopt,
error_table_$inconsistent,
error_table_$dirseg,
error_table_$no_dir,
error_table_$no_s_permission,
error_table_$noentry,
error_table_$entlong,
error_table_$not_act_fnc) fixed bin (35) external static;
dcl complain entry variable options (variable); /* com_err_ or active_fnc_err_ */
dcl get_arg variable entry (fixed bin, ptr, fixed bin, fixed bin (35));
dcl active_fnc_err_ entry options (variable);
dcl com_err_ entry options (variable);
dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
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_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl get_system_free_area_ entry returns (ptr);
dcl get_wdir_ entry returns (char (168));
dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35));
dcl hcs_$get_search_rules entry (ptr);
dcl hcs_$fs_get_seg_ptr 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_$make_ptr entry (ptr, char (*), char (*), ptr, fixed bin (35));
dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35));
dcl hcs_$terminate_name entry (char (*), fixed bin (35));
dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl ioa_ entry options (variable);
dcl ioa_$rsnnl entry options (variable);
dcl ioa_$nnl entry options (variable);
dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35));
dcl pathname_ entry (char (*), char (*)) returns (char (168));
dcl unique_chars_ entry (bit (*)) returns (char (15));
dcl WHOAMI char (32) internal static options (constant) init ("where");
dcl cleanup condition;
dcl (addr, bit, char, hbound, index, length, null, ptr, rtrim, substr) builtin;
/* \014 */
all_sw, all_entry_points, all_segments, brief_sw = "0"b;
inhibit_error, long_sw, search_manually, some_output = "0"b;
names_ptr = null ();
area_ptr = get_system_free_area_ ();
call cu_$af_return_arg (arg_count, return_ptr, return_len, code);
if code = error_table_$not_act_fnc then do;
af_sw = "0"b;
complain = com_err_;
get_arg = cu_$arg_ptr;
end;
else do;
af_sw = "1"b;
complain = active_fnc_err_;
get_arg = cu_$af_arg_ptr;
return_arg = "";
end;
if arg_count = 0 then do;
USAGE: if af_sw then call active_fnc_err_ (0, WHOAMI, "Usage: [^a refname {-control_args}]", WHOAMI);
else call com_err_ (0, WHOAMI, "Usage: ^a refnames {-control_args}", WHOAMI);
goto MAIN_RETURN;
end;
on condition (cleanup) call clean_up;
refname_count = 0;
do argno = 1 to arg_count;
call get_arg (argno, arg_ptr, arg_len, code);
if char (arg, 1) ^= "-" then do; /* a refname we should locate */
refname_count = refname_count+1;
if refname_count > hbound (refnames, 1) then do;
call complain (0, WHOAMI, "Too many reference names specified. Max is ^d.",
hbound (refnames, 1));
goto MAIN_RETURN;
end;
refnames (refname_count) = arg;
end;
else if (arg = "-all" | arg = "-a") then
if af_sw then do;
AF_BAD_OPT:
call complain (0, WHOAMI, "Control arg not allowed for the active function. ^a", arg);
return;
end;
else all_sw = "1"b;
else if (arg = "-long" | arg = "-lg") then
if af_sw then go to AF_BAD_OPT;
else do;
long_sw = "1"b;
brief_sw = "0"b;
end;
else if (arg = "-brief" | arg = "-bf") then
if af_sw then go to AF_BAD_OPT;
else do;
brief_sw = "1"b;
long_sw = "0"b;
end;
else if (arg = "-entry_point") | (arg = "-ep") then all_entry_points = "1"b;
else if (arg = "-segment") | (arg = "-sm") then all_segments = "1"b;
else if (arg = "-inhibit_error") | (arg = "-ihe") then inhibit_error = "1"b;
else if (arg = "-no_inhibit_error") | (arg = "-nihe") then inhibit_error = "0"b;
else do;
call complain (error_table_$badopt, WHOAMI, "^a", arg);
goto MAIN_RETURN;
end;
end;
if refname_count = 0 | (af_sw & refname_count > 1) then
goto USAGE;
if all_entry_points & all_segments then do;
call complain (error_table_$inconsistent, WHOAMI, "-segment and -entry_point");
goto MAIN_RETURN;
end;
if all_sw & ^brief_sw then long_sw = "1"b;
if long_sw | all_sw then do; /* must get search rules, to locate manually */
search_manually = "1"b;
call hcs_$get_search_rules (addr (search_rules));
dir_count = 0;
try_initiated_segs = "0"b;
do idx = 1 to rule_count; /* find all the genuine directories */
if rule (idx) = "initiated_segments" then try_initiated_segs = "1"b;
else if rule (idx) ^= "referencing_dir" then do;
dir_count = dir_count + 1;
if rule (idx) = "working_dir" then dir (dir_count) = get_wdir_ ();
else dir (dir_count) = rule (idx);
rule_number (dir_count) = idx;
end;
end;
end;
/* \014 */
do refname_idx = 1 to refname_count; /* Now, decide what to do with each of out reference name */
name = refnames (refname_idx);
idx = index (name, "$");
if (idx ^= 0) & ^all_segments then do; /* name$entry */
entry_point_name = substr (name, idx + 1);
name = substr (name, 1, idx - 1);
if entry_point_name = "" then entry_point = "0"b;
else entry_point = "1"b;
end;
else if all_entry_points then do; /* -entry_point specified */
entry_point = "1"b;
entry_point_name = name;
end;
else do;
entry_point = "0"b; /* reference name */
entry_point_name = "";
end;
if length (rtrim (name)) > 32 then do;
call complain (error_table_$entlong, WHOAMI, "^a", name);
goto NEXT;
end;
else if length (rtrim (entry_point_name)) > 32 then do;
call complain (error_table_$entlong, WHOAMI, "^a", entry_point_name);
goto NEXT;
end;
/* \014 */
if ^search_manually then do; /* locate by the usual (linker) mechanism */
terminate = "0"b;
call hcs_$fs_get_seg_ptr (name, seg_ptr, code); /* already initiated? */
if seg_ptr = null then do;
terminate = "1"b;
call hcs_$make_ptr (null (), name, "", seg_ptr, code);
if code ^= 0 then do;
if ^inhibit_error then call complain (code, WHOAMI, "^a", name);
goto NEXT;
end;
end;
call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
if code ^= 0 then do;
call complain (code, WHOAMI, "^a", name);
goto NEXT;
end;
if entry_point then do;
call find_entry_point;
if terminate then call hcs_$terminate_name (name, (0));
if code ^= 0 then do;
call complain (code, WHOAMI, "^a$^a", pathname_ (dn, en), entry_point_name);
goto NEXT;
end;
end;
else if terminate then call hcs_$terminate_name (name, code);
call ioa_$rsnnl ("^a^[$^a^;^s^]", out_str, (0),
pathname_ (dn, en), entry_point, entry_point_name);
if af_sw then do; /* just assign it to the return arg, and punt */
return_arg = out_str;
goto MAIN_RETURN;
end;
else call ioa_ ("^a", out_str);
end; /* of searching non-manually (via hcs_$make_ptr) */
/* \014 */
else do; /* we must search for the segment manually */
/* Note that this is never done for an AF. */
if (idx > 1) & some_output & all_sw then /* separate -all outputs by a blank line */
call ioa_ ("");
some_output, some_segs = "0"b;
if try_initiated_segs then do; /* search rules contained "initiated_segments" */
dir_idx = 0;
call hcs_$fs_get_seg_ptr (name, seg_ptr, code);
if seg_ptr ^= null () then do;
some_segs = "1"b;
call hcs_$fs_get_path_name (seg_ptr, dn, (168), en, code);
if code ^= 0 then call complain (code, WHOAMI, "^a", name);
else do;
if entry_point then call find_entry_point ();
if code ^= 0 then call complain (code, WHOAMI,
"^a$^a Search rule ""initiated_segments""",
pathname_ (dn, en), entry_point_name);
else call print_pathname ();
if ^all_sw then go to NEXT;
end;
end; /* of successfully finding segment by refname */
end; /* of trying "initiated_segments" */
do dir_idx = 1 to dir_count; /* try to initiate in each of the dirs in the search rules */
call hcs_$initiate (dir (dir_idx), name, "", 0, 1, seg_ptr, code);
if seg_ptr ^= null then do;
some_segs = "1"b;
call hcs_$fs_get_path_name (seg_ptr, dn, (0), en, code);
if code ^= 0 then do;
code = 0;
dn = dir (dir_idx);
en = name;
end;
if entry_point then call find_entry_point ();
if code ^= 0 then call complain (code, WHOAMI, "^a$^a (Search rule ""^a"")",
pathname_ (dn, en), entry_point_name, rule (rule_number (dir_idx)));
else call print_pathname ();
call hcs_$terminate_noname (seg_ptr, (0));
if ^all_sw then go to NEXT;
end; /* end of case for being able to initiate segment */
else if code ^= error_table_$noentry & code ^= error_table_$no_dir &
code ^= error_table_$dirseg then do;
some_output, some_segs = "1"b;
if entry_point then call complain (code, WHOAMI, "^a (Search rule ""^a"")",
pathname_ (dir (dir_idx), name), rule (rule_number (dir_idx)));
else do;
if brief_sw & all_sw then do;
call hcs_$status_long (dir (dir_idx), name, 1, addr (branch_status), null, code);
uid (dir_idx) = branch_status.unique_id;
printed_sw = "0"b;
do uid_idx = 1 to dir_idx - 1; /* print each path only once */
if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
end;
if ^printed_sw then call ioa_ ("^a", pathname_ (dir (dir_idx), name));
end;
else do;
call hcs_$status_ (dir (dir_idx), name, 1, addr (branch_status), area_ptr, code);
if code = 0 then do; /* print formatted line */
names_ptr = ptr (area_ptr, branch_status.names_rel_pointer);
if long_sw then call ioa_ ("^a (^a) Search rule ""^a""",
pathname_ (dir (dir_idx), (names_ptr -> primary_name)),
get_mode_letters (branch_status.mode), rule (rule_number (dir_idx)));
else call ioa_ ("^a", pathname_ (dir (dir_idx), name));
if ^all_sw then go to NEXT;
end;
else if code = error_table_$no_s_permission then
call complain (0, WHOAMI,
"No status permission on ^a (Search rule ""^a"")",
dir (dir_idx), rule (rule_number (dir_idx)));
else if code ^= error_table_$noentry then
call complain (code, WHOAMI, "^a (Search rule ""^a"")",
dir (dir_idx), rule (rule_number (dir_idx)));
else some_output = "0"b;
end;
end;
end; /* of case for unable to initiate segment */
end; /* of loop through dirs in search rules */
if ^some_output & ^inhibit_error then
if entry_point & some_segs then call complain (0, WHOAMI, "Entry point not found. ^a$^a",
name, entry_point_name);
else call complain (0, WHOAMI, "Segment not found. ^a", name);
end; /* of case for searching manually */
NEXT: end; /* end of refname loop */
MAIN_RETURN:
call clean_up;
return;
/* \014 */
clean_up: proc;
if names_ptr ^= null then free names_ptr -> primary_name in (area);
end clean_up;
find_entry_point: proc;
/* This internal procedure looks for an external definition. */
call hcs_$fs_get_mode (seg_ptr, fmode, code);
if fmode < R_ACCESS_BIN then do; /* inner ring seg: gate? */
/* make sure make_ptr finds this one */
unique_name = unique_chars_ ("0"b);
call hcs_$initiate (dn, en, unique_name, 0, 1, seg_ptr, code);
call hcs_$make_ptr (null, unique_name, entry_point_name, entry_point_ptr, code);
call hcs_$terminate_name (unique_name, 0);
end;
else do;
call hcs_$status_minf (dn, en, 1, (0), bit_count, code);
call object_info_$brief (seg_ptr, bit_count, addr (obj_info), code);
if code ^= 0 then return;
call get_definition_ (obj_info.defp, name, entry_point_name, null, code);
end;
end find_entry_point;
print_pathname: proc;
some_output = "1"b;
call hcs_$fs_get_mode (seg_ptr, fmode, code);
if code ^= 0 then fmode = 0;
if long_sw then do;
call ioa_$nnl ("^a^[$^a^;^s^] (^a) Search rule ",
pathname_ (dn, en), entry_point, entry_point_name, get_mode_letters (bit (fmode)));
if dir_idx = 0 then call ioa_ ("""initiated_segments""");
else call ioa_ ("""^a""", rule (rule_number (dir_idx)));
end;
else do;
call hcs_$status_long (dn, en, 1, addr (branch_status), null, code);
uid (dir_idx) = branch_status.unique_id;
printed_sw = "0"b;
do uid_idx = 1 to dir_idx-1; /* only print each path once */
if uid (uid_idx) = branch_status.unique_id then printed_sw = "1"b;
end;
if ^printed_sw then call ioa_ ("^a", pathname_ (dn, en));
end;
end print_pathname;
get_mode_letters: proc (mode_bits) returns (char (4)varying);
dcl mode_bits bit (5);
dcl amode char (4) varying;
amode = "";
if substr (mode_bits, 2, 1) ^= "0"b then amode = "r";
if substr (mode_bits, 3, 1) ^= "0"b then amode = amode||"e";
if substr (mode_bits, 4, 1) ^= "0"b then amode = amode||"w";
if amode = "" then amode = "null";
return (amode);
end get_mode_letters;
end where;
\014
who.pl1 11/09/82 1212.0rew 11/09/82 1211.8 144135
/* ***********************************************************
* *
* Copyright, (C) Honeywell Information Systems Inc., 1982 *
* *
* Copyright (c) 1972 by Massachusetts Institute of *
* Technology and Honeywell Information Systems, Inc. *
* *
*********************************************************** */
/* format: style4 */
who: procedure;
/* WHO - print information about who's on Multics.
HMU, HOW_MANY_USERS - give header lines with nusers and load.
This command types out the userid's of listed logged-in users
from the segment "whotab", which is maintained by the answering service
program "lg_ctl_". The possible arguments are as follows:
. -bf suppress header (not allowed for af)
. -lg print "long who" (not allowed for af)
. -nm sort lines on user name
. -pj sort lines on project id
. (the default sort is by time logged in)
. -as print information on absentee users
. -ia print information on interactive users
. -dmn print information on daemon users
. (default is -as -ia if none of -as -ia -dmn given)
. -all -as, -ia -dmn
. 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"
Initial coding by THVV, 9/6/70 */
/* changed for absentee by EDS 7/71 */
/* various changes by RBR 7/72 */
/* error messages changed 09/15/78 S. Herbst */
/* Modified May 1979 by T. Casey and S. Herbst for MR7.0a to add -interactive and -daemon,
and to list foreground absentee users correctly */
/* who active function added 01/12/81 S. Herbst */
/* 12/24/81 E. N. Kittlitz. whotab changes */
/* 9/82 BIM -all, no daemons by default */
/* 11/82 E. N. Kittlitz. list daemons if name explicitly given, do selection for af call */
dcl return_arg char (return_len) varying based (return_ptr);
dcl return_ptr ptr;
dcl return_len fixed bin;
dcl af_sw bit (1);
dcl argno fixed bin init (1), /* number of argument */
arg_count fixed bin,
ap ptr, /* ptr to argument */
al fixed bin, /* lth of argument */
ec fixed bin (35), /* file-system error code */
(f1, f2) float bin, /* conversion temps */
sort fixed bin init (0), /* type of sort. 0=date, 1=name, 2=proj */
hmucnt fixed bin init (0), /* number of names|projects in */
abscnt fixed bin init (0), /* hmucnt as absentee users */
long bit (1) aligned init ("0"b), /* 1 if long who wanted */
abs bit (1) aligned init ("0"b), /* 1 if listing absentee users */
only_abs bit (1) aligned init ("0"b), /* if only listing absentees */
daemon bit (1) aligned init ("0"b), /* if listing daemon users */
interactive bit (1) aligned init ("0"b), /* if listing interactive users */
brief bit (1) aligned init ("0"b), /* 1 for no heading at all */
hmuflg bit (1) aligned init ("0"b), /* selective hmu flag */
selx fixed bin init (0), /* if particular users wanted */
dotl fixed bin, /* location of dot in arg */
nm (50) char (24) aligned, /* user names wanted */
pj (50) char (12) aligned, /* user projs wanted */
caller char (14) varying, /* name of caller to com_err */
why char (128) aligned, /* reason for shutdown */
arg char (al) unaligned based (ap), /* pickup for args */
sort_arg char (32) init (""),
whoptr ptr int static init (null), /* ptr to whotab */
ip ptr int static init (null), /* ptr to installation_parms */
sysdir char (64) aligned int static init (">system_control_1"), /* name of dir in which who table resides */
j fixed bin, /* index */
d fixed bin, /* distance between sorted elems */
last fixed bin, /* highest index in whotab */
swap fixed bin, /* 1 if a swap was done */
ajd fixed bin, /* temp for sort, ary(j+d) */
sss char (1) aligned init ("s"), /* pretty for user-not-on */
(time, time1) char (16) aligned init (""), /* ASCII time */
aj fixed bin, /* temp, ary(j) */
did fixed bin init (0), /* count of lines printed */
mark char (3) aligned, /* denotation of absentee user if = "*" */
k fixed bin; /* index */
%include whotab;
%include installation_parms;
dcl complain entry variable options (variable);
dcl ioa_ ext entry options (variable), /* library procedures */
active_fnc_err_ entry options (variable),
com_err_ ext entry options (variable),
date_time_ ext entry (fixed bin (71), char (*) aligned),
cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)),
cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
hcs_$initiate ext entry (char (*) aligned, char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)),
requote_string_ entry (char (*)) returns (char (*));
dcl (divide, fixed, hbound, index, null, substr) builtin;
dcl (error_table_$badopt,
error_table_$not_act_fnc,
error_table_$too_many_args) ext fixed bin;
/* - - - - - - - - - - */
caller = "who"; /* set name of caller to com_err_ */
go to join;
how_many_users: hmu: entry;
caller = "how_many_users";
hmuflg = "1"b;
join:
call cu_$af_return_arg (arg_count, return_ptr, return_len, ec);
if ec = error_table_$not_act_fnc then do;
af_sw = "0"b;
complain = com_err_;
end;
else if caller = "how_many_users" then do;
call active_fnc_err_ (0, caller, "Cannot be called as an active function.");
return;
end;
else do;
af_sw = "1"b;
complain = active_fnc_err_;
end;
do argno = 1 to arg_count;
call cu_$arg_ptr (argno, ap, al, ec); /* get nth argument */
if arg = "-absentee" | arg = "-as" then abs = "1"b;
else if arg = "-daemon" | arg = "-dmn" then daemon = "1"b;
else if arg = "-interactive" | arg = "-ia" then interactive = "1"b;
else if arg = "-all" | arg= "-a" then interactive, daemon, abs = "1"b;
else if arg = "-name" | arg = "-nm" then sort = 1;
else if arg = "-project" | arg = "-pj" then sort = 2;
else if arg = "-brief" | arg = "-bf" then
if af_sw then do;
BAD_AF_OPT: call active_fnc_err_ (0, caller, "Invalid active function control arg ^a", arg);
return;
end;
else brief = "1"b;
else if arg = "-long" | arg = "-lg" then
if af_sw then go to BAD_AF_OPT;
else long = "1"b;
else if substr (arg, 1, 1) = "-" then do; /* then it must be a name or project */
bad_opt: call complain (error_table_$badopt, caller, "^a", arg);
return;
end;
else do; /* save Name | .Project */
selx = selx + 1; /* up index in select array */
if selx > hbound (nm, 1) then do;
call complain (error_table_$too_many_args, caller);
return;
end;
nm (selx), pj (selx) = ""; /* blank selectors */
dotl = index (arg, "."); /* where's the dot? */
if dotl = 0 then nm (selx) = arg; /* no dot. is user name. */
else if dotl = 1 then pj (selx) = substr (arg, 2, al - 1);
else do; /* dot in middle, is name.proj */
nm (selx) = substr (arg, 1, dotl - 1); /* get name */
pj (selx) = substr (arg, dotl + 1, al - dotl);
end;
end;
if sort ^= 0 & hmuflg then go to bad_opt;
end;
if ^interactive & ^abs & ^daemon then do; /* if process type not specified */
interactive, abs = "1"b; /* default is to list abs and ia */
if selx > 0 then daemon = "1"b; /* but if name/proj given, list everything */
end;
only_abs = abs & ^interactive & ^daemon; /* see if abs only */
go: if whoptr = null then do; /* is this the first call? */
call hcs_$initiate (sysdir, "whotab", "", 0, 1, whoptr, ec);
if whoptr = null then do;
call complain (ec, caller, "^a>whotab", sysdir);
return;
end;
end;
if ^brief & ^af_sw then do; /* suppress header */
if hmuflg then go to head; /* always a header for hmu, except after brief */
if selx = 0 then do; /* no header with who select */
if only_abs /* what type absentee header if any */
then if long
then go to print_long_abs_totals;
else go to print_abs_totals;
head: f1 = whotab.n_units / 10.0e0; /* format up units */
f2 = whotab.mxunits / 10.0e0; /* ... */
j = whotab.n_users - whotab.abs_users - whotab.fg_abs_users - whotab.n_daemons; /* compute interactive users */
if long then do; /* long who? */
if ip = null then do;
call hcs_$initiate (sysdir, "installation_parms", "", 0, 1, ip, ec);
if ip = null then do;
call complain (ec, caller, "Insufficient access for -long option");
return;
end;
end;
call date_time_ (whotab.timeup, time); /* yup. make heading */
call ioa_ ("^/Multics ^a; ^a", whotab.sysid, installation_parms.installation_id);
call ioa_ ("Load = ^.1f out of ^.1f units; users = ^d, ^d interactive, ^d daemons.",
f1, f2, whotab.n_users, j, whotab.n_daemons);
if (whotab.abs_users + whotab.max_abs_users) ^= 0
then /* ! */
print_long_abs_totals: call ioa_ ("^[^/^]Absentee users = ^d background^[, ^d foreground^;^s^]; Max background absentee users = ^d^[^/^]",
only_abs, whotab.abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, whotab.max_abs_users, only_abs);
if only_abs then go to check_hmu;
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^/", time);
else if whotab.lastsd = 0 then call ioa_ ("");
else if whotab.erfno = "" then call ioa_ ("Last shutdown was at ^a^/", time);
else call ioa_ ("Last crash (ERF ^a) was at ^a^/", whotab.erfno, time);
if hmuflg then if selx = 0 then return;
else go to shell_sort;
call ioa_ ("^4xLogin at^6xTTY Load^3xUser ID^/");
end;
else do; /* short who. */
call ioa_ ("^/Multics ^a, load ^.1f/^.1f; ^d users, ^d interactive, ^d daemons.",
whotab.sysid, f1, f2, whotab.n_users, j, whotab.n_daemons);
if (whotab.max_abs_users + whotab.abs_users) ^= 0
then /* print absentee totals under certain conditions */
print_abs_totals: call ioa_
("^[^/^]Absentee users ^d/^d^[^x(+^d FG)^;^s^]^[^/^]",
only_abs, whotab.abs_users, whotab.max_abs_users, (whotab.fg_abs_users > 0), whotab.fg_abs_users, only_abs);
if ^abs then call ioa_ ("");
end;
end;
end;
check_hmu:
if hmuflg & selx = 0 /* if a simple hmu entry then finished */
then return;
shell_sort: last = whotab.laste; /* save high limit on whotab */
if hmuflg then go to count; /* go to selective hmu counting */
begin;
dcl sort_array (last) fixed bin;
do j = 1 to last; /* set up sort array */
sort_array (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 = sort_array (j); /* make temps */
ajd = sort_array (j + d); /* ... */
if sort = 0 then if whotab.timeon (aj) > whotab.timeon (ajd) then go to ic;
if sort = 1 then if whotab.person (aj) > whotab.person (ajd) then go to ic;
if sort = 2 then if whotab.project (aj) > whotab.project (ajd) then go to ic;
else if whotab.project (aj) = whotab.project (ajd) then if whotab.person (aj)
> whotab.person (ajd) then do; /* Are items in order? */
ic: sort_array (j) = ajd; /* No. Swap entries */
sort_array (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; /* ... */
if af_sw then return_arg = "";
do j = 1 to last; /* now the print loop */
aj = sort_array (j); /* set up speed temp */
if whotab.active (aj) = 0 then go to skip; /* skip deads */
if selx = 0 then go to print; /* any users selected? */
do k = 1 to selx; /* check for selected users */
if nm (k) = whotab.person (aj) then if pj (k) = "" then go to print;
else if pj (k) = whotab.project (aj) then go to print;
if nm (k) = "" then if pj (k) = whotab.project (aj) then go to print;
end;
go to skip; /* user not in selected group */
print:
if whotab.proc_type (aj) = 1 & ^interactive
| whotab.proc_type (aj) = 2 & ^abs
| whotab.proc_type (aj) = 3 & ^daemon
then goto skip;
if af_sw then do;
if return_arg ^= "" then return_arg = return_arg || " ";
return_arg = return_arg ||
requote_string_ (rtrim (whotab.person (aj)) || "." || rtrim (whotab.project (aj)));
go to skip;
end;
if whotab.proc_type (aj) ^= 2 then /* if not absentee */
mark = ""; /* clear absentee flag */
else if whotab.fg_abs (aj) then /* if foreground absentee */
mark = "*FG"; /* flag it as such */
else mark = "*"; /* else flag it as background absentee */
did = did + 1; /* remember we did one */
if long then do; /* long who? */
call date_time_ (whotab.timeon (aj), time); /* yup. */
if substr (time, 1, 8) = substr (time1, 1, 8) then substr (time, 1, 8) = (8)" ";
/* Suppress date if it is the same as last printed date */
else time1 = time;
f1 = whotab.units (aj) / 10.0e0; /* get nice units */
call ioa_ ("^16a ^4a ^4.1f^3x^a.^a^a^x^[D^]^[S^]",
time, whotab.idcode (aj), f1, whotab.person (aj), whotab.project (aj),
mark, whotab.disconnected (aj), whotab.suspended (aj));
end;
else do; /* short who. */
call ioa_ ("^a.^a^a^x^[D^]^[S^]", whotab.person (aj), whotab.project (aj), mark,
whotab.disconnected (aj), whotab.suspended (aj));
end;
skip: end;
end;
if ^af_sw then do;
if ^brief then
if did = 0 then do; /* if printed nobody */
if selx = 1 then if nm (1) ^= "" then sss = "";
call ioa_ ("User^a not logged in.", sss);
end;
call ioa_ (""); /* extra CR */
end;
return; /* done. */
/* - - - - - - - - */
count: do j = 1 to selx; /* selective hmu counting */
hmucnt = 0; /* reset counters */
abscnt = 0;
if nm (j) = "" then do; /* selected project counting */
do aj = 1 to last;
if pj (j) = whotab.project (aj) then
if whotab.proc_type (aj) ^= 2
then hmucnt = hmucnt + 1;
else abscnt = abscnt + 1;
end;
call ioa_ (".^a = ^d + ^d*", pj (j), hmucnt, abscnt);
end;
if nm (j) ^= "" then
if pj (j) ^= "" /* selected name.project counting */
then do;
do aj = 1 to last;
if nm (j) = whotab.person (aj)
then if pj (j) = whotab.project (aj)
then if whotab.proc_type (aj) ^= 2
then hmucnt = hmucnt + 1;
else abscnt = abscnt + 1;
end;
call ioa_ ("^a.^a = ^d + ^d*", nm (j), pj (j), hmucnt, abscnt);
end;
else do; /* selected name counting */
do aj = 1 to last;
if nm (j) = whotab.person (aj) then
if whotab.proc_type (aj) ^= 2
then hmucnt = hmucnt + 1;
else abscnt = abscnt + 1;
end;
call ioa_ ("^a = ^d + ^d*", nm (j), hmucnt, abscnt);
end;
end;
return;
who_init: entry (system_directory); /* entry used for testing who command */
dcl system_directory char (*);
sysdir = system_directory; /* copy name of directory containing who table */
whoptr = null; /* set pointer to null */
return;
end who;
"This material is presented to ensure dissemination of scholarly and technical work. Copyright and all rights therein are retained by authors or by other copyright holders. All persons copying this information are expected to adhere to the terms and constraints invoked by each author's copyright. In most cases, these works may not be reposted without the explicit permission of the copyright holder."