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:
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.
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.
This subroutine is the guts of the help command.
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.)
This command lists the reference names by which a segment is initiated.
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.
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.
This subroutine reads information from the supervisor. Only specific values are available to normal user programs.
This subroutine reads information about the system.
Original implementation by Tom Van Vleck.
This subroutine returns information about the particular logged-in user process.
Original implementation by Tom Van Vleck.
This command and active function uses the system search rules to find a sgment, and prints out its file system pathname.
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
/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
/*