load_doc_db_dbf.pl1 10/10/83 1326.7rew 10/10/83 1306.2 163179 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2,ind3 */ load_doc_db_dbf: proc; /* DESCRIPTION: This command takes the db file and stores it into the online_doc database. Fields are extracted from an input file of a special format, described below. */ /* HISTORY: Written by Jim Paradise, 1979. 02/25/81 by M. Pierret: added cu_ calls, added get_array_of_lines-type processing, and adjusted to new format of data base. 03/04/81 by M. Pierret: added end condition in get_array_of_lines. 06/04/81 by M. Pierret: canonical names ("-" & " " -> "_"); fixing trailing order no bug. 09/30/83 by Matthew Pierret: Changed short_name_list from char (128) to (1024). */ /* DESCRIPTION of PARAMETERS: mrds_db_path - pathname to the online_doc.db database, of the form described in online_doc.incl.pl1. input_file - ASSCII file containing data about manuals. The file is assumed to be formatted as follows: Order No.: AANN-NNA Manual Name: ____ Short Name: ____ Description: ____ _____ Audience: ____ _____ Table of Contents: ____ _____ New Features: ____ _____ Release Supported: ____ _____ */ /* ERRORS: Any of the errors possible from trying to read a input segment via vfile_ unstructured read. Any of the errors possible from trying to store data into a MRDS database. */ /* START OF DECLARATIONS */ dcl sysprint file; /* Automatic */ dcl line_buffer char (1024); dcl input_file char (168); dcl mrds_db_path char (168); dcl short_name_list char (1024) varying; dcl field_value char (1024) varying; dcl temp_varying_string char (1024) varying; dcl ( input_file_is_open init ("0"b), is_active_function, all_lines_have_been_processed ) bit (1) aligned; dcl (arg_len, return_arg_len, current_input_line_length) fixed bin (21); dcl (code, dbi) fixed bin (35); dcl (nargs, current_input_line_number, record_count) fixed bin init (0); dcl (iocb_ptr, arg_ptr, return_arg_ptr, input_line_ptr, field_value_ptr) ptr; /* Based */ dcl arg char (arg_len) based (arg_ptr); dcl input_line char (current_input_line_length) based (input_line_ptr); /* Builtin */ dcl (addr, after, min, substr, length, index, null) builtin; /* Constant */ dcl myname char (15) init ("load_doc_db_dbf") int static options (constant); dcl LIMIT_TO_STOP_INFINITE_LOOPING init (99999) fixed bin int static options (constant); dcl NL char (1) init (" ") int static options (constant); dcl LOWER_CASE_ALPHA char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UPPER_CASE_ALPHA char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); /* Entry */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_ entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), ptr, fixed (35)); dcl iox_$open entry (ptr, fixed, bit (1) aligned, fixed (35)); dcl iox_$get_line entry (ptr, ptr, fixed (21), fixed (21), fixed (35)); dcl iox_$close entry (ptr, fixed (35)); dcl iox_$detach_iocb entry (ptr, fixed (35)); dcl dsl_$open entry options (variable); dcl dsl_$store entry options (variable); dcl dsl_$close entry options (variable); /* External */ dcl ( mdbm_error_$dup_store, error_table_$not_act_fnc ) fixed bin (35) ext static; /* END OF DECLARATIONS */ /* Get the two arguments to this command: mrds_db_path and input_file. Return if the arguments are not found or if they refer to objects that do not exist. */ call cu_$af_return_arg (nargs, return_arg_ptr, return_arg_len, code); if code = 0 then is_active_function = "1"b; else if code = error_table_$not_act_fnc then is_active_function = "0"b; else do; call com_err_ (code, myname); return; end; if nargs ^= 2 | is_active_function then do; call com_err_ (0, myname, "Usage: ^a ", myname); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, code); call absolute_pathname_$add_suffix (arg, "db", mrds_db_path, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", arg); return; end; call cu_$arg_ptr (2, arg_ptr, arg_len, code); call absolute_pathname_ (arg, input_file, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", arg); return; end; /* open the MRDS database */ call dsl_$open (mrds_db_path, dbi, 4, code); if code ^= 0 then do; call com_err_ (code, myname, "Database path ^a.", mrds_db_path); return; end; full_name_rel.manual_number = 0; /* start at zero and increment by one for each manual */ /* Loop through the records in the input file, creating tuples out of the data in the input file and storing that data in the database. */ input_line_ptr = addr (line_buffer); all_lines_have_been_processed = "0"b; do record_count = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (^all_lines_have_been_processed); field_value = ""; call GET_NEXT_INPUT_LINE (code); call GET_NEXT_FIELD (ORDER_NUMBER_FIELD_ID, MANUAL_NAME_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, ORDER_NUMBER_FIELD_ID); if length (field_value) ^= 4 & length (field_value) ^= 7 & length (field_value) ^= 8 then call FORMAT_ERROR (ORDER_NUMBER_FIELD_ID); else do; full_name_rel.order_number = substr (field_value, 1, 4); field_value = field_value || " " /* spaces */; full_name_rel.revision = substr (field_value, 6, 3); end; call GET_NEXT_FIELD (MANUAL_NAME_FIELD_ID, SHORT_NAME_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, MANUAL_NAME_FIELD_ID); else do; full_name_rel.full_name = field_value; name_rel.name = CANONICALIZE_NAME (field_value); end; call GET_NEXT_FIELD (SHORT_NAME_FIELD_ID, DESCRIPTION_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, SHORT_NAME_FIELD_ID); else short_name_list = field_value; call GET_NEXT_FIELD (DESCRIPTION_FIELD_ID, AUDIENCE_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, DESCRIPTION_FIELD_ID); else info_rel.description = field_value; call GET_NEXT_FIELD (AUDIENCE_FIELD_ID, TOC_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, AUDIENCE_FIELD_ID); else info_rel.audience = field_value; call GET_NEXT_FIELD (TOC_FIELD_ID, NEW_FEATURES_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, TOC_FIELD_ID); else info_rel.table_of_contents = field_value; call GET_NEXT_FIELD (NEW_FEATURES_FIELD_ID, RELEASE_SUPPORTED_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, NEW_FEATURES_FIELD_ID); else info_rel.new_features = field_value; call GET_NEXT_FIELD (RELEASE_SUPPORTED_FIELD_ID, ORDER_NUMBER_FIELD_ID, field_value, code); if code ^= 0 then call FILE_ERROR (code, RELEASE_SUPPORTED_FIELD_ID); else full_name_rel.release_supported = field_value; call PUT_DATA_IN_DB (); END_LOOP: end; call FINISH (); RETURN: return; %page; /* Finish and error handling */ FINISH: proc (); call dsl_$close (dbi, code); call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); goto RETURN; end FINISH; FORMAT_ERROR: proc (p_field_idx); dcl p_field_idx fixed bin; call com_err_ (0, myname, "Unexpected format encountered scanning for ^a field.^/Current line (line ^d) is: ^a^/Skipping to next record.", FIELD_NAME (p_field_idx), current_input_line_number, input_line); goto END_LOOP; end FORMAT_ERROR; FILE_ERROR: proc (p_code, p_field_idx); dcl p_code fixed bin (35); dcl p_field_idx fixed bin; call com_err_ (p_code, myname, "^/Error encountered scanning for ^a field.^/Current line (line ^d) is: ^a.", FIELD_NAME (p_field_idx), current_input_line_number, input_line); call FINISH (); goto RETURN; end FILE_ERROR; STORE_ERROR: proc (p_code, p_relation); dcl p_code fixed bin (35); dcl p_relation char (*); call com_err_ (p_code, myname, "^/Error encountered attempting to store ^a relation.^/Current line (line ^d) is: ^a.", p_relation, current_input_line_number, input_line); call FINISH (); goto RETURN; end STORE_ERROR; ERROR: proc (p_code, p_text); dcl p_code fixed bin (35); dcl p_text char (*); call com_err_ (p_code, myname, "^a.^/Current line (line ^d) is: ^a.", p_text, current_input_line_number, input_line); call FINISH (); goto RETURN; end ERROR; %page; /* SUPPORT SUBROUTINES */ CANONICALIZE_NAME: proc (p_name_string) returns (char (64) var); dcl p_name_string char (*) varying; dcl p_canonical_name char (64) var; dcl name_string char (128) var; name_string = p_name_string; name_string = translate (name_string, "__", "- "); do while (index (name_string, "__") ^= 0); name_string = before (name_string, "__") || "_" || after (name_string, "__"); end; p_canonical_name = translate (name_string, LOWER_CASE_ALPHA, UPPER_CASE_ALPHA); return (p_canonical_name); end CANONICALIZE_NAME; STRIP: proc (p_input_string) returns (char (*) var); dcl p_input_string char (*); dcl temp_varying_string char (1024) varying; dcl position_of_first_interesting_character fixed bin; position_of_first_interesting_character = verify (p_input_string, " "); if position_of_first_interesting_character > 0 then temp_varying_string = substr (p_input_string, position_of_first_interesting_character); else temp_varying_string = p_input_string; temp_varying_string = rtrim (ltrim (temp_varying_string)); if temp_varying_string = "" then return (" ") /* space */; else return (temp_varying_string); end STRIP; %page; GET_NEXT_FIELD: proc (p_field_idx, p_terminating_field_idx, p_field_value, p_code); dcl p_field_idx fixed bin; dcl p_terminating_field_idx fixed bin; dcl p_field_value char (*) varying; dcl p_code fixed bin (35); dcl (counter, nf_indentation_level) fixed bin; dcl temp_varying_string char (1024) varying; do counter = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (index (input_line, FIELD_INDICATOR (p_field_idx)) = 0); call GET_NEXT_INPUT_LINE (p_code); end; if p_code ^= 0 then call ERROR (p_code, ""); if counter >= LIMIT_TO_STOP_INFINITE_LOOPING then call ERROR (0, "Was in an unbounded loop."); goto FIELD (p_field_idx); FIELD (1): /* order number */ FIELD (2): /* manual name (full) */ FIELD (8): /* release supported */ temp_varying_string = STRIP (after (input_line, FIELD_INDICATOR (p_field_idx))); p_field_value = temp_varying_string; return; FIELD (3): /* short name */ temp_varying_string = STRIP (after (input_line, FIELD_INDICATOR (p_field_idx))); p_field_value = temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); do counter = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (p_code = 0 & index (input_line, FIELD_INDICATOR (p_terminating_field_idx)) = 0); temp_varying_string = STRIP (input_line); p_field_value = p_field_value || temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); end; return; FIELD (4): /* description */ FIELD (5): /* audience */ temp_varying_string = STRIP (after (input_line, FIELD_INDICATOR (p_field_idx))); p_field_value = temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); do counter = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (p_code = 0 & index (input_line, FIELD_INDICATOR (p_terminating_field_idx)) = 0); temp_varying_string = STRIP (input_line); p_field_value = p_field_value || " " || temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); end; return; FIELD (6): /* table of contents */ temp_varying_string = STRIP (after (input_line, FIELD_INDICATOR (p_field_idx))); p_field_value = temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); do counter = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (p_code = 0 & index (input_line, FIELD_INDICATOR (p_terminating_field_idx)) = 0); temp_varying_string = STRIP (input_line); p_field_value = p_field_value || NL || temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); end; temp_varying_string = ltrim (p_field_value, NL); p_field_value = rtrim (temp_varying_string, NL); return; FIELD (7): /* new features */ temp_varying_string = STRIP (after (input_line, FIELD_INDICATOR (p_field_idx))); p_field_value = temp_varying_string; nf_indentation_level = 0; call GET_NEXT_INPUT_LINE (p_code); do counter = 1 to LIMIT_TO_STOP_INFINITE_LOOPING while (p_code = 0 & index (input_line, FIELD_INDICATOR (p_terminating_field_idx)) = 0); if nf_indentation_level = 0 then nf_indentation_level = verify (input_line, " "); temp_varying_string = substr (input_line, nf_indentation_level); p_field_value = p_field_value || NL || temp_varying_string; call GET_NEXT_INPUT_LINE (p_code); end; temp_varying_string = ltrim (p_field_value, NL); p_field_value = rtrim (temp_varying_string, NL); return; end GET_NEXT_FIELD; %page; GET_NEXT_INPUT_LINE: proc (p_code); dcl p_code fixed bin (35); if ^input_file_is_open then do; call iox_$attach_ioname ("load_doc_db_dbf.f", iocb_ptr, "vfile_ " || input_file, null, p_code); if p_code ^= 0 then call ERROR (p_code, "While attaching input file"); call iox_$open (iocb_ptr, 1, "0"b, p_code); if p_code ^= 0 then call ERROR (p_code, "While openning input file."); current_input_line_number = 0; input_file_is_open = "1"b; end; call iox_$get_line (iocb_ptr, input_line_ptr, length (line_buffer), current_input_line_length, p_code); if p_code ^= 0 then call ERROR (p_code, ""); if current_input_line_length > 1024 then call ERROR (0, "Line too long for buffer."); current_input_line_number = current_input_line_number + 1; if substr (input_line, current_input_line_length) = NL then current_input_line_length = current_input_line_length - 1; return; end GET_NEXT_INPUT_LINE; %page; PUT_DATA_IN_DB: proc (); dcl temp_short_name char (128) varying; info_rel.manual_number, full_name_rel.manual_number, short_name_rel.manual_number, entry_name_rel.manual_number, name_rel.manual_number = full_name_rel.manual_number + 1; call dsl_$store (dbi, "full_name_rel", full_name_rel, code); if code ^= 0 then call STORE_ERROR (code, "full_name_rel"); call dsl_$store (dbi, "name_rel", name_rel, code); if code ^= 0 then call STORE_ERROR (code, "name_rel"); call dsl_$store (dbi, "info_rel", info_rel, code); if code ^= 0 then call STORE_ERROR (code, "info_rel"); temp_short_name = ""; do while (short_name_list ^= ""); temp_short_name = ltrim (before (short_name_list, ",")); if temp_short_name = "" then do; temp_short_name = short_name_list; short_name_list = ""; end; else short_name_list = after (short_name_list, ","); short_name_rel.short_name = temp_short_name; name_rel.name = CANONICALIZE_NAME (temp_short_name); temp_short_name = ""; call dsl_$store (dbi, "short_name_rel", short_name_rel, code); if code ^= 0 then if code = mdbm_error_$dup_store then code = 0; else call STORE_ERROR (code, "short_name_rel"); call dsl_$store (dbi, "name_rel", name_rel, code); if code ^= 0 then if code = mdbm_error_$dup_store then code = 0; else call STORE_ERROR (code, "name_rel"); end; return; end PUT_DATA_IN_DB; %page; %include online_doc; %page; %include online_doc_fields; end load_doc_db_dbf;  load_doc_db_ent.pl1 02/11/85 1139.6rew 02/11/85 1137.6 128196 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* format: style2 */ load_doc_db_ent: proc; /* DESCRIPTION: This command takes the AN50 master index listin file and stores it into the online_doc database. It strips entry names and topics from AN50 master index and stores them as entry_name attributes in the entry_name_rel relation in online_doc.db. */ /* HISTORY: Originally written by Jim Paradise, autumn 1980. Modified: 81-02-21 by M. Pierret: added cu_ calls, reformatted. 81-06-05 by M. Pierret: parse =name field to extract entry names, exclude parenthetical comments. 83-03-29 by M. Pierret: Changed to use structure database. 83-04-12 by M. Pierret: Added the -entry_name/-topic control args. They are used to specify whether entry names or topics are to be extracted from the input file. There are no short forms. This change was necessitated by a change in the format of the master index listin. 83-09-28 by M. Pierret: Made strip_blanks and index_end inline subroutines instead of including char_utils.incl.pl1. 85-02-08 by Steve Herbst: Fixed uninitialized -topic/-entry_name default and added cleanup handler, improved error messages. */ /* DESCRIPTION of PARAMETERS: mrds_db_path - is the pathname to the online_doc.db database input_file - is the pathname of the AN50 master index lister file. This program assumes the file is in the following format: { ... } { ... } first 3 lines are ignored { ... } ~ =manual _____ =nb AANN =rev _____ =name entry_value ~ =manual _____ =nb AANN =rev _____ =name entry_value . . . -or- ~ =manual _____ =nb AANN =rev _____ =topic topic_value ~ =manual _____ =nb AANN =rev _____ =topic topic_value . . . The =rev field may or may not be present. entry_value may be of the forms: entry_name entry_name (comment -not to be stored) entry_name {short_name} entry_name {short_name} (comment - not to be stored) topic_value may be one of: topic topic of multiple words topic of multiple words (comment - to be stored) Everything that is stored is first converted to lower-case to provide a canonical version for searching. */ /* ERRORS: Any of the errors possible from trying to read a listing segment via vfile_ unstructured read. Any of the errors possible from trying to store data into a MRDS database. ------------------------------------------------------------ NOTES: This command should use cu_$ entries. This command should use the xxx{.listin} convention. ------------------------------------------------------------ */ %page; /* Constants */ dcl ME char (32) int static options (constant) init ("load_doc_db_ent"); dcl (NORMAL_EXIT init (1), ON_CLEANUP init (2)) fixed bin int static options (constant); dcl LOWER_CASE_ALPHA char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); dcl UPPER_CASE_ALPHA char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); dcl NL char (1) int static options (constant) init (" "); /* Based */ dcl arg char (arg_len) based (arg_ptr); /* Automatic */ dcl order_number char (32) varying; dcl last_error_order_number char (32) varying; dcl manual_number fixed bin; dcl name_field char (64) varying; dcl entry_name char (64) varying; dcl topic_or_entry_name_field_indicator char (8) varying; dcl line char (1024) var; dcl begin_char char (1) var; dcl end_char char (1); dcl next_char char (1); dcl tuple_name char (30); dcl mrds_db_path char (168); dcl input_file char (168); dcl arg_len fixed bin (21); dcl return_arg_len fixed bin (21); dcl dbi fixed bin (35); dcl nargs fixed bin; dcl pos_after_nb fixed; dcl pos_after_name fixed; dcl end_of_nb_field fixed; dcl dummy_idx fixed bin; dcl num_lines_read fixed; dcl code fixed (35); dcl arg_ptr ptr; dcl iocb_ptr ptr; dcl return_arg_ptr ptr; dcl exitting_sw bit (1) init ("0"b); dcl more_names_are_present bit (1); dcl open bit (1) init ("0"b); dcl is_active_function bit (1) aligned; /* External */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl iox_$error_output ptr ext; dcl mdbm_error_$dup_store fixed bin (35) ext; /* Entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl absolute_pathname_$add_suffix entry (char (*), char (*), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl iox_$attach_ioname entry (char (*), ptr, char (*), ptr, fixed (35)); dcl iox_$open entry (ptr, fixed, bit (1) aligned, fixed (35)); dcl iox_$get_line entry (ptr, ptr, fixed (21), fixed (21), fixed (35)); dcl iox_$close entry (ptr, fixed (35)); dcl iox_$detach_iocb entry (ptr, fixed (35)); dcl dsl_$open entry options (variable); dcl dsl_$store entry options (variable); dcl dsl_$close entry options (variable); dcl dsl_$retrieve entry options (variable); /* Builtins */ dcl (addr, after, before, index, length, ltrim, null, rtrim, substr, translate, verify) builtin; /* Conditions */ dcl cleanup condition; %page; /* Get the two arguments to this command: mrds_db_path and input_file. Return if the arguments are not found or if they refer to objects that do not exist. */ call cu_$af_return_arg (nargs, return_arg_ptr, return_arg_len, code); if code = 0 then is_active_function = "1"b; else if code = error_table_$not_act_fnc then is_active_function = "0"b; else do; call com_err_ (code, ME); return; end; if (nargs ^= 2 & nargs ^= 3) | is_active_function then do; call com_err_$suppress_name (0, ME, "Usage: ^a database_path input_file {-topic | -entry_name}", ME); return; end; call cu_$arg_ptr (1, arg_ptr, arg_len, code); call absolute_pathname_$add_suffix (arg, "db", mrds_db_path, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; call cu_$arg_ptr (2, arg_ptr, arg_len, code); call absolute_pathname_$add_suffix (arg, "listin", input_file, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); return; end; if nargs = 3 then do; call cu_$arg_ptr (3, arg_ptr, arg_len, code); if arg = "-topic" then topic_or_entry_name_field_indicator = " =topic"; else if arg = "-entry_name" then topic_or_entry_name_field_indicator = " =name"; else do; call com_err_ (error_table_$badopt, ME, "Usage: ^a {-topic|-entry_name}", ME); return; end; end; else topic_or_entry_name_field_indicator = " =name"; manual_number = 0; last_error_order_number = ""; /* Establish cleanup handler */ dbi = -1; iocb_ptr = null; on cleanup call clean_up (ON_CLEANUP); /* Open the MRDS database */ call dsl_$open (mrds_db_path, dbi, 4, code); call check_code ("Calling dsl_$open on " || mrds_db_path); /* Skip the first three lines */ do dummy_idx = 1 to 3; call read_line; end; /* Loop through the records, storing */ do while ("1"b); call read_line_to_eof; pos_after_nb = index_end (line, "=nb "); if pos_after_nb <= 0 then call syntax_error ("Missing ""=nb"""); end_of_nb_field = index (line, " =rev"); if end_of_nb_field <= 0 then do; end_of_nb_field = index (line, topic_or_entry_name_field_indicator); if end_of_nb_field <= 0 then call syntax_error ("Missing ""=name"" or ""=topic"""); end; order_number = rtrim (substr (line, pos_after_nb, end_of_nb_field - pos_after_nb)); call strip_blanks (order_number); if length (order_number) ^= 4 then call syntax_error ("Order number must be 4 characters long."); call dsl_$retrieve (dbi, "-range (x full_name_rel) -select x.manual_number -where x.order_number = .V.", order_number, manual_number, code); if code ^= 0 then do; if order_number ^= last_error_order_number then call com_err_ (code, ME, "^/Order number ^a not found in MRDS database.", order_number); last_error_order_number = order_number; go to END_LOOP; end; pos_after_name = index_end (line, topic_or_entry_name_field_indicator || " "); if pos_after_name <= 0 then call syntax_error ("Wrong delimiter after ""=name"" or ""=topic"""); name_field = substr (line, pos_after_name); call strip_blanks (name_field); if name_field = " " then call syntax_error ("Blank ""=name"" or ""=topic"" value."); /* Canonicalize name to lower-case and single blanks */ do while (index (name_field, " ") ^= 0); /* search for two consecutive blanks*/ name_field = before (name_field, " ") || " " || after (name_field, " "); end; name_field = translate (name_field, LOWER_CASE_ALPHA, UPPER_CASE_ALPHA); /* name_field's which have "{"s in them contain multiple names, and each must be extracted. Those that have no " "s are single names and should be stored as is. Those that have a "(" following the first " " are single entry or subsystem names with parenthetical comments; the single name should be stored. In all of these cases the parenthetical comments should be discarded. If none of these conditions is present, one can assume that the name_field contains a section title, and parenthetical comments should be retained. Ex: print (LINUS request) => print print {pr} (read_mail) => print => pr print => print Interrupted I/O (BOS) => Interrupted I/O (BOS) */ if index (name_field, " ") = 0 then end_char = NL; /* case: single entry name */ else do; next_char = substr (after (name_field, " "), 1, 1); if next_char = "{" | /* case: entry name followed by short name(s) */ next_char = "(" /* case: entry name followed by parenthetical comment */ then end_char = " "; else end_char = NL; /* case: multiple word topic */ end; begin_char = ""; tuple_name = "entry_name_rel"; more_names_are_present = "1"b; do while (more_names_are_present); entry_name = before (name_field, end_char); entry_name = after (entry_name, begin_char); call strip_blanks (entry_name); name_field = after (name_field, end_char); call strip_blanks (name_field); begin_char = "{"; end_char = "}"; if index (name_field, begin_char) = 0 then more_names_are_present = "0"b; call dsl_$store (dbi, tuple_name, entry_name, manual_number, code); if code ^= 0 then if code ^= mdbm_error_$dup_store then call com_err_ (code, ME, "^/(^d) ^a", num_lines_read, line); end; END_LOOP: end; RETURN: call clean_up (NORMAL_EXIT); return; %page; clean_up: proc (P_when); dcl P_when fixed bin; exitting_sw = "1"b; if dbi ^= -1 then do; call dsl_$close (dbi, code); if P_when = NORMAL_EXIT then call check_code ("dsl_$close"); end; call iox_$close (iocb_ptr, code); if P_when = NORMAL_EXIT then call check_code ("iox_$close"); call iox_$detach_iocb (iocb_ptr, code); if P_when = NORMAL_EXIT then call check_code ("iox_$detach_iocb"); end clean_up; %page; syntax_error: proc (P_str); dcl P_str char (*); call ioa_$ioa_switch (iox_$error_output, "*** Syntax error on line ^d: ^a^/Text of line: ^a", num_lines_read, P_str, line); goto END_LOOP; end syntax_error; %page; /* SUPPORT SUBROUTINES */ strip_blanks: proc (string); dcl string char (*) var; dcl temp_string char (1024) varying; dcl first_char_pos fixed bin; first_char_pos = verify (string, " "); /* space, tab */ if first_char_pos > 0 then temp_string = substr (string, first_char_pos); else temp_string = string; if temp_string = "" then string = " "; else string = rtrim (temp_string); return; end; index_end: proc (string, search) returns (fixed); dcl string char (*) varying; dcl search char (*) varying; dcl last_char_pos fixed bin; dcl first_char_pos fixed bin; first_char_pos = index (string, search); if first_char_pos ^= 0 then last_char_pos = first_char_pos + length (search); else last_char_pos = first_char_pos; return (last_char_pos); end index_end; check_code: proc (str); dcl str char (*); if code = 0 then return; call com_err_ (code, ME, str); return; end check_code; %page; /* get line from input file */ read_line: proc; dcl buff_ptr ptr; dcl num_chars fixed (21); dcl buffer char (10000); dcl expect_eof bit (1); expect_eof = "0"b; start: buff_ptr = addr (buffer); if ^open then do; call iox_$attach_ioname ("f", iocb_ptr, "vfile_ " || input_file, null, code); call check_code ("iox_$attach_ioname"); call iox_$open (iocb_ptr, 1, "0"b, code); call check_code ("iox_$open"); num_lines_read = 0; open = "1"b; end; call iox_$get_line (iocb_ptr, buff_ptr, length (buffer), num_chars, code); if code ^= 0 then goto error1; if num_chars > 10000 then goto error1; num_lines_read = num_lines_read + 1; line = substr (buffer, 1, num_chars); if substr (line, length (line)) = NL then line = substr (line, 1, length (line) - 1); return; error1: if ^expect_eof then call com_err_ (code, ME, " ^d ^d ^a", num_lines_read, num_chars, substr (buffer, 1, num_chars)); go to RETURN; read_line_to_eof: entry; expect_eof = "1"b; goto start; end read_line; end load_doc_db_ent; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved