



		    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:	____
     _____
<nl>
*/
/* 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 <database path> <input file>", 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 <database path> <input file> {-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
