



		    PNOTICE_extensions.alm          11/14/89  1129.9r w 11/14/89  1129.9        2853



	dec	1			"version 1 structure
	dec	1			"no. of pnotices
	dec	3			"no. of STIs
	dec	100			"lgth of all pnotices + no. of pnotices
          acc       "Copyright (c) 1989 by Massachusetts Institute of
Technology and Honeywell Information Systems, Inc."

	aci	"C1MSSM0E0000"
	aci	"C2MSSM0E0000"
	aci	"C3MSSM0E0000"
	end




		    add_pnotice.pl1                 12/01/87  1042.3rew 12/01/87  0913.1      918459



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(81-06-01,Stansbury), approve(), audit(), install():
     Created.
  2) change(82-10-01,Stansbury), approve(), audit(), install():
     Modified - Changed the treatment of Lisp comment conventions from
     use of one semicolon to three semicolons, which is desired by
     various Lisp language formatters.
  3) change(82-11-01,Stansbury), approve(), audit(), install():
     Modified - Added functionality to (add display)_pnotice to support
     public domain notices.  This functionality is invoked with the
     -public_domain control argument for add_pnotice. A public domain
     pnotice is expected to have the name "public_domain.pnotice".
     There should only be one such template.
  4) change(83-06-01,Stansbury), approve(), audit(), install():
     Modified - Made display_pnotice smart enough to find embedded trade
     secret and public domain pnotices. Fixed miscellaneous bugs.
  5) change(85-09-27,LJAdams), approve(85-09-27,MCR7150),
     audit(86-05-19,Gilcrease), install(86-02-13,MR12.0-1017):
      - Removed the date from the template names.
      - Changed add_pnotice to allow multiple component prefixes for template
        names.
      - Added the default arguments -dc and -dts.
      - Default pnotices are no longer automatically applied if there are no
        existing pnotices.
      - The -long and -brief arguments have been added; -long is the default
        as -brief prints nothing.
      - Two new language types have been added.  Type 4 has a /****^ as a
        comment delimiter; this allows format pl1 to work properly on history
        comments.  Type 5 is for runoff and compose files. Blank lines will
        not be inserted before and after the history comment as they are
        interpeted as space blocks by compose.
  6) change(86-04-17,LJAdams), approve(86-05-05,MCR7393),
     audit(86-05-19,Gilcrease), install(86-09-05,MR12.0-1071):
     Change so that if the -long argument is specified , default copyrights
     will print if they have been added.
  7) change(86-09-05,LJAdams), approve(86-09-05,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Corrected looping problem with pnotices in invalid format.
     
     Corrected problem of losing a character when adding pnotice without
     the -nm option.
     
     phx20632 - was not picking up DEFAULT TRADE SECRET pnotices.
     
     phx20629 - suggestion was made to use error_table_$bad_file_name
     instead of error_table_$badstar.
  8) change(87-04-17,LJAdams), approve(87-04-20,MCR7674),
     audit(87-05-04,Gilcrease), install(87-05-08,MR12.1-1031):
     Add HBULL copyright as the default if the most recent pnotice is HIS,
     HIS_A, HIS_B, MIT_HIS, or MIT_HIS_A.
  9) change(87-11-09,LJAdams), approve(87-11-10,MCR7805),
     audit(87-11-30,Wallman), install(87-12-01,MR12.2-1007):
     Do not add blank line after pnotice box for compin or runoff files as they
     are interpreted as space blocks by compose.
                                                   END HISTORY COMMENTS */

/* format: style2,ind2,ll79,dclind4,idind15,comcol41,linecom,ifthenstmt*/
/* for mat: style2,ind2,ll131,dclind4,idind15,comcol41,linecom,ifthenstmt*/
add_pnotice:
  proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This command is used to insert software protection copyright or Trade Secret notices	*/
/* into source programs. The code is entirely new, it replaces the add_copyright and	*/
/* copyright_archive commands. This command uses the pnotice search list to find the text	*/
/* of protection notices to add. The default search directory for this search list is	*/
/* >tools. The command also uses the pnotice_language_info_ database (created by CDS) to  */
/* obtain information on the source language segment.				*/
/*									*/
/* ENTRY:	    display_pnotice							*/
/*									*/
/* This is the command used to print either the entire text of protection notices, or	*/
/* their primary names, as found in source programs. Since so much of the code is	*/
/* shareable, it is a separate external entry in add_pnotice.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* INTERNAL PROCEDURES IN THIS PROGRAM. THESE ARE LISTED IN THE ORDER THAT THEY EXIST	*/
/* INLINE, AS WELL AS THE MOST FREQUENT PATH OF EXECUTION.				*/
/*									*/
/* Name		       Brief description					*/
/* init_structures	       sets variables in the source_info and target_info structures.	*/
/* process_archive_components							*/
/*		       main internal proc to begin archive processing.		*/
/* process_single_seg      main internal proc to begin free standing segment processing.	*/
/* get_language_info       obtains per-language parameters like comment delimiters, etc.	*/
/* pnotice_parse	       finds the extents of a notice box, if any.			*/
/* process_tokens	       drives the parsing procedures to locate notices.		*/
/* parse_source_           primitive that provides mechanism for finding source tokens.	*/
/* parse_templates_        primitive that provides mechanism for finding template tokens.	*/
/* find_line	       used by parsing procs for processing line-by-line.		*/
/* continue_processing     function providing testing for further processing.		*/
/* sort_pnotices	       sorts >1 notice into proper order.			*/
/* ok_nine_year_rule       enforces LISD rule for new notices.			*/
/* make_star_box	       forms text and new star box for insertion.			*/
/* add_text	       builds new star box line-by-line.			*/
/* check_acl	       provides for possible need to force access.		*/
/* insert_notice	       puts new star box into proper place in a segment.		*/
/* reset_acl	       provides mechanism to reset any forced access.		*/
/* report		       used ONLY by display_pnotice to print output.		*/
/* clean_up	       standard clean up proc.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

%page;



/*  A U T O M A T I C  */
    dcl current_year   fixed bin,
        current_year_a char (4),
        DFcopy_right   bit (1),	/* flag for default copyright			*/
        DFtrade_secret bit (1),	/* flag for default trade secret		*/
        Farchive	   bit (1),	/* flag to indicate an archive		*/
        Fdisplay	   bit (1),	/* ON if the display_pnotice entry called	*/
        Fcopy_right	   bit (1),	/* ON if default copyright given		*/
        Fmode_set	   bit (1),
        Fmust_reset	   bit (1),	/* ON if access is forced.			*/
        Fname	   bit (1),	/* ON if a copyright template name given	*/
        Fpublic_domain bit (1),	/* ON if -public_domain given			*/
        Ftrade_secret  bit (1),	/* ON if -trade_secret given			*/
        i		   fixed bin (24),
        Iarg	   fixed bin,
        Idx1	   fixed bin (24),
        Itemplate	   fixed bin (24),	/* index for templates			*/
        Larg	   fixed bin (21),
        ME	   char (32),
        Nargs	   fixed bin,
        Parg	   ptr,
        bit_count	   fixed bin (24),
        code	   fixed bin (35),
        common_archive_name
		   char (32),
        component	   char (32),	/* component name in archive if any		*/
        doing_all_components
		   bit (1),
        path	   char (168),	/* pathname input to command			*/
        pdir	   char (168) var,
        process_dir	   char (168),	/* used by get_pdir_			*/
        save_name	   char (32),	/* used to save template name			*/
        save_text	   char (512) var,	/* used to save template text			*/
        seqno	   fixed bin (18),	/* order templates occur in text		*/
        SI_yrno	   fixed bin (24),	/* seq of yr in source			*/
        Sadd_default_pnotice
		   bit (1),
        Sdfcopyright   bit (1),
        Sno_args_given bit (1),
        Sold_style_pnotice
		   bit (1),	/* cmt_bgn delimiter is a slash/asterick	*/
        Sprt_notice	   bit (1),	/* print notice if -lg and new notices was added  */
        source_year	   (10) fixed bin,	/* yr in pgm requesing pnotice		*/
        source_year_a  (10) char (4),
        used_old_argument
		   bit (1);	/* flag for old arg usage			*/



/*  E X T E R N A L   E N T R I E S  */
    dcl add_char_offset_
		   entry (ptr, fixed bin (21)) returns (ptr) reducible,
        archive	   entry options (variable),
        archive_$get_component
		   entry (ptr, fixed bin (24), char (*), ptr,
		   fixed bin (24), fixed bin (35)),
        archive_$next_component
		   entry (ptr, fixed bin (24), ptr, fixed bin (24),
		   char (*), fixed bin (35)),
        char_offset_   entry (ptr) returns (fixed bin (21)) reducible,
        check_star_name_$entry
		   entry (char (*), fixed bin (35)),
        com_err_	   entry () options (variable),
        cu_$arg_count  entry (fixed bin, fixed bin (35)),
        cu_$arg_ptr	   entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
        cu_$generate_call
		   entry (entry, ptr),
        date_time_$format
		   entry (char (*), fixed bin (71), char (*), char (*))
		   returns (char (250) var),
        expand_pathname_$component
		   entry (char (*), char (*), char (*), char (*),
		   fixed bin (35)),
        get_ec_version_
		   entry (char (*), char (*), fixed bin, fixed bin (21),
		   fixed bin (35)),
        get_group_id_  entry () returns (char (32)),
        get_pdir_	   entry () returns (char (168)),
        get_temp_segment_
		   entry (char (*), ptr, fixed bin (35)),
        hcs_$add_acl_entries
		   entry (char (*), char (*), ptr, fixed bin,
		   fixed bin (35)),
        hcs_$delentry_seg
		   entry (ptr, fixed bin (35)),
        hcs_$delete_acl_entries
		   entry (char (*), char (*), ptr, fixed bin,
		   fixed bin (35)),
        hcs_$initiate_count
		   entry (char (*), char (*), char (*), fixed bin (24),
		   fixed bin (2), ptr, fixed bin (35)),
        hcs_$list_acl  entry (char (*), char (*), ptr, ptr, ptr, fixed bin,
		   fixed bin (35)),
        hcs_$make_seg  entry (char (*), char (*), char (*), fixed bin (5), ptr,
		   fixed bin (35)),
        ioa_	   entry () options (variable),
        pathname_	   entry (char (*), char (*)) returns (char (168)),
        pathname_$component
		   entry (char (*), char (*), char (*))
		   returns (char (194)),
        pnotice_mlr_   entry (ptr, fixed bin (21), ptr, fixed bin (21)),
        pnotice_mrl_   entry (ptr, fixed bin (21), ptr, fixed bin (21)),
        pnotice_paths_ entry (char (*), bit (*), ptr, fixed bin (35)),
        release_temp_segment_
		   entry (char (*), ptr, fixed bin (35)),
        terminate_file_
		   entry (ptr, fixed bin (24), bit (*), fixed bin (35));


/*  I N T E R N A L   S T A T I C  */
    dcl Inconsistent_args
		   char (132) varying int static
		   init (
		   "^/The ""^a"" and ""^a"" may not be used together"),
        Not_found	   char (132) varying int static
		   init (
		   "^/""^a"" not found in the pnotice search list.^/Use list pnotice_names to list valid names."
		   ),
        True	   bit (1) int static options (constant) init ("1"b),
        False	   bit (1) int static options (constant) init ("0"b),
        sfx_string	   char (3) int static options (constant) init (" *
"),
        STAR	   char (1) int static options (constant) init ("*"),
        STARS	   char (200) int static options (constant)
		   init ((200)"*"),
        SP_STAR	   char (2) int static options (constant) init (" *"),
        SP_STAR_SP	   char (3) int static options (constant) init (" * "),
        HT_SP_STAR	   char (3) int static options (constant) init ("	 *"),
        HT_SP_NL	   char (3) int static options (constant) init ("	 
"),
        SP	   char (1) int static options (constant) init (" "),
        SPACES	   char (200) int static options (constant)
		   init ((200)" "),
        NL	   char (1) int static options (constant) init ("
"),
        NL_NL	   char (2) int static options (constant) init ("

"),
        HT_SP_NL_VT_NP char (5) int static options (constant) init ("	 
");



/*  E X T E R N A L   S T A T I C  */
    dcl (
        error_table_$archive_component_modification,
        error_table_$badopt,
        error_table_$bad_file_name,
        error_table_$improper_data_format,
        error_table_$inconsistent,
        error_table_$noarg,
        error_table_$not_done,
        error_table_$name_not_found,
        error_table_$nostars,
        error_table_$typename_not_found,
        error_table_$wrong_no_of_args
        )		   fixed bin (35) ext static;


/*  B U I L T I N  */
    dcl (addr, addrel, addcharno, before, char, charno, clock, convert,
        currentsize, dim, divide, hbound, index, length, lbound, ltrim, max,
        null, ptr, reverse, rtrim, search, string, substr, verify)
		   builtin;


/*  B A S E D  */
    dcl argument	   char (Larg) based (Parg);
				/* used to obtain args			*/


/*  C O N D I T I O N S  */
    dcl (cleanup, not_in_write_bracket, no_write_permission)
		   condition;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

    ME = "add_pnotice";		/* the add_pnotice command			*/
    Fdisplay = False;
    goto COMMON;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


display_pnotice:
  entry;

    ME = "display_pnotice";		/* the display_pnotice command		*/
    Fdisplay = True;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


COMMON:
    arg_list_arg_count = 0;
    Ppaths = null;
    Pcomp_info = null;
    Ptext = null;
    path = "";
    Farchive = False;
    Sprt_notice = False;
    current_year_a = date_time_$format ("^9999yc", clock (), "", "");
    current_year = convert (current_year, current_year_a);
    doing_all_components = False;
    call init_structures (source_info, target_info);
				/* init source and target info structures	*/


    on cleanup call clean_up;

    target_info.long_output = True;	/* default output				*/
    call init_variables;

    call cu_$arg_count (Nargs, code);
    if code ^= 0
    then
      do;
        call com_err_ (code, ME, "");
        return;
      end;
    if Nargs = 0
    then
      do;
        call ioa_ (
	   "Syntax:  ^a path {-control_args} For details, type:  help ^a",
	   ME, ME);
        return;
      end;
    do Iarg = 1 to Nargs;
      call cu_$arg_ptr (Iarg, Parg, Larg, code);
      if index (argument, "-") ^= 1
      then
        do;
	if path = ""
	then path = argument;
	else
	  do;
	    call com_err_ (error_table_$wrong_no_of_args, ME, "^a
Multiple pathnames not allowed.", argument);
	    goto FATAL_ERROR;
	  end;
        end;
      else if (argument = "-trade_secret" | argument = "-public_domain")
      then
        do;
	used_old_argument = True;
	if argument = "-trade_secret" & ^Fdisplay then Ftrade_secret = True;
	else if argument = "-public_domain" & ^Fdisplay
	then Fpublic_domain = True;
        end;
      else if (argument = "-dts" | argument = "-default_trade_secret")
	 & ^Fdisplay
      then DFtrade_secret = True;
      else if (argument = "-dc" | argument = "-default_copyright") & ^Fdisplay
      then DFcopy_right = True;
      else if (argument = "-name" | argument = "-nm") & ^Fdisplay
      then
        do;
	Iarg = Iarg + 1;
	call cu_$arg_ptr (Iarg, Parg, Larg, code);
	if code ^= 0
	then
	  do;
NAME_ERR:
	    call com_err_ (code, ME, "
The -name control arg requires a pnotice name operand.
Use the list_pnotice_names command to print valid names.");
	    return;
	  end;
	if index (argument, ".") ^= 0
	then
	  do;
	    if reverse (before (reverse (argument), ".")) = "pnotice"
	    then
	      do;
	        code = error_table_$improper_data_format;
	        goto NAME_ERR;
	      end;
	    else ;
	  end;
	if argument = "public_domain" then Fpublic_domain = True;
	if reverse (before (reverse (argument), ".")) = "trade_secret"
	then
	  do;
	    Ftrade_secret = True;
	    Fname = True;
	    source_info.notice_to_add.name = argument;
	  end;
	else
	  do;
	    source_info.notice_to_add.name = argument;
	    Fname = True;
	  end;
        end;			/* argument = -nm			*/
      else if argument = "-long" | argument = "-lg"
      then target_info.long_output = True;
      else if argument = "-brief" | argument = "-bf"
      then target_info.long_output = False;
      else
        do;
	code = error_table_$badopt;
	call com_err_ (code, ME);
	goto FATAL_ERROR;
        end;
    end;				/* Iarg = 1 to Nargs			*/

    if Fdisplay
    then
      do;				/* No pnotices are being added		*/
        call init_variables;
        goto GET_TEMPLATES;
      end;

    if used_old_argument & Ftrade_secret & Fname
    then
      do;
        code = error_table_$inconsistent;
        call com_err_ (code, ME, Inconsistent_args, "-trade_secret", "-name");
        goto FATAL_ERROR;
      end;
    if DFtrade_secret & Fname
    then
      do;
        code = error_table_$inconsistent;
        call com_err_ (code, ME, Inconsistent_args, "-default_trade_secret",
	   "-name");
        goto FATAL_ERROR;
      end;
    if used_old_argument & Fpublic_domain & Fname
    then
      do;
        code = error_table_$inconsistent;
        call com_err_ (code, ME, Inconsistent_args, "-public_domain", "-name");
        goto FATAL_ERROR;
      end;
    if Fpublic_domain & (Ftrade_secret | DFtrade_secret)
    then
      do;
        code = error_table_$inconsistent;
        call com_err_ (code, ME,
	   "The ""-public_domain"" control arg must be used alone.");
        goto FATAL_ERROR;
      end;
    if DFcopy_right & Fname
    then
      do;
        code = error_table_$inconsistent;
        call com_err_ (code, ME, Inconsistent_args, "-default_copyright",
	   "-name");
        goto FATAL_ERROR;
      end;
GET_TEMPLATES:
    if path = ""
    then
      do;
        call com_err_ (error_table_$noarg, ME, "
No pathname specified.");
        goto FATAL_ERROR;
      end;

/* do some data gathering and checking first	*/


    call pnotice_paths_ (ME, "00"b, Ppaths, code);
				/* fill in template info			*/
    if code ^= 0
    then				/* pnotice_paths_ will complain for us.		*/
         goto FATAL_ERROR;		/* things won't work this way			*/


    if Fdisplay
    then				/* no pnotices to add			*/
         goto EXPAND_PATH;

/* find out what notice we should add		*/
    if (Ftrade_secret & ^Fname) | DFtrade_secret
    then
      do;
        do Itemplate = 1 to pnotice_paths.Ntemplates
	   while (^pnotice_paths.templates (Itemplate).defaultTS);
        end;
        if Itemplate > pnotice_paths.Ntemplates
        then
	do;
	  code = error_table_$name_not_found;
	  call com_err_ (code, ME, Not_found, "default_trade_secret");
	  goto FATAL_ERROR;
	end;
        else source_info.notice_to_add.name =
	        before (pnotice_paths.templates (Itemplate).primary_name,
	        ".pnotice");
        source_info.notice_to_add.type = TRADE_SECRET;
      end;
    else if Fpublic_domain
    then
      do;				/* if public domain is desired		*/
        do Itemplate = 1 to pnotice_paths.Ntemplates
	   while (pnotice_paths.templates (Itemplate).type ^= PUBLIC_DOMAIN);
        end;			/* verify that the name is there.		*/
        if Itemplate > pnotice_paths.Ntemplates
        then
	do;
	  code = error_table_$name_not_found;
	  call com_err_ (code, ME, Not_found, "public_domain");
	  goto FATAL_ERROR;
	end;
        else source_info.notice_to_add.name =
	        before (pnotice_paths.templates (Itemplate).primary_name,
	        ".pnotice");
        source_info.notice_to_add.type = PUBLIC_DOMAIN;
      end;
    else if (Fname & Ftrade_secret & ^used_old_argument)
         | (Fname & ^DFtrade_secret) | (Fname & ^Fpublic_domain)
    then
      do;				/* if a template name was given,		*/
        do Itemplate = 1 to pnotice_paths.Ntemplates
	   while (source_info.notice_to_add.name
	   ^=
	   before (pnotice_paths.templates (Itemplate).primary_name,
	   ".pnotice"));
        end;			/* verify that the name is there.		*/
        if Itemplate > pnotice_paths.Ntemplates
        then
	do;
	  code = error_table_$name_not_found;
	  call com_err_ (code, ME, Not_found, source_info.notice_to_add.name)
	       ;
	  goto FATAL_ERROR;
	end;
        if Ftrade_secret
        then source_info.notice_to_add.type = TRADE_SECRET;
        else source_info.notice_to_add.type = COPYRIGHT;
      end;
    else
      do;				/* use default copyright			*/
        do Itemplate = 1 to pnotice_paths.Ntemplates
	   while (^pnotice_paths.templates (Itemplate).defaultC);
        end;
        if Itemplate > pnotice_paths.Ntemplates
        then
	do;
	  code = error_table_$name_not_found;
	  call com_err_ (code, ME, Not_found, "default_copyright");
	  goto FATAL_ERROR;
	end;
        else
	do;			/* input name if none of above criteria met	*/
	  source_info.notice_to_add.name =
	       before (pnotice_paths.templates (Itemplate).primary_name,
	       ".pnotice");
	  source_info.notice_to_add.type = COPYRIGHT;
	  if ^DFcopy_right then Sno_args_given = True;
	  Sdfcopyright = True;
	end;
      end;			/* default copyright			*/
EXPAND_PATH:			/* now work on the path we were given		*/
    call expand_pathname_$component (path, source_info.dir, source_info.entry,
         component, code);		/* xlate the input path into dir, entry and	*/
				/*  component				*/
				/* comp is null unless archive component given	*/


    if code ^= 0
    then
      do;
        call com_err_ (code, ME, path);
        goto FATAL_ERROR;
      end;
    target_info.dir = source_info.dir;	/* fill in target info directory name		*/
    if index (source_info.entry, ".") = 0
    then
      do;
        code = error_table_$bad_file_name;
        if source_info.archive_name ^= ""
        then call com_err_ (code, ME,
	        "^/Entry must include language suffix. ^a",
	        pathname_$component (source_info.dir,
	        source_info.archive_name, source_info.entry));
        else call com_err_ (code, ME,
	        "^/Entry must include language suffix. ^a",
	        pathname_ (source_info.dir, source_info.entry));
        goto FATAL_ERROR;
      end;
    call check_star_name_$entry (source_info.entry, code);
    if code ^= 0
    then
      do;
        code = error_table_$nostars;
        call com_err_ (code, ME, "^/Processing ^a.",
	   pathname_ (source_info.dir, source_info.entry));
        goto FATAL_ERROR;
      end;
    if component ^= ""
    then
      do;
        call check_star_name_$entry (component, code);
        if code ^= 0
        then
	do;
	  code = error_table_$nostars;
	  call com_err_ (code, ME, "^/Processing ^a.",
	       pathname_$component (source_info.dir, source_info.entry,
	       component));
	  goto FATAL_ERROR;
	end;
        Farchive = True;		/* it is an archive				*/
      end;
    else if component = ""
    then if reverse (before (reverse (source_info.entry), ".")) = "archive"
         then Farchive = True;	/* we have been given an archive to deal with	*/
    call hcs_$initiate_count (source_info.dir, source_info.entry, "",
         bit_count, 0, source_info.Pentry, code);
				/* initiate segment				*/
    if source_info.Pentry = null
    then
      do;
        call com_err_ (code, ME, "^/Initiating ^a.",
	   pathname_ (source_info.dir, source_info.entry));
        goto FATAL_ERROR;
      end;
    source_info.Lentry = divide (bit_count, 9, 21, 0);
				/* compute its length			*/
    if Farchive
    then
      do;
        process_dir = get_pdir_ ();	/*  we need this with archives		*/
        pdir = rtrim (process_dir);
        source_info.archive_name = source_info.entry;
        common_archive_name = source_info.archive_name;
				/* used by display_pnotice			*/
        source_info.entry = component;
        source_info.Parchive = source_info.Pentry;
        source_info.Larchive = source_info.Lentry;
        target_info.archive_name = source_info.archive_name;
        target_info.Parchive = source_info.Pentry;
        target_info.Larchive = source_info.Lentry;
        if Fdisplay
        then call ioa_ ("^a^[>^]^a:", source_info.dir, source_info.dir ^= ">",
	        source_info.archive_name);
        call process_archive_components (source_info, target_info);
      end;
    else
      do;
        source_info.archive_name = "";
        source_info.Parchive = null;
        source_info.Larchive = 0;
        target_info.archive_name = "";
        target_info.Parchive = null;
        target_info.Larchive = 0;
        target_info.entry = source_info.entry;
        target_info.Pentry = source_info.Pentry;
        target_info.Lentry = source_info.Lentry;
        call process_single_seg (source_info, target_info);
      end;
NORMAL_EXIT:
FATAL_ERROR:
    call clean_up;
    return;


%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

init_structures:
  proc (SI, TI);

    dcl 1 SI	   aligned like source_info,
        1 TI	   aligned like target_info;

    SI.version = V_source_info_1;
    TI.version = V_target_info_1;
    SI.archive_name = "";

init_structures$next_component:
  entry (SI, TI);			/* this entry is used when an archive is processed*/
				/* to avoid resetting the archive_name		*/
    SI.Pentry = null;
    SI.ec_version = 0;
    SI.text_pos = 0;
    SI.cmt_bgn = "";
    SI.cmt_end = "";
    SI.Pold_box = null;
    SI.Lold_box = 0;
    SI.Nnotices = 0;
    SI.notice_info (*).notice_name = "";
    SI.notice_info (*).notice_date = "";
    SI.notice_info (*).notice_type = 0; /* UNDEFINED				*/
    TI.Pnew_box = null;
    TI.Lnew_box = 0;
    TI.Pstar_box = null;
    TI.Lstar_box = 0;
    TI.Nnotices = 0;
    seqno = 0;
    TI.notice (*) = "";

  end init_structures;

%page;
init_variables:
  proc;
    Fname = False;			/* init vars used in arg processing		*/
    Fcopy_right = False;
    DFcopy_right = False;
    DFtrade_secret = False;
    Sadd_default_pnotice = False;
    Sdfcopyright = False;
    Sno_args_given = False;
    Fpublic_domain = False;
    Ftrade_secret = False;
    used_old_argument = False;
    source_info.notice_to_add.name = "";
    source_info.notice_to_add.type = 0;

  end init_variables;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

    dcl 1 comp_info	   based (Pcomp_info),
				/* structure of info on archive		*/
				/* components needing to be updated		*/
	2 Ncomp	   fixed bin,
	2 array	   (0 refer (comp_info.Ncomp)),
	  3 name	   char (32),
	  3 ptr	   ptr,
	  3 length   fixed bin (21);

    dcl Lcomp	   fixed bin (21),	/* lgth of an archive component		*/
        Pal	   ptr,		/* ptr to argument list when processing archives	*/
        Parchive_paths ptr,		/* ptr to archive component paths		*/
        Pcomp_info	   ptr,
        Pcomp	   ptr,		/* ptr to an archive component		*/
        Pdesc	   ptr,		/* ptr to descriptors when processing an archive	*/
        comp_bc	   fixed bin (24),	/* archive component's bit_count		*/
        comp_name	   char (32),	/* archive component name			*/
        paths	   (comp_info.Ncomp + 2) based (Parchive_paths) char (168);

process_archive_components:
  proc (SI, TI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* An internal procedure to provide capability for inserting notices into each component	*/
/* of an archive, or only a single component. The star name convention is not supported,	*/
/* and is checked long before this procedure is called.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info,
				/* IN					*/
        1 TI	   aligned like target_info;
				/* IN					*/
    dcl Acode	   fixed bin (35);
    dcl COMPONENT	   char (Lcomp) based (Pcomp);

    if ^Fdisplay
    then
      do;				/* if this is display_pnotice, skip this stuff	*/
        Fmust_reset = False;
        Fmode_set = False;
        on cleanup
	begin;
	  if Fmust_reset
	  then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry,
		  Fmode_set);	/* protect against inadvertent ACL changes	*/
	end;
        call get_temp_segment_ (ME, Pcomp_info, Acode);
        if Acode ^= 0
        then
	do;
	  call com_err_ (Acode, ME, "
Obtaining temp seg for archive info.");
	  goto FATAL_ERROR;
	end;
        comp_info.Ncomp = 0;
      end;
    if SI.entry = ""
    then				/* path like foo.archive given		*/
         goto ALL_COMPONENTS;
    else goto SINGLE_COMPONENT;	/* path like foo::prog.pl1 given		*/


ALL_COMPONENTS:
    doing_all_components = True;	/* in case the archive contains a surprise	*/
    Pcomp = null;			/* in case all components are processed		*/
NEXT_COMPONENT:
    call archive_$next_component (SI.Parchive, bit_count, Pcomp, comp_bc,
         comp_name, Acode);
    if Acode ^= 0
    then
      do;
        call com_err_ (Acode, ME,
	   "^/Last component processed: ^a^/Error obtaining next component info.",
	   pathname_$component (SI.dir, SI.archive_name, SI.entry));
        goto FATAL_ERROR;
      end;
    else if Pcomp = null
    then				/* we are finished				*/
         goto END_OF_COMPONENTS;
    SI.entry = comp_name;
    SI.Pentry = Pcomp;
    TI.entry = comp_name;
    TI.Pentry = Pcomp;
    if ^get_language_info (SI)
    then				/* if it is a single component name, skip and	*/
         goto NEXT_COMPONENT;		/* go on to the next one.			*/
    Lcomp = divide (comp_bc, 9, 21, 0);
    SI.Lentry = Lcomp;
    TI.Lentry = Lcomp;
    call pnotice_parse (SI);		/* parse the component inside the archive.	*/
    if Fdisplay
    then
      do;				/* if display_pnotice then just report info	*/
        call report (SI, TI);
      end;
    else
      do;
        if ^continue_processing (SI, TI)
        then ;			/* should we continue?			*/
        else
	do;			/* this component must be processed		*/
	  comp_info.Ncomp = comp_info.Ncomp + 1;
	  comp_info.array (Ncomp).length = Lcomp;
	  comp_info.array (Ncomp).name = SI.entry;
	  call hcs_$make_seg (process_dir, comp_info.array (Ncomp).name, "",
	       01010b, comp_info.array (Ncomp).ptr, Acode);
				/* make a copy in the pdir			*/
	  if Acode ^= 0
	  then
	    do;
	      call com_err_ (Acode, ME, "
Creating ^a>^a.", pdir, comp_info.array (Ncomp).name);
	      goto FATAL_ERROR;
	    end;
	  comp_info.array (Ncomp).ptr -> COMPONENT = COMPONENT;
				/* copy the seg contents			*/
	  call make_star_box (SI, TI);
	  TI.Pentry = comp_info.array (Ncomp).ptr;
				/* target is now in the pdir			*/
	  TI.Pnew_box =
	       add_char_offset_ (TI.Pentry,
	       char_offset_ (SI.Pold_box) - char_offset_ (SI.Pentry));
				/* since the target seg is actually in the pdir,	*/
				/* Pnew_box must point there, and be adjusted 	*/
				/* based on where the old box is found by parsing */
				/* the seg in the archive. That's what this does. */
	  TI.Lnew_box = TI.Lstar_box;
	  call insert_notice (SI, TI);
	  if TI.long_output
	  then if SI.archive_name ^= ""
	       then call ioa_ (
		       "^/The following notice was added to:^a^a^/^a",
		       "  ",
		       pathname_$component (SI.dir, SI.archive_name,
		       SI.entry), save_name);
	       else call ioa_ (
		       "^/The following notice was added to ^a^a^/^a",
		       "  ", pathname_ (SI.dir, SI.entry), save_name);
	end;
      end;
    call init_structures$next_component (SI, TI);
				/* re-set values in the info structures		*/
    goto NEXT_COMPONENT;		/* no notices found				*/


SINGLE_COMPONENT:
    call archive_$get_component (SI.Parchive, bit_count, component, Pcomp,
         comp_bc, Acode);
    if Acode ^= 0
    then
      do;
        call com_err_ (Acode, ME, "^/Processing ^a.",
	   pathname_$component (SI.dir, SI.archive_name, component));
        goto FATAL_ERROR;
      end;
    SI.Pentry = Pcomp;
    TI.entry = component;
    TI.Pentry = Pcomp;
    if ^get_language_info (SI)
    then
      do;				/* if user tried this on a single component name, */
        call com_err_ (error_table_$bad_file_name, ME, "
Single-component names not permitted. ^a", SI.entry);
        goto FATAL_ERROR;
      end;
    Lcomp = divide (comp_bc, 9, 21, 0); /* get component length			*/
    SI.Lentry = Lcomp;
    TI.Lentry = Lcomp;
    call pnotice_parse (SI);
    if Fdisplay
    then
      do;
        call report (SI, TI);
      end;
    else
      do;
        if ^continue_processing (SI, TI)
        then ;			/* should we continue?			*/
        else
	do;			/* this component must be processed		*/
	  comp_info.Ncomp = comp_info.Ncomp + 1;
	  comp_info.array (Ncomp).length = Lcomp;
	  comp_info.array (Ncomp).name = SI.entry;
	  call hcs_$make_seg (process_dir, comp_info.array (Ncomp).name, "",
	       01010b, comp_info.array (Ncomp).ptr, Acode);
				/* make a copy in the pdir			*/
	  if Acode ^= 0
	  then
	    do;
	      call com_err_ (Acode, ME, "
Creating ^a>^a.", pdir, comp_info.array (Ncomp).name);
	      goto FATAL_ERROR;
	    end;
	  comp_info.array (Ncomp).ptr -> COMPONENT = COMPONENT;
				/* copy the seg contents			*/
	  call make_star_box (SI, TI);
	  TI.Pentry = comp_info.array (Ncomp).ptr;
				/* target is now in the pdir			*/
	  TI.Pnew_box =
	       add_char_offset_ (TI.Pentry,
	       char_offset_ (SI.Pold_box) - char_offset_ (SI.Pentry));
	  TI.Lnew_box = TI.Lstar_box;
	  call insert_notice (SI, TI);
	  if TI.long_output
	  then if SI.archive_name ^= ""
	       then call ioa_ ("The following notice was added to:^a^a^/^a",
		       "  ",
		       pathname_$component (SI.dir, SI.archive_name,
		       SI.entry), save_name);
	       else call ioa_ ("The following notice was added to:^a^a^/^a",
		       "  ", pathname_ (SI.dir, SI.entry), save_name);
	end;
      end;
END_OF_COMPONENTS:
    if Fdisplay
    then				/* if display_pnotice,			*/
         return;			/* also exit here				*/
    if comp_info.Ncomp = 0
    then				/* if no components needed anything		*/
         return;			/* quietly exit				*/


INIT_ARG_LIST:
    Pal = addrel (Pcomp_info, currentsize (comp_info));
    al.header.arg_count = comp_info.Ncomp + 2;
    al.header.pad1 = "0"b;
    al.header.call_type = Interseg_call_type;
    al.header.desc_count = comp_info.Ncomp + 2;
    al.header.pad2 = "0"b;

INIT_DESCRIPTOR_VALUES:
    Pdesc = addrel (Pal, currentsize (al));
    desc (*).version2_ = "1"b;
    desc (*).type_ = char_desc;
    desc (*).pack_ = "1"b;
    desc (*).dimension_ = "0"b;
    desc (*).scale_ = 0;
    desc (*).precision_ = 0;

INIT_ARGUMENT_PATHS:
    Parchive_paths = addrel (Pdesc, currentsize (desc));
    paths (1) = "u";		/* we will "update" the archive		*/
    paths (2) = rtrim (TI.dir) || ">" || TI.archive_name;
				/* the absolute path of the archive		*/
    do Idx1 = 3 to comp_info.Ncomp + 2;
      paths (Idx1) = pdir || ">" || comp_info.array (Idx1 - 2).name;
    end;

FINISH_ARGS_AND_DESCS:
    do Idx1 = 1 to comp_info.Ncomp + 2;
      desc (Idx1).precision_ = length (rtrim (paths (Idx1)));
      al.ap (Idx1) = addr (paths (Idx1));
      al.dp (Idx1) = addr (desc (Idx1));
    end;

    call check_acl (TI.Parchive, TI.dir, TI.archive_name, Fmust_reset);
				/* see if proper access			*/
    call cu_$generate_call (archive, Pal);
				/* pass the argument list along to the		*/
				/* archive command				*/
    if Fmust_reset
    then call check_acl$reset_acl (TI.Parchive, TI.dir, TI.archive_name,
	    Fmode_set);		/* if needed, restore access			*/


  end process_archive_components;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


process_single_seg:
  proc (SI, TI);
    dcl 1 SI	   aligned like source_info,
        1 TI	   aligned like target_info;

    Fmust_reset = False;
    Fmode_set = False;
    on cleanup
      begin;
        if Fmust_reset
        then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry, Fmode_set);
				/* protect against inadvertent ACL changes	*/
      end;
    if ^get_language_info (SI)
    then
      do;				/* if user tried to pass off a single comp name,	*/
        call com_err_ (error_table_$bad_file_name, ME, "
Single-component names not permitted. ^a", SI.entry);
        goto FATAL_ERROR;
      end;
    call pnotice_parse (SI);		/* parse the segment			*/
    if Fdisplay
    then
      do;				/* if display_pnotice			*/
        call report (SI, TI);		/* just print info				*/
      end;
    else
      do;
        if ^continue_processing (SI, TI) then goto FATAL_ERROR;
        call make_star_box (SI, TI);	/* form the new box with text			*/
        call check_acl (TI.Pentry, TI.dir, TI.entry, Fmust_reset);
				/* if Fmust_reset is set, we forced access	*/
        TI.Pnew_box = SI.Pold_box;	/* the new box begins at the same place as the old*/
        TI.Lnew_box = TI.Lstar_box;	/* lgth of new box is lgth of one in temp seg	*/
        call insert_notice (SI, TI);	/* put it into the seg			*/
        if Fmust_reset
        then call check_acl$reset_acl (TI.Pentry, TI.dir, TI.entry, Fmode_set);
				/* put the old access back			*/
        if TI.long_output
        then
	do;
	  if ^Sdfcopyright
	  then call ioa_ ("The following notice was added to:^a^a^/^a", "  ",
		  pathname_ (source_info.dir, source_info.entry),
		  save_name);
	  else if Sdfcopyright & Sprt_notice
	  then call ioa_ ("The following notice was added to:^a^a^/^a", "  ",
		  pathname_ (source_info.dir, source_info.entry),
		  save_name);
	end;

      end;
  end process_single_seg;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_language_info:
  proc (SI) returns (bit (1));


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure determines the parameters of the language of the source segment. These	*/
/* parameters are: type, name, and comment begin and end delimiters.			*/
/* If the source is an exec_com or absin, there are two added parameters needed: the	*/
/* version (ec_version) and the character position of the first non-version character	*/
/* (text_pos). These values are obtained from calling get_ec_version_.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info;
				/* IN/OUT					*/
    dcl Acode	   fixed bin (35),
        Ilang	   fixed bin,
        language	   char (8) var;	/* language name				*/
%include pnotice_language_info_;


    SI.ec_version = 0;
    SI.text_pos = 0;
    if index (SI.entry, ".") = 0
    then				/* primarily for the archive case, if it is a	*/
         return (False);		/* single component name.			*/
    language = reverse (before (reverse (SI.entry), "."));
				/* determine language name			*/
    do Ilang = 1
         to hbound (pnotice_language_info.languages.lang_array, 1)
         while (language
         ^= pnotice_language_info.languages.lang_array (Ilang).lang_name);
    end;				/* look it up in pnotice_language_info_		*/
    if Ilang > pnotice_language_info.languages.N
    then
      do;
        Acode = error_table_$typename_not_found;
        if doing_all_components
        then
	do;			/* processing an entire archive, don't stop here	*/
	  if SI.archive_name ^= ""
	  then call com_err_ (Acode, ME,
		  "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry was skipped: ^a",
		  language,
		  pathname_$component (SI.dir, SI.archive_name, SI.entry));
	  else call com_err_ (Acode, ME,
		  "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry was skipped: ^a",
		  language, pathname_ (SI.dir, SI.entry));
	  return (False);
	end;
        else
	do;
	  if reverse (before (reverse (SI.entry), ".")) = "archive"
	  then call com_err_ (Acode, ME,
		  "^/Archived archives are not supported.");
	  else if SI.archive_name ^= ""
	  then call com_err_ (Acode, ME,
		  "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry not processed: ^a",
		  language,
		  pathname_$component (SI.dir, SI.archive_name, SI.entry));
	  else call com_err_ (Acode, ME,
		  "^/The ^a suffix is not supported because it is not defined in pnotice_language_info_.^/Entry not processed: ^a",
		  language, pathname_ (SI.dir, SI.entry));
	  goto FATAL_ERROR;
	end;
      end;

    SI.type = pnotice_language_info.languages.lang_array (Ilang).lang_type;
				/* type better be 1, 2, 3, 4, or 5		*/
    if SI.type < 1 | SI.type > 5
    then
      do;
        Acode = error_table_$typename_not_found;
        call com_err_ (Acode, ME,
	   "
Language type (^d) found for the ^a suffix in pnotice_language_info_ is not implemented.",
	   SI.type, language);
        goto FATAL_ERROR;
      end;			/* get comment delimiters			*/
    SI.cmt_bgn =
         pnotice_language_info.languages.lang_array (Ilang).comment_start;
    SI.cmt_end =
         pnotice_language_info.languages.lang_array (Ilang).comment_end;

    if SI.type = 3
    then
      do;
        if SI.archive_name ^= ""
        then
	do;			/* can't support archived exec_coms		*/
	  call com_err_ (error_table_$archive_component_modification, ME,
	       "^/^a^/Processing of archived exec_coms is not supported.",
	       pathname_ (SI.dir, SI.archive_name));
	  goto FATAL_ERROR;
	end;
        call get_ec_version_ (SI.dir, SI.entry, SI.ec_version, SI.text_pos,
	   Acode);
        if Acode ^= 0
        then
	do;
	  call com_err_ (Acode, ME, "^/Getting ec version.");
	  goto FATAL_ERROR;
	end;
        if SI.text_pos < 1
        then			/* prevent invalid subscripting		*/
	   SI.text_pos = 1;
        if SI.ec_version = 1
        then SI.cmt_bgn = SI.cmt_bgn || SP;
        else SI.cmt_bgn = SI.cmt_bgn || "-";
      end;

    return (True);

  end get_language_info;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


pnotice_parse:
  proc (SI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure determines the extents of what appears to be a valid protection notice	*/
/* comment. This determination is somewhat different for the three types of defined	*/
/* languages. Once this is done, these extents are then used by the process_tokens and	*/
/* parse_source_ procedures to actually see if a match can be found within these extents. */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info;
				/* IN					*/


    dcl rest	   char (Lrest) based (Prest),
        Prest	   ptr,
        Lrest	   fixed bin (21),
        Icmt	   fixed bin (21),
        rest_ch	   (Lrest) char (1) based (Prest),
        cmt_bgn_length fixed bin (21),
        save_length	   fixed bin (21),
        save_ptr	   ptr,
        save_Prest	   ptr,
        Spnotice	   bit (1),
        Sstar_line	   bit (1);

    dcl Pcomment	   ptr,
        Lcomment	   fixed bin (21),
        comment	   char (Lcomment) based (Pcomment),
        comment_chr	   (Lcomment) char (1) based (Pcomment),
        Pcomment_line  ptr,
        Lcomment_line  fixed bin (21),
        comment_line   char (Lcomment_line) based (Pcomment_line);

    dcl Ppnotice	   ptr,
        Lpnotice	   fixed bin (21),
        pnotice	   char (Lpnotice) based (Ppnotice),
        pnotice_chr	   (Lpnotice) char (1) based (Ppnotice),
        Ppnotice_line  ptr,
        Lpnotice_line  fixed bin (21),
        pnotice_line   char (Lpnotice_line) based (Ppnotice_line);

    dcl 1 pnotices	   based (Ppnotices),
	2 Nwords	   fixed bin (24),
	2 pword	   (0 refer (Nwords)) char (80) var,
        Ppnotices	   ptr;


    dcl 1 template	   based (Ptemplate),
	2 Twords	   fixed bin (24),
	2 tword	   (0 refer (Twords)) char (80) var,
        Ptemplate	   ptr;

    dcl Ntemplates_parsed
		   fixed bin;

    dcl Ibreak	   fixed bin (21),
        Inonwhite	   fixed bin (21),
        Iskip	   fixed bin (21),
        Lword_text	   fixed bin (21),
        Pword_text	   ptr;

    dcl word_text	   char (Lword_text) based (Pword_text),
        word_text_arr  (Lword_text) char (1) based (Pword_text);


    dcl WORD_BREAKS	   char (30) var,
        SKIP_CHRS	   char (30) var;

    dcl Acode	   fixed bin (35);


    SI.Pold_box = SI.Pentry;
    SI.Lold_box = 0;
    Prest = SI.Pentry;
    Lrest = SI.Lentry;
    Sold_style_pnotice = False;
    source_year (*) = 0;
    source_year_a (*) = " ";
    cmt_bgn_length = length (SI.cmt_bgn);
    goto TYPE (SI.type);

TYPE (1):
TYPE (4):
    Icmt = verify (rest, HT_SP_NL_VT_NP);
				/* disregard white space at front.		*/
    if Icmt = 0
    then				/* an empty seg				*/
         goto end_parse1;
    else
      do;
        Prest = addr (rest_ch (Icmt));
        Lrest = Lrest - (Icmt - 1);
      end;

    if length (SI.cmt_bgn) > length (rest) then goto end_parse1;
				/* no room left for comments			*/

    if SI.type = 4 & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
         & substr (rest, 1, 2) = "/*"
    then Sold_style_pnotice = True;
    if ^Sold_style_pnotice
         & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
    then goto end_parse1;

    save_length = 0;
    save_ptr = Prest;
    Icmt = 0;

    do while (pnotice_found ());	/* check for multiple pnotices		*/
      if (index (comment, "PROPRIETARY") > 0
	 | index (comment, "PUBLIC DOMAIN") > 0
	 | index (comment, "Copyright") > 0)
      then save_length = save_length + Lcomment;
    end;

    if save_length = 0
    then				/* not a pnotice				*/
         goto end_parse1;

    Pcomment = save_ptr;
    Lcomment = save_length;

    if ^valid_format ()
    then
      do;
        call com_err_ (error_table_$improper_data_format, ME,
	   "^/^a^/^3xPnotice begin delimiters may not be on a line by themselves.",
	   pathname_ (SI.dir, SI.entry));
        goto FATAL_ERROR;
      end;
    SI.Lold_box = Lcomment;
    call process_tokens;

end_parse1:
    goto PARSE_CLEANUP;


TYPE (3):				/* adjust things for ec's and absin		*/
    Prest = addr (rest_ch (SI.text_pos));
				/* adjust to avoid any "&version" lines		*/
    Lrest = Lrest - (SI.text_pos - 1);
    SI.Pold_box = Prest;		/* after this, type 3 is just like type 2	*/
TYPE (2):
TYPE (5):				/* runoff and compint files			*/
    Icmt = verify (rest, HT_SP_NL_VT_NP);
				/* remove white space			*/
    if Icmt = 0
    then				/* empty seg				*/
         goto end_parse2;

    if (Icmt - 1) + length (SI.cmt_bgn) > length (rest)
    then				/* no room left for any comments		*/
         goto end_parse2;

    Prest = addr (rest_ch (Icmt));
    Lrest = Lrest - (Icmt - 1);

    if substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
    then				/* if first non-white ^= comment,		*/
         goto end_parse2;

    Spnotice = True;
    save_ptr = Prest;

    do while (Spnotice);
      Pcomment, save_Prest = Prest;
      Lcomment = Lrest;
      save_length = 0;
      Sstar_line = False;

      if substr (comment, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
      then Spnotice = False;
      else
        do;
	if (substr (comment, length (SI.cmt_bgn) + length ("     "),
	     length ("**********")) = "**********"
	     | substr (comment, 1, length (SI.cmt_bgn)) = SI.cmt_bgn) &
				/* pnotices begin with a star line		*/
	     (index (comment, "PROPRIETARY") > 0
	     | index (comment, "PUBLIC DOMAIN") > 0
	     | index (comment, "Copyright") > 0)
	then
	  do;
	    do while (Lcomment > 0);	/* check for multiple pnotices		*/
	      Pcomment_line = Pcomment;
	      Lcomment_line = index (comment, NL);
	      if Lcomment_line = 0 then Lcomment_line = Lcomment;
	      Pcomment = addcharno (addr (comment_chr (Lcomment_line)), 1);
	      Lcomment = Lcomment - Lcomment_line;
	      save_length = save_length + Lcomment_line;
	      if Lcomment_line
		 > length (SI.cmt_bgn) + length ("     ")
		 + length ("**********")
	      then if substr (comment_line,
		      length (SI.cmt_bgn) + length ("     "),
		      length ("**********")) = "**********"
		 then
		   do;
		     if ^Sstar_line
		     then Sstar_line = True;
		     else
		       do;
		         Prest =
			    addcharno (addr (rest_ch (save_length)), 1);
		         Lrest = Lrest - save_length;
		         Lcomment = 0;
		       end;
		   end;
	    end;
	    if Prest = save_Prest
	    then			/* nothing has changed so no pnotices found	*/
	         Spnotice = False;
	    Icmt = verify (rest, HT_SP_NL_VT_NP);
	    Prest = addr (rest_ch (Icmt));
	    Lrest = Lrest - (Icmt - 1);
	    if (substr (rest, length (SI.cmt_bgn) + length ("     "),
	         length ("**********")) ^= "**********"
	         & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn)
	         | Lrest = 0
	    then Spnotice = False;
	  end;
	else			/* no pnotices present			*/
	     Spnotice = False;
        end;
    end;

    Pcomment = save_ptr;
    Lcomment = charno (Prest) - charno (Pcomment) - 1;
    if Lcomment <= 0
    then				/* not a pnotice				*/
         goto end_parse2;

    SI.Lold_box = Lcomment;
    call process_tokens;

end_parse2:
PARSE_CLEANUP:
    if Ptemplate ^= null then call release_temp_segment_ (ME, Ptemplate, code);

    if Ppnotices ^= null then call release_temp_segment_ (ME, Ppnotices, code);

    return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
pnotice_found:
  proc returns (bit (1));

    dcl Inl	   fixed bin (21);

    Icmt = verify (rest, HT_SP_NL_VT_NP);
    if Icmt > 0
    then
      do;
        Prest = addr (rest_ch (Icmt));
        Lrest = Lrest - (Icmt - 1);
      end;

    Pcomment = Prest;

    if Sold_style_pnotice & substr (rest, 1, 2) ^= "/*" then return (False);
    else if ^Sold_style_pnotice
         & substr (rest, 1, length (SI.cmt_bgn)) ^= SI.cmt_bgn
    then return (False);
    else
      do;				/* see if line starts with cmt_bgn and has stars	*/
        Inl = index (rest, NL);
        if Inl < length (cmt_bgn) + length ("     ") + length ("**********")
        then return (False);
        if substr (rest, length (cmt_bgn) + length ("     "),
	   length ("**********")) ^= "**********"
        then return (False);
      end;

    if (SI.cmt_bgn = SI.cmt_end) & ^Sold_style_pnotice
    then				/* TECO */
         Lcomment =
	    index (substr (rest, length (SI.cmt_bgn) + 1), SI.cmt_end)
	    + length (SI.cmt_end);
    else Lcomment = index (rest, SI.cmt_end) - 1 + length (SI.cmt_end);

    Lcomment = Lcomment + Icmt;	/* include any intervening ctl chars and white	*/
				/* space if there are multiple pnotices		*/

    Prest = addcharno (addr (rest_ch (Lcomment)), 1);
    Lrest = Lrest - Lcomment;

    return (True);

  end pnotice_found;		/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

valid_format:
  proc returns (bit (1));

    i = index (comment, NL);
    if i <= cmt_bgn_length + length ("     ") + length ("**********")
    then return (False);
    if index (
         substr (comment, cmt_bgn_length + length ("     "),
         length ("**********")), "**********") = 0
    then return (False);

    return (True);
  end valid_format;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

process_tokens:
  proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure is the driver for the parse_source_ and parse_templates_ primitives.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl Scontinue	   bit (1),
        Sfound	   bit (1),
        Snomatch	   bit (1);


    call parse_source_init;
    call parse_templates_$init;
    if SI.type = 1 | SI.type = 4
    then				/* pl1 progs				*/
         WORD_BREAKS = HT_SP_STAR;
    else WORD_BREAKS = SI.cmt_bgn || HT_SP_STAR;

    do while (Lcomment > 0);
      if get_pnotice_block ()
      then
        do;			/* check for multile pnotice blocks		*/
	do while (parse_pnotice_$block ());
	  Ntemplates_parsed = 0;
	  Scontinue, Snomatch = True;
	  do while (Scontinue);
	    if parse_templates_$get_next ()
	    then
	      do;
	        call parse_templates_$line;
	        if Nwords ^= Twords
	        then ;
	        else
		do;
		  Sfound = True;
		  do i = 1 to Nwords while (Sfound);
		    if pnotices.pword (i) = template.tword (i) then ;
		    else if template.tword (i) = "<yr>"
		         & verify (pnotices.pword (i), "0123456789") = 0
		         & length (pnotices.pword (i)) = length ("1986")
		    then ;
		    else if template.tword (i) = "<yr>."
		         & length (pnotices.pword (i)) = length ("1986.")
		         &
		         verify (
		         substr (pnotices.pword (i), 1, length ("1986")),
		         "0123456789") = 0
		         &
		         substr (pnotices.pword (i), length ("1986."),
		         length (".")) = "."
		    then ;
		    else Sfound = False;
		  end;
		  if Sfound
		  then if i - 1 = Nwords then Scontinue, Snomatch = False;
		end;
	      end;
	    else Scontinue = False;
	  end;

	  if Snomatch
	  then
	    do;
	      if SI.archive_name ^= ""
	      then call com_err_ (error_table_$not_done, ME,
		      "^/^a contains an unknown or illegal notice.",
		      pathname_$component (SI.dir, SI.archive_name,
		      SI.entry));
	      else call com_err_ (error_table_$not_done, ME,
		      "^/^a contains an unknown or illegal notice.",
		      pathname_ (SI.dir, SI.entry));
	      goto FATAL_ERROR;
	    end;
	  else call template_matched;
	end;
        end;
      else Lcomment = 0;
    end;

  end process_tokens;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

get_pnotice_block:
  proc returns (bit (1));

    Spnotice = True;
    Sstar_line = False;
    Ppnotice = null;
    Lpnotice = 0;
    save_ptr = Pcomment;
    save_length = Lcomment;

    do while (Spnotice);
      Pcomment_line = Pcomment;
      Lcomment_line = index (comment, NL);
      if Lcomment_line = 0
      then
        do;
	Lcomment_line = Lcomment;
	Lcomment = 0;
        end;
      else
        do;
	Pcomment = addcharno (addr (comment_chr (Lcomment_line)), 1);
	Lcomment = Lcomment - Lcomment_line;
        end;
      if Lcomment_line
	 > cmt_bgn_length + length ("     ") + length ("**********")
      then if substr (comment_line, cmt_bgn_length + length ("     "),
	      length ("**********")) = "**********"
	 then
	   do;
	     if ^Sstar_line
	     then
	       do;
	         Ppnotice = Pcomment_line;
	         Sstar_line = True;
	       end;
	     else
	       do;
	         Sstar_line = False;
	         Spnotice = False;
	       end;
	   end;
      if Ppnotice ^= null then Lpnotice = Lpnotice + Lcomment_line;
    end;

    if Lpnotice > 0
    then
      do;
        if Lcomment > 0
        then
	do;
	  Icmt = verify (comment, HT_SP_NL_VT_NP);
	  if Icmt > 0
	  then
	    do;
	      Pcomment = addr (comment_chr (Icmt));
	      Lcomment = Lcomment - (Icmt - 1);
	    end;
	  else Lcomment = 0;
	end;
        return (True);
      end;

    return (False);

  end get_pnotice_block;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

parse_source_init:
  proc;

    SI_yrno = 0;			/* Initialize date seq counter		*/

    call get_temp_segment_ (ME, Ppnotices, Acode);
				/* get area for pnotice_arr			*/
    if Acode ^= 0
    then
      do;
        call com_err_ (Acode, ME, "
Obtaining temp seg for pnotice parse.");
        goto FATAL_ERROR;
      end;

    SKIP_CHRS = SI.cmt_bgn || SI.cmt_end || STAR || HT_SP_NL;

  end parse_source_init;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

template_matched:
  proc;

    SI.Nnotices = SI.Nnotices + 1;
    if SI.Nnotices > dim (SI.notice_info, 1)
    then
      do;
        if SI.archive_name ^= ""
        then call ioa_ (
	        "^a^/Has more notices than this procedure currently implements.^/Only ^d are allowed.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry),
	        dim (SI.notice_info, 1));
        else call ioa_ (
	        "^a^/Has more notices than this procdure currently implements.^/Only ^d are allowed.",
	        pathname_ (SI.dir, SI.entry), dim (SI.notice_info, 1));
        goto FATAL_ERROR;
      end;
    SI.notice_info (SI.Nnotices) = parse_templates_$get_template_pnotice ();

  end template_matched;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

parse_pnotice_:
  proc;

parse_pnotice_$block:
  entry returns (bit (1));

    pnotices.Nwords = 0;

    if verify (pnotice, SKIP_CHRS) = 0
    then				/* if only blank and stars left		*/
         Lpnotice = 0;

    if Lpnotice = 0 then return (False);

    do while (parse_pnotice_$get_line ());
      if verify (pnotice_line, SKIP_CHRS) = 0
      then
        do;			/* blank line				*/
	if pnotices.Nwords = 0
	then ;			/* no pnotices parsed yet			*/
	else return (True);
        end;
      else call parse_pnotice_$line;
    end;

    return (True);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

parse_pnotice_$get_line:
  entry returns (bit (1));

    dcl Iline	   fixed bin (24);

    if length (pnotice) = 0 then return (False);

    Iline = index (pnotice, NL);
    if Iline = 0 | Lpnotice - Iline = 0
    then
      do;
        Ppnotice_line = Ppnotice;
        Lpnotice_line = length (pnotice);
        Lpnotice = 0;
      end;
    else
      do;
        Ppnotice_line = Ppnotice;
        Lpnotice_line = Iline - 1;
        Ppnotice = addcharno (addr (pnotice_chr (Iline)), 1);
        Lpnotice = Lpnotice - Iline;
      end;

    return (True);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

parse_pnotice_$line:
  entry;

    Pword_text = Ppnotice_line;
    Lword_text = Lpnotice_line;
    Inonwhite = verify (word_text, WORD_BREAKS);
				/* skip over cmt_bgn & white space		*/
    if Inonwhite = 0 then Lword_text = 0;
    else if Inonwhite > 1
    then
      do;
        Pword_text = addr (word_text_arr (Inonwhite));
        Lword_text = length (word_text) - (Inonwhite - 1);
      end;

    do while (Lword_text > 0);
      Ibreak = search (word_text, WORD_BREAKS);
      if Ibreak = 0 then Ibreak = length (word_text) + 1;
      if Ibreak > 1
      then
        do;
	pnotices.Nwords = pnotices.Nwords + 1;
	pnotices.pword (Nwords) = substr (word_text, 1, Ibreak - 1);
	if length (pnotices.pword (Nwords)) >= length ("1986")
	then if verify (substr (pnotices.pword (Nwords), 1, 4), "0123456789")
		= 0
	     then			/* store date for future use			*/
		call store_date;
	Pword_text = addr (word_text_arr (Ibreak));
	Lword_text = length (word_text) - (Ibreak - 1);
        end;
      Iskip = verify (word_text, WORD_BREAKS);
				/* skip over all consecutive breaks chars	*/
      if Iskip > 0
      then
        do;
	Pword_text = addr (word_text_arr (Iskip));
	Lword_text = length (word_text) - (Iskip - 1);
        end;
      else Lword_text = 0;		/* nothing but break characters remain		*/
    end;

    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

store_date:
  proc;

    if length (pnotices.pword (Nwords)) = length ("1986.")
    then if substr (pnotices.pword (Nwords), length ("1986."), length ("."))
	    ^= "."
         then goto RETURN;

    SI_yrno = SI_yrno + 1;
    source_year_a (SI_yrno) = substr (pnotices.pword (Nwords), 1, 4);
    source_year (SI_yrno) =
         convert (source_year (SI_yrno), source_year_a (SI_yrno));

RETURN:
  end store_date;


  end parse_pnotice_;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


    dcl Ltline	   fixed bin (21),	/* lgth of a template			*/
        Ptline	   ptr,		/* ptr to template notice			*/
        tline	   char (Ltline) based (Ptline);
				/* a template line of text			*/

parse_templates_:
  proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This internal procedure provides the primitive operations necessary for obtaining a	*/
/* token (word) from a pnotice template, resetting to parse a new template, and		*/
/* initially preparing for parsing.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

parse_templates_$init:
  entry;

    call get_temp_segment_ (ME, Ptemplate, Acode);
    if Acode ^= 0
    then
      do;
        call com_err_ (Acode, ME, "
Obtaining temp seg for template parse.");
        goto FATAL_ERROR;
      end;

    return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

parse_templates_$get_next:
  entry returns (bit (1));

    Ntemplates_parsed = Ntemplates_parsed + 1;

    if Ntemplates_parsed <= pnotice_paths.Ntemplates
    then
      do;
        Ptline = pnotice_paths.templates (Ntemplates_parsed).Ptemplate;
        Ltline =
	   pnotice_paths.templates (Ntemplates_parsed).Ltemplate
	   - length (NL);
        return (True);
      end;

    return (False);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


parse_templates_$line:
  entry;

    template.Twords = 0;
    Pword_text = Ptline;
    Lword_text = Ltline;
    WORD_BREAKS = WORD_BREAKS || NL;

    Inonwhite = verify (tline, HT_SP_NL);
				/* remove "white space"			*/
    if Inonwhite = 0
    then				/* zero means there is nothing but white space	*/
         Lword_text = 0;
    else if Inonwhite > 1
    then
      do;
        Pword_text = addr (word_text_arr (Inonwhite));
        Lword_text = length (word_text) - (Inonwhite - 1);
      end;

    do while (Lword_text > 0);
      template.Twords = template.Twords + 1;
      Ibreak = search (word_text, WORD_BREAKS);
      if Ibreak = 0
      then
        do;
	template.tword (Twords) = substr (word_text, 1, length (word_text));
	Lword_text = 0;
        end;
      else
        do;
	template.tword (Twords) = substr (word_text, 1, Ibreak - 1);
	Pword_text = addr (word_text_arr (Ibreak));
	Lword_text = length (word_text) - (Ibreak - 1);
	Iskip = verify (word_text, WORD_BREAKS);
				/* skip over all consecutive breaks chars	*/
	if Iskip > 0
	then
	  do;
	    Pword_text = addr (word_text_arr (Iskip));
	    Lword_text = length (word_text) - (Iskip - 1);
	  end;
	else Lword_text = 0;	/* nothing but break characters remain		*/
        end;
    end;

    return;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


parse_templates_$get_template_pnotice:
  entry returns (1 aligned, 2 char (32), 2 char (4), 2 fixed bin, 2 fixed bin);

    dcl 1 ret	   aligned,
	2 Aname	   char (32),
	2 Adate	   char (4),
	2 Atype	   fixed bin,
	2 Aseq	   fixed bin;


    ret.Aname =
         before (pnotice_paths.templates (Ntemplates_parsed).primary_name,
         ".pnotice");
    if SI_yrno > 0
    then ret.Adate = source_year_a (SI_yrno);
    else ret.Adate = "";
    ret.Atype = pnotice_paths.templates (Ntemplates_parsed).type;
    seqno = seqno + 1;
    ret.Aseq = seqno;
    return (ret);

  end parse_templates_;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/



  end pnotice_parse;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

continue_processing:
  proc (SI, TI) returns (bit (1));


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This internal procedure must do some necessary checking on any notices found in	*/
/* source already and the notice that would be added. Specifically, checks must be made	*/
/* for duplicate notices already in the source. If this is found, only one copy is	*/
/* retained. A check must be made to see if the notice to add is already in the source.	*/
/* If it is, then an error message is produced, and nothing is done. Checks must be made	*/
/* to see if the source has mixed Trade Secret notices and copyrights. If this is so, an	*/
/* error message is produced, and nothing is done.				*/
/* Checks are also made for mixed public domain and copyright or trade secret notices in	*/
/* the source. A check is made to see if the action the user wants would be inconsistent	*/
/* with the notice(s) already in the source.					*/
/*									*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info,
				/* IN					*/
        1 TI	   aligned like target_info;
				/* OUT					*/


    dcl Iname	   fixed bin,
        Idx1	   fixed bin,
        Idx2	   fixed bin,
        Acode	   fixed bin (35),
        match	   bit (1),
        addC	   bit (1),
        addTS	   bit (1),
        addPD	   bit (1),
        foundPD	   bit (1),
        foundC	   bit (1),
        foundTS	   bit (1);


    Acode = 0;
    addC = False;
    addTS = False;
    addPD = False;
    foundPD = False;
    foundC = False;
    match = False;
    Iname = 1;

    if SI.Nnotices = 0
    then
      do;				/* if the source had no notices,		*/
        if ^Fname & ^Ftrade_secret & ^DFtrade_secret & ^Fcopy_right
	   & ^DFcopy_right & ^Fpublic_domain
        then
	do;
	  call com_err_ (0, ME, "
No protection notices were found in ^a ^a^[>^]^[^a::^;^s^]^a^a", "       ",
	       SI.dir, SI.dir ^= ">", SI.archive_name ^= "", SI.archive_name,
	       SI.entry, ".");
	  return (False);
	end;

        TI.Nnotices = 1;		/* we must add the requested notice		*/
        TI.notice (TI.Nnotices).name = SI.notice_to_add.name;
        TI.notice (TI.Nnotices).date = current_year_a;
        seqno = seqno + 1;
        TI.notice (TI.Nnotices).seq = ltrim (char (seqno));
        if Sdfcopyright then Sprt_notice = True;
        return (True);		/* nothing remains to be done			*/
      end;


/* CHECK FOR MIXED NOTICE TYPES, ILLEGAL MULTIPLE NOTICES */
    if SI.notice_to_add.type = TRADE_SECRET then addTS = True;
    else if SI.notice_to_add.type = PUBLIC_DOMAIN then addPD = True;
    else addC = True;
    do Idx1 = 1 to SI.Nnotices;	/* now look at notices found			*/
      if SI.notice_info (Idx1).notice_type = TRADE_SECRET then foundTS = True;
      else if SI.notice_info (Idx1).notice_type = PUBLIC_DOMAIN
      then foundPD = True;
      else foundC = True;
    end;
    if foundC & foundTS
    then
      do;				/* source had copyright and T. S. somehow	*/
        Acode = error_table_$not_done;
        if SI.archive_name ^= ""
        then call com_err_ (Acode, ME,
	        "^/Processing ^a. The module has mixed copyright and trade secret notices.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry));
        else call com_err_ (Acode, ME,
	        "^/Processing ^a. The module has mixed copyright and trade secret notices.",
	        pathname_ (SI.dir, SI.entry));
        return (False);
      end;
    if foundC & foundPD
    then
      do;				/* source had copyright and public domain	*/
        Acode = error_table_$not_done;
        if SI.archive_name ^= ""
        then call com_err_ (Acode, ME,
	        "^/Processing ^a. The module has mixed copyright and public domain notices.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry));
        else call com_err_ (Acode, ME,
	        "^/Processing ^a.  The module has mixed copyright and public domain notices.",
	        pathname_ (SI.dir, SI.entry));
        return (False);
      end;
    if foundTS & foundPD
    then
      do;				/* source had trade secret and public domain	*/
        Acode = error_table_$not_done;
        if SI.archive_name ^= ""
        then call com_err_ (Acode, ME,
	        "^/Processing ^a. The module has mixed trade secret and public domain notices.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry));
        else call com_err_ (Acode, ME,
	        "^/Processing ^a. The module has mixed trade secret and public domain notices.",
	        pathname_ (SI.dir, SI.entry));
        return (False);
      end;
    if addTS & foundTS
    then
      do;
        do Idx1 = 1 to SI.Nnotices
	   while (SI.notice_to_add.name ^= SI.notice_info (Idx1).notice_name)
	   ;
        end;
        if Idx1 ^> SI.Nnotices
        then
	do;
	  Acode = error_table_$not_done;
	  if SI.archive_name ^= ""
	  then call com_err_ (Acode, ME,
		  "^/Processing ^a.^/Duplicate Trade Secret notices not allowed.",
		  pathname_$component (SI.dir, SI.archive_name, SI.entry));
	  else call com_err_ (Acode, ME,
		  "^/Processing ^a.^/Duplicate Trade Secret notices are not allowed.",
		  pathname_ (SI.dir, SI.entry));
	  return (False);
	end;
      end;
    else if addPD & foundPD
    then
      do;
        Acode = error_table_$not_done;
        if SI.archive_name ^= ""
        then call com_err_ (Acode, ME,
	        "^/Processing ^a.^/Multiple Public Domain notices not allowed.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry));
        else call com_err_ (Acode, ME,
	        "^/Processing ^a.^/Multiple Public Domain notices not allowed.",
	        pathname_ (SI.dir, SI.entry));
        return (False);
      end;
    else if addC & foundC then ;	/* the ONLY way to have >1 notice		*/
    else
      do;				/* this will abort everything			*/
        Acode = error_table_$not_done;
        if SI.archive_name ^= ""
        then call com_err_ (Acode, ME,
	        "^/Found ^[Copyright^;Trade Secret^;Public Domain^] notice in ^a.^/Cannot add ^a.",
	        SI.notice_info (1).notice_type,
	        pathname_$component (SI.dir, SI.archive_name, SI.entry),
	        SI.notice_to_add.name);
        else call com_err_ (Acode, ME,
	        "^/Found ^[Copyright^;Trade Secret^;Public Domain^] notice in ^a.^/Cannot add ^a.",
	        SI.notice_info (1).notice_type, pathname_ (SI.dir, SI.entry),
	        SI.notice_to_add.name);
        return (False);
      end;

/* VALIDATE THE TEN-YEAR RULE FOR COPYRIGHTS */
    TI.Nnotices = 0;
    if ^Ftrade_secret & ^Fpublic_domain
    then				/* if we are working on a copyright...		*/
         if ok_nine_year_rule (SI)
         then
	 do;			/* the new notice may be added.		*/
	   do Idx1 = 1 to SI.Nnotices while
				/* check to see if new name being added or same	*/
				/* name with a new date.			*/
	        ((SI.notice_to_add.name ^= SI.notice_info (Idx1).notice_name)
	        | (SI.notice_to_add.name = SI.notice_info (Idx1).notice_name
	        & current_year ^= source_year (Idx1)));
	   end;
	   if Idx1 > SI.Nnotices
	   then
	     do;
	       TI.Nnotices = 1;
	       TI.notice (1).name = SI.notice_to_add.name;
				/* shall be first				*/
	       TI.notice (1).date = current_year_a;
				/* new notice yr				*/
	       seqno = seqno + 1;
	       TI.notice (1).seq = ltrim (char (seqno));
	       if Sdfcopyright then Sprt_notice = True;
	     end;
	 end;


    if Sno_args_given
    then if ^Sadd_default_pnotice	/* if already there dont try to readd		*/
         then return (False);

    if Fname & Ftrade_secret
    then
      do;
        TI.Nnotices = 1;
        TI.notice (1).name = SI.notice_to_add.name;
        seqno = seqno + 1;
        TI.notice (1).seq = ltrim (char (seqno));
      end;

/* CHECK FOR DUPS IN THE SOURCE ALREADY */
    do Idx1 = 1 to SI.Nnotices - 1;
      do Idx2 = Idx1 + 1 to SI.Nnotices;
        if SI.notice_info (Idx1).notice_name
	   = SI.notice_info (Idx2).notice_name
	   & SI.notice_info (Idx1).notice_date
	   = SI.notice_info (Idx2).notice_date
        then			/* if a dup is found, only one will be retained	*/
	   SI.notice_info (Idx2).notice_name = "";
      end;
    end;

/* FILL IN TARGET PNOTICE NAMES */
    do Idx1 = 1 to SI.Nnotices;
      if SI.notice_info (Idx1).notice_name ^= ""
      then
        do;
	TI.Nnotices = TI.Nnotices + 1;/* the target structure contains notices	*/
				/* that will be put into the source.		*/
	TI.notice (TI.Nnotices).name = SI.notice_info (Idx1).notice_name;
	TI.notice (TI.Nnotices).date = SI.notice_info (Idx1).notice_date;
	TI.notice (TI.Nnotices).seq =
	     ltrim (char (SI.notice_info (Idx1).seq));
        end;
    end;

/* SORT IF THERE IS MORE THAN ONE */
    if TI.Nnotices > 1 then call sort_pnotices (TI);
    do Idx1 = 1 to dim (SI.notice_info, 1)
         while (SI.notice_info (Idx1).notice_name ^= ""
         & SI.notice_info (Idx1).notice_name = TI.notice (Idx1).name
         & SI.notice_info (Idx1).notice_date = TI.notice (Idx1).date);
    end;
    if Idx1 - 1 > dim (SI.notice_info, 1)
    then				/* there is no change, do nothing.		*/
         return (False);
    else return (True);


  end continue_processing;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

sort_pnotices:
  proc (TI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure is called upon to sort multiple copyright notices into the proper	*/
/* order. The order must be "most recent first", i.e., the notice containing the most	*/
/* recent date must show up as the first notice in the comment box. Descending collating	*/
/* order, if you will.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



    dcl 1 V	   aligned,	/* sort vector of pointers			*/
	2 N	   fixed bin (18),
	2 vector	   (dim (TI.notice, 1)) ptr unaligned;

    dcl 1 TI	   aligned like target_info;
				/* IN/OUT					*/
    dcl Idx1	   fixed bin,
        Idx2	   fixed bin;
    dcl 1 notice	   aligned like target_info.notice based;
    dcl 1 sorted_data  (dim (TI.notice, 1)) aligned like target_info.notice;
    dcl sort_items_$char
		   entry (ptr, fixed bin (24));

    V.N = TI.Nnotices;
    do Idx1 = 1 to TI.Nnotices;
      V.vector (Idx1) = addr (TI.notice.sort_field (Idx1));
				/* get ptr value to it			*/
    end;
    call sort_items_$char (addr (V),
         length (string (TI.notice.sort_field (1))));
				/* sort on sort field			*/


    Idx2 = 1;
    do Idx1 = V.N to 1 by -1;
      sorted_data (Idx2) = V.vector (Idx1) -> notice;
      Idx2 = Idx2 + 1;
    end;
    do Idx2 = Idx2 to dim (sorted_data, 1);
      string (sorted_data (Idx2)) = "";
    end;

    TI.notice (*) = sorted_data (*);

  end sort_pnotices;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


ok_nine_year_rule:
  proc (SI) returns (bit (1));

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This internal procedure enforces the rule promulgated by Honeywell LISD management	*/
/* that consists of the following:						*/
/* If a source program already has one (or more) copyright notice(s), and this program	*/
/* is invoked to insert another one, then no notice need be added if there is already a	*/
/* notice which is within nine years of the date of the new notice AND both notices are	*/
/* duplicates, with exception of the date. This rule does NOT apply to Trade Secret	*/
/* notices.								*/
/* If no -nm arg is given the most recent pnotice will have the nine-year rule applied    */
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl 1 SI	   aligned like source_info;
				/* IN					*/
    dcl continue	   bit (1),
        new_pnotice_vers
		   char (32) var,
        new_pnotice_date
		   char (4),
        current_pnotice_vers
		   char (32) var,
        current_pnotice_date
		   char (4);

    dcl HBull_name_array
		   (5) char (80) varying int static options (constant)
		   init ("HIS", "HIS_A", "HIS_B", "MIT_HIS", "MIT_HIS_A");

    dcl most_recent_date
		   char (4),
        Idx2	   fixed bin;

    continue = True;
    new_pnotice_vers = before (SI.notice_to_add.name, ".");
    new_pnotice_date = current_year_a;
    most_recent_date = "";

    if Sno_args_given
    then
      do Idx1 = 1 to SI.Nnotices;
        if SI.notice_info (Idx1).notice_name = new_pnotice_vers
				/* default already exists so exit		*/
        then
	do;
	  Sadd_default_pnotice = False;
	  return (Sadd_default_pnotice);
	end;
        if most_recent_date < SI.notice_info (Idx1).notice_date
        then most_recent_date = SI.notice_info (Idx1).notice_date;
      end;

    do Idx1 = 1 to SI.Nnotices while (continue);
				/* go thru all notices in the segment		*/
      current_pnotice_vers = SI.notice_info (Idx1).notice_name;
      current_pnotice_date = SI.notice_info (Idx1).notice_date;

      if Sno_args_given
      then
        do;
	if SI.notice_info (Idx1).notice_date = most_recent_date
	then
	  do Idx2 = lbound (HBull_name_array, 1)
	       to hbound (HBull_name_array, 1);
	    if SI.notice_info (Idx1).notice_name = HBull_name_array (Idx2)
				/* if a match is found exit & add HBull notice	*/
	    then Sadd_default_pnotice = True;
	  end;
	else Sadd_default_pnotice = False;

	return (Sadd_default_pnotice);
        end;

      if current_pnotice_vers = new_pnotice_vers
      then
        do;			/* if a matching version is found,		*/
	if current_year <= source_year (Idx1) + 9
	then			/* the new notice date must be more than	*/
				/* nine years newer, else no need to add it.	*/
	     continue = False;
        end;
    end;
    return (continue);

  end ok_nine_year_rule;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


    dcl Lmax_line	   fixed bin (21),	/* lgth of longest line in notice(s)		*/
        Lmove	   fixed bin (21),
        Lsave	   fixed bin (21),
        Ltext	   fixed bin (21),
        Psave	   ptr,
        Ptext	   ptr,
        move	   char (Lmove) based,
				/* used to obtain template text		*/
        save_chr	   (Lsave) char (1) based (Psave),
        star_box	   char (target_info.Lstar_box)
		   based (target_info.Pstar_box);

make_star_box:
  proc (SI, TI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure obtains a temporary segment, gets the text of all notices to put into	*/
/* the source segment, and then forms the star comment box.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl 1 SI	   aligned like source_info,
				/* IN					*/
        1 TI	   aligned like target_info;
				/* IN/OUT					*/
    dcl box_line	   char (128) var,
        Idate	   fixed bin,
        Inotice	   fixed bin,
        Nnotices_in_box
		   fixed bin;

    box_line = "";
    Nnotices_in_box = 0;
    Ltext = 0;
    Lmove = 0;
    if Ptext = null
    then
      do;
        call get_temp_segment_ (ME, Ptext, code);
				/* temp seg for text and star box		*/
        if code ^= 0
        then
	do;
	  call com_err_ (code, ME, "
Obtaining temp seg for text and star box.");
	  goto FATAL_ERROR;
	end;
      end;
    else Ptext = ptr (Ptext, 0);	/* incase of multiple archive components	*/
				/* don't want to get another temp seg, 		*/
				/* just start over.				*/
    Psave = Ptext;			/* Psave will be moved along thru text		*/
				/* get text of notices.			*/
    do Inotice = 1 to TI.Nnotices;	/* for each notice				*/
      do Itemplate = 1 to pnotice_paths.Ntemplates;
				/* search the template names			*/
        if TI.notice (Inotice).name
	   =
	   before (pnotice_paths.templates (Itemplate).primary_name,
	   ".pnotice")
        then
	do;			/* if a matching name is found,		*/
	  Lmove = pnotice_paths.templates (Itemplate).Ltemplate + 1;
	  Psave -> move =
	       pnotice_paths.templates (Itemplate).Ptemplate -> move;
				/* get the text of that template.		*/
	  substr (Psave -> move, Lmove, 1) = NL;
				/* add a NL				*/
				/* put the dates in template text               */
	  Idate = 0;
	  Idate = index (Psave -> move, "<yr>");
	  if Idate ^= 0
	  then substr (Psave -> move, Idate, 4) = TI.notice (Inotice).date;
	  Ltext = Ltext + Lmove;
	  if Inotice = 1
	  then
	    do;			/* save data for print			*/
	      save_text = substr (Psave -> move, 1, Ltext);
	      save_name = SI.notice_to_add.name;
	    end;
	  Lsave = Lmove + 1;
	  Psave = addr (save_chr (Lsave));
	  Nnotices_in_box = Nnotices_in_box + 1;

	end;
      end;
    end;
    if Nnotices_in_box ^= TI.Nnotices
    then
      do;
        if SI.archive_name ^= ""
        then call com_err_ (0, ME,
	        "^/A programming error has occurred while processing ^a.^/Total number of notices (^d) is inconsistent with target information (^d).^/Operation not performed.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry),
	        Nnotices_in_box, TI.Nnotices);
        else call com_err_ (0, ME,
	        "^/A programming error has occurred while processing ^a.^/Total number of notices (^d) is inconsistent with target information (^d).^/Operation not performed.",
	        pathname_ (SI.dir, SI.entry), Nnotices_in_box, TI.Nnotices);
        goto FATAL_ERROR;
      end;			/* now find the longest line			*/
    call find_line$init (Ptext, Ltext); /* set find_line				*/
    Lmax_line = 0;
    do while (find_line ());
      Lmax_line = max (Lmax_line, length (line));
				/* longest line				*/
    end;

    TI.Pstar_box = Psave;		/* from here, Pstar_box marks the beginning of 	*/
				/* the new box				*/
    TI.Lstar_box = 0;
    call add_text$init (addr (TI));	/* set up add_text				*/
    goto TYPE (SI.type);

TYPE (1):				/* cds   */
TYPE (4):				/* pl1   */
				/* first line made up of stars		*/
    call add_text$var (SI.cmt_bgn);
    call add_text$fixed (SP);
    call add_text$substr (STARS, Lmax_line + length ("*  *"));
    call add_text$fixed (NL);		/* second line is for looks			*/
    call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
    call add_text$fixed (STAR);
    call add_text$substr (SPACES, Lmax_line + length ("  "));
    call add_text$fixed (STAR);
    call add_text$fixed (NL);

    call find_line$init (Ptext, Ltext); /* set up for find_line			*/
    do while (find_line ());		/* get lines of text			*/
      call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
      call add_text$fixed (STAR);
      call add_text$fixed (SP);
      call add_text$fixed (line);
      call add_text$substr (SPACES, Lmax_line - length (line));
      call add_text$fixed (sfx_string);
    end;
    call add_text$substr (SPACES, length (SI.cmt_bgn) + length (SP));
    call add_text$substr (STARS, Lmax_line + length ("*  *"));
    call add_text$fixed (SP);
    call add_text$var (SI.cmt_end);
    if SI.Nnotices = 0
    then				/* only do first time any notice was added			*/
         call add_text$fixed (NL_NL);
    else call add_text$fixed (NL);

    return;

TYPE (2):				/*cobol*/
TYPE (3):				/*exec_com*/
TYPE (5):				/*compin, runoff*/
				/* first line made up of stars		*/
    call add_text$var (SI.cmt_bgn);
    call add_text$fixed (SP);
    call add_text$substr (STARS, Lmax_line + 4);
    call add_text$fixed (NL);		/* next line is for readability		*/
    call add_text$var (SI.cmt_bgn);
    call add_text$fixed (SP_STAR);
    call add_text$substr (SPACES, Lmax_line + 2);
    call add_text$fixed (STAR);
    call add_text$fixed (NL);

    call find_line$init (Ptext, Ltext); /* set up for find_line			*/
    do while (find_line ());
      call add_text$var (SI.cmt_bgn);
      call add_text$fixed (SP_STAR_SP);
      call add_text$fixed (line);
      call add_text$substr (SPACES, Lmax_line - length (line));
      call add_text$fixed (sfx_string);
    end;
    call add_text$var (SI.cmt_bgn);
    call add_text$fixed (SP);
    call add_text$substr (STARS, Lmax_line + 4);
    if SI.type ^= 5
    then call add_text$fixed (NL);
    return;
  end make_star_box;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

add_text:
  proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure forms the text of a star comment box, one line at a time. It is called	*/
/* from the procedure make_star_box.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

    dcl Lold_text	   fixed bin (21);
    dcl TIptr	   ptr;
    dcl 1 TI	   aligned like target_info based (TIptr);

add_text$init:
  entry (Aptr);
    dcl Aptr	   ptr;

    TIptr = Aptr;
    return;

add_text$fixed:
  entry (new_text);

    dcl new_text	   char (*);	/* IN					*/


    Lold_text = TI.Lstar_box;
    TI.Lstar_box = TI.Lstar_box + length (new_text);
    substr (star_box, Lold_text + 1) = new_text;
    return;

add_text$var:
  entry (new_var_text);

    dcl new_var_text   char (*) var;	/* IN					*/


    Lold_text = TI.Lstar_box;
    TI.Lstar_box = TI.Lstar_box + length (new_var_text);
    substr (star_box, Lold_text + 1) = new_var_text;
    return;

add_text$substr:
  entry (Astring, Alength);

    dcl Astring	   char (*),	/* IN					*/
        Alength	   fixed bin (21);

    Lold_text = TI.Lstar_box;
    TI.Lstar_box = TI.Lstar_box + Alength;
    substr (star_box, Lold_text + 1) = substr (Astring, 1, Alength);
    return;

  end add_text;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


check_acl:
  proc (Aptr, Adir, Aentry, Amust_reset);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* A procedure to check for validation level problems, as well as access so that the	*/
/* notices can be written into the segment. If proper access is not there, this		*/
/* procedure will try to force access. The reset_acl procedure will then restore things	*/
/* the way they were.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl Aptr	   ptr,		/* IN					*/
        Adir	   char (*),	/* IN					*/
        Aentry	   char (*),	/* IN					*/
        Amode_set	   bit (1),	/* IN					*/
        Amust_reset	   bit (1);	/* OUT					*/
    dcl Acode	   fixed bin (35),
        old_mode	   bit (36) aligned;/* original access to a seg, if acl forced	*/


    dcl 1 acle	   (1),		/* structure for the list_acl and		*/
				/* add_acl_entries calls			*/
	2 name	   char (32) aligned,
	2 mode	   bit (36) aligned,
	2 mbz	   bit (36) aligned,
	2 code	   fixed bin (35);

    dcl 1 del_acl	   (1),		/* structure for the delete_acl_entries call	*/
	2 name	   char (32) aligned,
	2 code	   fixed bin (35);

    dcl one_word	   char (4) based,
        error_table_$lower_ring
		   fixed bin (35) ext static,
        error_table_$user_not_found
		   fixed bin (35) ext static;

    Amust_reset = False;		/* we've done nothing yet.			*/
    on not_in_write_bracket
      begin;
        call com_err_ (error_table_$lower_ring, ME, "
Writing ^a>^a.", Adir, Aentry);
        goto FATAL_ERROR;		/* non-local goto out of this mess		*/
      end;

    on no_write_permission goto FORCE_ACL;
    Aptr -> one_word = Aptr -> one_word;/* try to write the first word of the seg.	*/
    return;			/* no need to go further if it worked.		*/


FORCE_ACL:
    acle (1).name = get_group_id_ ();
    acle (1).mode = "0"b;
    acle (1).mbz = "0"b;
    acle (1).code = 0;
    call hcs_$list_acl (Adir, Aentry, null, null, addr (acle), 1, Acode);
    if acle (1).code ^= 0
    then if acle (1).code = error_table_$user_not_found
         then			/* this user not in ACL			*/
	    Amode_set = False;
         else goto ERROR;
    else
      do;
        if Acode ^= 0
        then
	do;
	  acle (1).code = Acode;
	  goto ERROR;
	end;
        Amode_set = True;		/* this user was in ACL			*/
        old_mode = acle (1).mode;	/* save current mode for restoring		*/
      end;
    acle (1).mode = "101"b;		/* we need rw access			*/
    acle (1).mbz = "0"b;
    acle (1).code = 0;
    call hcs_$add_acl_entries (Adir, Aentry, addr (acle), 1, Acode);
    if Acode ^= 0
    then
      do;
        call com_err_ (Acode, ME, "
Unable to force write access for ^a to ^a>^a.", acle (1).name, Adir, Aentry);
        goto FATAL_ERROR;
      end;
    Amust_reset = True;		/* we will have to reset access.		*/
    return;
ERROR:
    call com_err_ (acle (1).code, ME, "
When listing ^a's access to ^a>^a", acle (1).name, Adir, Aentry);
    goto FATAL_ERROR;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


check_acl$reset_acl:
  entry (Aptr, Adir, Aentry, Amode_set);

    acle (1).name = get_group_id_ ();	/* this proc has its own stack frame, so don't	*/
				/* rely on earlier name being there...		*/
    if Amode_set
    then
      do;				/* we must restore old mode			*/
        acle (1).mode = old_mode;
        acle (1).mbz = "0"b;
        acle (1).code = 0;
        call hcs_$add_acl_entries (Adir, Aentry, addr (acle), 1, Acode);
        if acle (1).code ^= 0
        then
	do;
	  call com_err_ (Acode, ME, "
Restoring access for ^a to ^a>^a.", acle (1).name, Adir, Aentry);
	  return;
	end;
      end;
    else
      do;
        del_acl (1).name = acle (1).name;
        del_acl (1).code = 0;
        call hcs_$delete_acl_entries (Adir, Aentry, addr (del_acl), 1, Acode);
        if Acode ^= 0 then call com_err_ (Acode, ME, "
Removing access for ^a to ^a>^a.", del_acl (1).name, Adir, Aentry);
        return;
      end;
    return;

  end check_acl;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


    dcl Lline	   fixed bin (21),
        Ltemp	   fixed bin (21),	/* lgth string searched by find_line		*/
        Pline	   ptr,
        Ptemp	   ptr,		/* ptr to string used by find_line		*/
        line	   char (Lline) based (Pline),
				/* a line of notice text to be added		*/
        temp	   char (Ltemp) based (Ptemp),
				/* string searched by find_line		*/
        temp_chr	   (Ltemp) char (1) based (Ptemp);

find_line:
  proc returns (bit (1));


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This internal procedure is used to obtain the text of pnotice templates, line by	*/
/* line, as they were built by the first half of the star_box internal procedure. These	*/
/* lines are used with format characters to build the actual comment box containing the	*/
/* notices.								*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    if Ltemp <= 0
    then return (False);
    else
      do;
        Pline = Ptemp;
        Lline = search (temp, NL);	/* find end of this line			*/
        Ptemp = addcharno (addr (temp_chr (Lline)), 1);
        Ltemp = Ltemp - Lline;
        Lline = Lline - 1;		/* remove the NL				*/
      end;
    return (True);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


find_line$init:
  entry (Pstr, Lstr);
    dcl Pstr	   ptr,
        Lstr	   fixed bin (21);
    Ptemp = Pstr;
    Ltemp = Lstr;
    return;

find_line$remainder_length:
  entry returns (fixed bin (21));

    return (Ltemp);

  end find_line;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
    dcl new_box	   char (target_info.Lnew_box)
		   based (target_info.Pnew_box);

insert_notice:
  proc (SI, TI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure adds the notice to a segment. In the case of free-standing segments,	*/
/* the target is the segment itself, but for archives, the target is a copy of the	*/
/* archive component in the process dir. The archive command then will update the	*/
/* archive via process_archive_components.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info,
				/* IN					*/
        1 TI	   aligned like target_info;
				/* IN					*/


    dcl Psource	   ptr,
        Ptarget	   ptr;

    Psource = addcharno (TI.Pnew_box, SI.Lold_box);
    Ptarget = addcharno (TI.Pnew_box, TI.Lnew_box);
				/* determine proper size hole for append	*/
				/* if new box is same size, we go by this.	*/
    if TI.Lnew_box > SI.Lold_box
    then				/* new notice box larger than old		*/
         call pnotice_mrl_ (Psource, SI.Lentry - SI.Lold_box, Ptarget,
	    SI.Lentry - SI.Lold_box); /* append seg				*/
    else if TI.Lnew_box < SI.Lold_box
    then				/* new notice box smaller than old		*/
				/* this may happen if source had >1 box in it	*/
         call pnotice_mlr_ (Psource, SI.Lentry - SI.Lold_box, Ptarget,
	    SI.Lentry - SI.Lold_box);

    TI.Lentry = (SI.Lentry - SI.Lold_box) + TI.Lnew_box;

    new_box = star_box;		/* obtain new box from the temp seg		*/
				/* copy box back from temp storage		*/
				/* For an archive, the archive command will be 	*/
				/* used to update the archive after all components*/
				/*  have been processed			*/
    call terminate_file_ (TI.Pentry, TI.Lentry * 9, TERM_FILE_TRUNC_BC, code);
				/* set the bit count.			*/
				/* THIS IS THE ONLY PLACE WHERE BIT COUNTS ARE SET*/


  end insert_notice;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

    dcl Lt	   fixed bin (21),	/* used by display_pnotice for template lgth	*/
        Pt	   ptr,
        template	   char (Lt) based, /* used by display_pnotice			*/
        dt	   char (4);


report:
  proc (SI, TI);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* An internal procedure that is used ONLY by display_pnotice to report on the		*/
/* protection notices found in a source program.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info;
    dcl 1 TI	   aligned like target_info;
    dcl Inotice	   fixed bin,
        Itemplate	   fixed bin;
    dcl pnames	   (SI.Nnotices) char (32);
    dcl Iyr	   fixed bin (24);


    if SI.Nnotices = 0
    then
      do;				/* NO NOTICE				*/
        if ^imbedded_notices (SI)
        then if SI.archive_name ^= ""
	   then call ioa_ ("Warning: ^a has no protection notice.",
		   pathname_$component (SI.dir, SI.archive_name, SI.entry))
		   ;
	   else call ioa_ ("Warning: ^a has no protection notice.",
		   pathname_ (SI.dir, SI.entry));
        else if SI.archive_name ^= ""
        then call ioa_ ("Warning: ^a has an imbedded notice.",
	        pathname_$component (SI.dir, SI.archive_name, SI.entry));
        else call ioa_ ("Warning: ^a has an imbedded notice.",
	        pathname_ (SI.dir, SI.entry));
        return;
      end;
    if TI.long_output
    then
      do;				/* LONG OUTPUT				*/
        call ioa_ ("^[^5x^a^2s^;^s^a>^a^/^]", SI.archive_name ^= "", SI.entry,
	   SI.dir, SI.entry);
        do Inotice = 1 to SI.Nnotices;
	do Itemplate = 1 to pnotice_paths.Ntemplates;
	  if (SI.notice_info (Inotice).notice_name
	       =
	       before (pnotice_paths.templates (Itemplate).primary_name,
	       ".pnotice"))
	  then
	    do;
	      Lt = pnotice_paths.templates (Itemplate).Ltemplate;
	      Pt = pnotice_paths.templates (Itemplate).Ptemplate;

	      if index (Pt -> template, "<yr>") = 0
	      then call ioa_ ("^a^/", Pt -> template);
	      else
	        do;
		Iyr = index (Pt -> template, "<yr>");
		dt = SI.notice_info (Inotice).notice_date;
		call print_template (Pt, Lt, Iyr, dt);
	        end;
	      Itemplate = pnotice_paths.Ntemplates;
	    end;
	end;
        end;
      end;
    else
      do;				/* SHORT OUTPUT				*/
        do Idx1 = 1 to SI.Nnotices;
	pnames (Idx1) = SI.notice_info (Idx1).notice_name;
        end;
        call ioa_ ("^[^5x^a^2s^;^s^a>^a^/^]^(^40t^a^/^)",
	   SI.archive_name ^= "", SI.entry, SI.dir, SI.entry, pnames);
      end;
  end report;
%page;
print_template:
  proc (Ppt, Plt, Pyr, Pdt);

    dcl Ppt	   ptr,		/* pointer to template			*/
        Plt	   fixed bin (21),	/* length of template			*/
        Pyr	   fixed bin (24),	/* position of <yr> in template		*/
        Pdt	   char (4),	/* source date				*/
        store_template char (Plt),
        store_templateb
		   char (Plt) based;




/************************************************************************/
/*							     */
/* Procedure to print the template with the date in source	     */
/*							     */
/************************************************************************/

    store_template = Ppt -> store_templateb;
    substr (store_template, Pyr, 4) = Pdt;
    call ioa_ ("^a^/", store_template);
    return;

  end print_template;


%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


imbedded_notices:
  proc (SI) returns (bit (1));


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This procedure will check for 60 lines into the source looking for any imbedded	*/
/* protection notices. It is used by display_pnotice to provide a warning message about	*/
/* such notices.								*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


    dcl 1 SI	   aligned like source_info;
    dcl sub_seg	   char (Lsub) based (Psub),
        Iseg	   fixed bin,
        Lseg	   fixed bin (21),
        Lsub	   fixed bin (21),
        Pseg	   ptr,
        Psub	   ptr;

    Pseg = SI.Pentry;
    Lseg = SI.Lentry;
    Psub = Pseg;
    Lsub = 0;
    call find_line$init (Pseg, Lseg);
    do Iseg = 1 to 60 while (find_line ());
				/*  for 60 lines				*/
      Lsub = Lsub + length (line) + length (NL);
    end;
    if (index (sub_seg, "Copyright") = 0 & index (sub_seg, "PROPRIETARY") = 0
         & index (sub_seg, "PUBLIC") = 0)
    then return (False);
    else return (True);		/* something hidden				*/
  end imbedded_notices;

%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

clean_up:
  proc;


    if ^Farchive
    then
      do;				/* this is a free standing segment.		*/
        if source_info.Pentry ^= null
        then call terminate_file_ (source_info.Pentry, bit_count,
	        TERM_FILE_TERM, code);/* terminate seg. Don't set bit count.		*/
      end;
    else
      do;				/* this was an archive			*/
        if Pcomp_info ^= null
        then
	do;
	  do Idx1 = 1 to comp_info.Ncomp;
				/* delete any component copies in pdir		*/
	    if comp_info.array (Idx1).ptr ^= null
	    then
	      do;
	        call hcs_$delentry_seg (comp_info.array (Idx1).ptr, code);
	      end;
	  end;
	  call release_temp_segment_ (ME, Pcomp_info, code);
				/* now release the component temp seg		*/
	end;
        if source_info.archive_name ^= ""
        then call terminate_file_ (source_info.Parchive, bit_count,
	        TERM_FILE_TERM, code);
        else if source_info.Pentry ^= null
        then call terminate_file_ (source_info.Pentry, bit_count,
	        TERM_FILE_TERM, code);/* terminate the archive, don't set bit count	*/
      end;

/* pnotice templates info			*/
    if Ppaths ^= null
    then
      do;
        do Itemplate = 1 to dim (pnotice_paths.templates, 1);
	call terminate_file_ (pnotice_paths.templates (Itemplate).Ptemplate,
	     pnotice_paths.templates (Itemplate).Ltemplate * 9,
	     TERM_FILE_TERM, code);
        end;
        call release_temp_segment_ (ME, Ppaths, code);
      end;


    if Ptext ^= null then call release_temp_segment_ (ME, Ptext, code);
				/* notice text and star box			*/


  end clean_up;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include arg_list;
    dcl arg_list_arg_count
		   fixed bin;
    dcl 1 al	   aligned based (Pal),
				/* argument list passed to cu_$generate_call	*/
	2 header	   like arg_list.header,
	2 ap	   (0 refer (al.header.arg_count)) ptr,
				/* argument pointers			*/
	2 dp	   (0 refer (al.header.desc_count)) ptr;
				/* descriptor pointers			*/
%page;
%include descriptor;
    dcl 1 desc	   (comp_info.Ncomp + 2) aligned based (Pdesc) like desc_;

%page;
%include desc_types;
%page;
%include pnotice_paths;
%page;
%include pnotice_source_info;
%page;
%include pnotice_target_info;
%page;
%include terminate_file;

  end add_pnotice;




		    display_psp.pl1                 10/25/89  1204.8r w 10/25/89  1000.0      309114



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1989                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1982 *
        *                                                         *
        * Copyright (c) 1972 by Massachusetts Institute of        *
        * Technology and Honeywell Information Systems, Inc.      *
        *                                                         *
        *********************************************************** */




/****^  HISTORY COMMENTS:
  1) change(88-12-01,Parisek), approve(89-01-03,MCR8037),
     audit(89-01-16,Farley), install(89-01-19,MR12.3-1006):
     Ignore the error_table_$undefined_order_request error code when
     calling the control order "dump_fnp" in fnp_fetch.  If the order
     is undefined for a particular FNP then we simply don't need to
     display the data produced by the control order.
                                                   END HISTORY COMMENTS */


display_psp:
     proc;




/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* The display_psp command will provide a means to       */
/* assure that products ordered and installed at a site  */
/* is at the correct revison and installed in the	       */
/* proper location. This tool will provide a quick       */
/* means to find the status of a product as to	       */
/* revision, marketing identifier, copyright and title.  */
/* This tool will indicate the correct version of the    */
/* software running only if care is taken at the site    */
/* to update the STI of installed modified software.     */
/* For more information on how to update the STI see     */
/* the generate_copyright command.		       */
/*					       */
/* 0) Written by R. Holmstedt 07/18/81		       */
/* 1) Modified by G. Dixon 10/15/84 - handle missing     */
/*	        source properly.		       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl  Ccode fixed bin (35);
dcl  MI_name char (9);
dcl  NL char (1) int static options (constant) init ("
");
dcl 01 Pnotice aligned,
    02 source_C char (1680) init (""),
    02 source_STI char (12) init (""),
    02 object_C char (1680) init (""),
    02 object_STI char (12) init (""),
    02 xecute_C char (1680) init (""),
    02 xecute_STI char (12) init ("");
dcl  QUOTE char (1) int static options (constant) init ("""");
dcl  Sptr ptr;
dcl  no_acc_sw init ("0"b) bit (1);
dcl  active_fnc_err_ entry options(variable);
dcl  af_flag init ("0"b) bit (1);
dcl  all_flag init ("0"b) bit (1);
dcl  arg char (argl) based (argp);
dcl  argl fixed bin (21);
dcl  argp ptr;
dcl  argno fixed bin;
dcl  brief_flag init ("0"b) bit (1);
dcl  code fixed bin (35);
dcl  com_err_ entry () options (variable);
dcl  copyw_flag init ("0"b) bit (1);
dcl  crmod fixed bin int static;
dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$af_arg_ptr	entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
dcl  cu_$arg_count entry (fixed bin);
dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
dcl  datanet_infop ptr internal static;
dcl  ddata_sdw fixed bin (71);
dcl  dn355_datap ptr int static;
dcl  dn355_data_len fixed bin int static;
dcl  dsegp ptr;
dcl (error_table_$incorrect_access, error_table_$noentry,
     error_table_$no_dir, error_table_$improper_data_format,
     error_table_$no_component, error_table_$bad_arg,
     error_table_$inconsistent, error_table_$segknown,
     error_table_$moderr, error_table_$no_info,
     error_table_$noarg, error_table_$wrong_no_of_args,
     error_table_$undefined_order_request) fixed bin (35) ext static;
dcl 01 fnp_infos aligned,				/* Data structure to dump fnp */
    02 fnp_addr fixed bin,
    02 fnp_len fixed bin,
    02 data_ptr ptr,
    02 prev_data_ptr ptr;
dcl  fnp fixed bin;
dcl  fnp_name char (1);
dcl 01 fnptab aligned int static,
    02 per_fnp (0:8),
      03 init_switches,
        04 modtab_init bit (1) unal,
      03 nmodules fixed bin,
      03 per_module (50),
        04 name char (6),
        04 start fixed bin,
        04 date char (6),
        04 sti char (12);
dcl  generic_name char (32) varying;
dcl  get_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  i fixed bin;
dcl  ioa_ entry () options (variable);
dcl  long_flag init ("0"b) bit (1);
dcl  match_flag init ("0"b) bit (1);
dcl  name_flag init ("0"b) bit (1);
dcl  nargs fixed bin;
dcl  parse_pnotice_info_ entry (ptr, fixed bin (35));
dcl  pathname_ entry (char(*), char(*)) returns(char(168));
dcl  phcs_$tty_order entry (fixed bin, char (*), ptr, fixed bin, fixed bin (35));
dcl  phcs_$tty_control entry (char (*), char (*), ptr, fixed bin (35));
dcl  print_prod fixed bin;
dcl  prog_name char (12) varying;
dcl  release_temp_segment_ entry (char (*), ptr, fixed bin (35));
dcl  ret char (retl) varying based (retp);
dcl  retl fixed bin(21);
dcl  retp pointer;
dcl  ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35));
dcl  ring_zero_peek_ entry (ptr, ptr, fixed bin (17), fixed bin (35));
dcl  true init ("1"b) bit (1) internal static options (constant);
dcl  warn char (80) varying;
dcl  xlate (0: 63) char (1) int static options (constant) init (

     "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "[", "#", "@", ":", ">", "?",

     " ", "A", "B", "C", "D", "E", "F", "G", "H", "I", "&", ".", "]", "(", "<", "^",

     "|", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "-", "$", "*", ")", ";", "'",

     "+", "/", "S", "T", "U", "V", "W", "X", "Y", "Z", "_", ",", "%", "=", """", "!");

dcl (addr, baseno, before, bin, convert, divide, hbound, index, length, 
     ltrim, min, null, size, substr, rank, rtrim, translate) builtin;


dcl (linkage_error, cleanup) condition;


/* ***********  S T A R T************* */

	Sptr = null;				/* prime pointers incase of error   */
	datanet_infop = null;
	dn355_datap = null;
	prog_name = "display_psp";
	on cleanup call janitor;

	call command_args ();
	call open_files ();
	call get_info ();
	call out_info ();
	goto fini;		/* exit			       */
	
/* \014 */
describe_psp: entry;
	

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*					       */
	/* this entry, describe_psp Marketing_Identifier Key     */
	/* operates as an active function so site and developers */
	/* can write tools based on a psp. Information will be   */
	/* returned based on a key passed in as an argument.     */
	/*					       */
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	dcl  message_out char (80) varying;
	prog_name = "describe_psp";
	call cu_$af_return_arg (nargs, retp, retl, code);
				/* check to see if invoked as an active function*/
	if code = 0 then af_flag = true;
	else call cu_$arg_count (nargs);   /* its a command	       */
	

	if nargs ^= 2 then do;	/* 1st is a marketing identifier and 2nd is a key*/
	     code = error_table_$wrong_no_of_args;
	     warn = "Usage: describe_psp Marketing_Identifier Key.";
	     goto bummer;
	end;

	call open_files ();		/* get space to work in	       */
	call get_info ();		/* read the >t>psp_info_ file	       */

				/* get 1st argument		       */
	if af_flag then call cu_$af_arg_ptr (1, argp, argl, code);
	else call cu_$arg_ptr (1, argp, argl, code);
	if code ^= 0 then do;
	     code = error_table_$wrong_no_of_args;
	     warn = "Error in parsing the first argument.";
	     goto bummer;
	end;
	arg = translate(arg, "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz");
				/* upper, lower case don't matter    */

	do i = 1 to product.prod_number while (arg ^= product.num(i).MI);
	end;
	if i > product.prod_number then do;
	     warn = "Illegal or unknown marketing identifier used: "||arg||".";
	     code = error_table_$bad_arg;
	     goto bummer;
	end;

				/* get 2nd argument		       */
	if af_flag then call cu_$af_arg_ptr (2, argp, argl, code);
	else call cu_$arg_ptr (2, argp, argl, code);
	if code ^= 0 then do;
	     code = error_table_$noarg;
	     warn = "Error in parsing the second argument.";
	     goto bummer;
	end;

	
	if arg = "title" then  message_out = product.num(i).prod_title;
	else if arg = "name" then  message_out = product.num(i).prod_name;
	else if arg = "sti" then  message_out = product.num(i).prod_STI;
	else if arg = "source" then message_out = rtrim(product.num(i).source_path.dirname)||">"||product.num(i).source_path.entryname;
	else if arg = "object" then message_out = rtrim(product.num(i).object_path.dirname)||">"||product.num(i).object_path.entryname;
	else if arg = "executable" then message_out = rtrim(product.num(i).x_path.dirname)||">"||product.num(i).x_path.entryname;
	else do;
	     warn = "Illegal or unknown key used: "||arg||".";
	     code = error_table_$bad_arg;
	     goto bummer;
	end;
	
	if ^af_flag then call ioa_ ("^a", message_out);
	else ret = message_out;
	goto fini;
	

/* \014 */
command_args: proc ();


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure will define the arguments used for     */
/* the command to process. Some checking is done on      */
/* arguments passed in as to valid characters	       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



	     call cu_$arg_count (nargs);

	     if nargs = 0 then do;			/* no args is ok use defaults	       */
		all_flag = true;
		brief_flag = true;
		return;
	     end;


	     do argno = 1 to nargs;


		call cu_$arg_ptr (argno, argp, argl, code);
		if code ^= 0 then goto bad_arg;

		if substr (arg, 1, 1) = "-" then do;

		     if arg = "-name" | arg = "-nm" then do;
			if name_flag then goto dup_arg;
			name_flag = true;
			argno = argno + 1;
			call cu_$arg_ptr (argno, argp, argl, code);
			if code ^= 0 then goto bad_arg;
			if substr (arg, 1, 1) = "-" then goto bad_arg;
			generic_name = arg;		/* i.e. compose, ted       */
		     end;

		     else if arg = "-match" then do;
			if match_flag then go to dup_arg;
			match_flag = true;
			argno = argno + 1;
			call cu_$arg_ptr (argno, argp, argl, code);
			if code ^= 0 then goto bad_arg;
			if substr (arg, 1, 1) = "-" then goto bad_arg;
			if argl ^= 7 then do;
			     warn = "Using incorrect number of characters for Marketing Identifier "||arg||".";
			     goto bummer;
			end;
			MI_name = arg;
		     end;

		     else if arg = "-brief" | arg = "-bf" then do;
			if brief_flag then goto dup_arg;
			brief_flag = true;
		     end;

		     else if arg = "-long" | arg = "-lg" then do;
			if long_flag then goto dup_arg;
			long_flag = true;
		     end;

		     else if arg = "-copyright" then do;
			if copyw_flag then go to dup_arg;
			copyw_flag = true;
		     end;

		     else if arg = "-all" | arg = "-a" then do;
			if all_flag then goto dup_arg;
			all_flag = true;
		     end;
		     else goto bad_arg;
		end;
		else goto bad_arg;
	     end;
	     if brief_flag & long_flag then do;
		code = error_table_$inconsistent;
		warn = "-brief and -long cannot be used together.";
		goto bummer;
	     end;

	     if match_flag & all_flag then do;
		code = error_table_$inconsistent;
		warn = "-match and -all cannot be used together.";
		goto bummer;
	     end;

	     if name_flag & all_flag then do;
		code = error_table_$inconsistent;
		warn = "-name and -all cannot be used together.";
		goto bummer;
	     end;

	     if match_flag & name_flag then do;
		code = error_table_$inconsistent;
		warn = "-match and -name cannot be used together.";
		goto bummer;
	     end;


	     return;
	end command_args;
						/* \014 */
open_files: proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure gets the working storage needed for    */
/* the command to operate			       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



	     call get_temp_segment_ ((prog_name), Sptr, code);
	     if code ^= 0 then do;
		warn = " Error while getting temporary segment for Sptr.";
		goto bummer;
	     end;

	     SI_ptr = Sptr;				/* let the product structure point to the temp.seg */

	     call get_temp_segment_ ((prog_name), datanet_infop, code);
	     if code ^= 0 then do;
		warn = " Error while getting temporary segment.";
		goto bummer;
	     end;
	     return;
	end open_files;
						/* \014 */
get_info:	proc;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure calls a rdc program that will read    */
/* the psp_info_ segment and return information	       */
/* contained in the ascii segment for use by the	       */
/* program, see software_pnotice_info_.incl.pl1 as to    */
/* the structure passed.			       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	     call parse_pnotice_info_ (SI_ptr, code);
	     if code ^= 0 then do;
		warn = "Error while reading psp_info_ file.";
		goto bummer;
	     end;

	     return;
	end get_info;

/* \014 */
find_lib_info:
	proc (dirname, entryname, prod_name);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure will probe into the library segments   */
/* and return information contained in them as to the    */
/* STI and protection notice.			       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */




dcl  P_ark_ptr ptr;
dcl  P_ark_bc fixed bin (24);
dcl  P_comp_seg char (P_comp_length) based (P_comp_ptr);
dcl  P_comp_length fixed bin;
dcl  P_comp_ptr ptr;
dcl  P_comp_bc fixed bin (24);
dcl  Tpointer fixed bin;
dcl  archive_$get_component entry (ptr, fixed bin (24), char (*), ptr,
     fixed bin (24), fixed bin (35));
dcl  cl fixed bin;
dcl  dirname char (168);
dcl  entryname char (32);
dcl  get_fnp_name_ entry (fixed bin) returns (char (32));
dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24),
     fixed bin (2), ptr, fixed bin (35));
dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
dcl  i fixed bin;
dcl  num_of_pnotice fixed bin;
dcl  prod_name char (24);
dcl  whitesp char (4) int static options (constant) init (" 	

");
dcl  xx fixed bin;

	     if length (ltrim (rtrim (entryname))) > 7 then do;
						/* do only if not an FNP module name */
		call hcs_$initiate_count (dirname, entryname, "", P_ark_bc, 1, P_ark_ptr, code);
		if code ^= 0 then do;
		     if code ^= error_table_$segknown then do;
						/* ok if we already know	       */
			call hcs_$terminate_noname (P_ark_ptr, Ccode);
			return;			/* let the caller know it don't exist */
		     end;
		     code = 0;			/* seg known is ok		       */
		end;
	     end;


	     if index (entryname, ".s.archive") ^= 0 then do;
						/* this is the routine to get the source info */

		call archive_$get_component
		     (P_ark_ptr, P_ark_bc, "PNOTICE_"||rtrim (prod_name)||".alm", P_comp_ptr, P_comp_bc, code);
						/* get a pointer to the notice component */
		if code ^= 0 then return;

		Pnotice.source_C = "";   /* init the copyright	       */

		P_comp_length = divide (P_comp_bc, 9, 17, 0);
						/* get the length to the pnotice seg */


		Tpointer = index (P_comp_seg, "dec");
						/* points to the version line	       */

		Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, (Tpointer + 3))), "dec");
						/* points to the no. of pnotices     */
		num_of_pnotice = convert (num_of_pnotice, (ltrim (rtrim (before ((
		     substr (P_comp_seg, (Tpointer + 3))), QUOTE), whitesp), whitesp)));
						/* save it away for later	       */



/* next comes the words in the copyright */
		do i = 1 to num_of_pnotice;
		     Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, Tpointer)), "acc");
		     Tpointer = Tpointer + index ((substr (P_comp_seg, Tpointer)), QUOTE);
						/* Tpointer points to the start of the notice */
		     Pnotice.source_C = rtrim (Pnotice.source_C) || substr
			(P_comp_seg, Tpointer, (index ((substr (P_comp_seg, Tpointer)), QUOTE) - 1))
			|| NL;
						/* stuff the words away for printing */
		     Tpointer = Tpointer + index ((substr (P_comp_seg, Tpointer)), QUOTE);
						/* move pointer to end of copyright  */


		end;

/* this is the source STI	       */
		Tpointer = Tpointer + 3 + index ((substr (P_comp_seg, (Tpointer + 3))), "aci");
						/* now suck off the STI	       */
		source_STI = substr ((ltrim (substr (P_comp_seg, (Tpointer + 3)), whitesp)), 2, 12);
						/* always 12 chars		       */
	     end;


	     else if index (entryname, ".archive") ^= 0 then do;
						/* this is the routine to get the object info */

		call archive_$get_component
		     (P_ark_ptr, P_ark_bc, "PNOTICE_"||rtrim (prod_name), P_comp_ptr, P_comp_bc, code);
						/* get a pointer to the notice component */
		if code ^= 0 then return;

		Pnotice.object_C = ""; /* init the area	       */
		

		P_pnotice_sti = P_comp_ptr;
						/* make the PNOTICE_ segment look like the include file */

		Pnotice.object_STI = pnotice_sti.STI (2);

		Tpointer = 1;

		do i = 1 to pnotice_sti.Npnotice;

		     cl = rank (substr (pnotice_sti.pnotice, Tpointer, 1));
		     Pnotice.object_C = 
			rtrim (Pnotice.object_C) || substr (pnotice_sti.pnotice, (Tpointer + 1), cl) || NL;
		     Tpointer = Tpointer + 1 + cl;
		end;
	     end;

	     else do;				/* do executable segments then       */
						/* this is an executable segment     */

		if index (entryname, "bound_") ^= 0 then do;


		     P_pnotice_sti = P_ark_ptr;
						/* make the PNOTICE_ segment look like the include file */
		     Tpointer = 1;
		     if pnotice_sti.Vpnotice_sti_1 ^= 1 then do;
						/* validate that segment has a copyright that can be probed */
			code = error_table_$improper_data_format;
			return;
		     end;
		     if pnotice_sti.Nsti ^= 3 then do;
						/* if not 3 better get out	       */
			code = error_table_$improper_data_format;
			return;
		     end;

		     Pnotice.xecute_C = "";	/* initialize the field    */

		     do i = 1 to pnotice_sti.Npnotice;
			cl = rank (substr (pnotice_sti.pnotice, Tpointer, 1));
			Pnotice.xecute_C = 
			     rtrim (Pnotice.xecute_C) || substr (pnotice_sti.pnotice, (Tpointer + 1), cl) || NL;
			Tpointer = Tpointer + 1 + cl;
		     end;

		     Pnotice.xecute_STI = pnotice_sti.STI (3);
		end;


/* this is a FNP module then	       */

		else if length (ltrim (rtrim (entryname))) <= 6 then do;

						/* need access to the phcs_	       */
		     call ring0_get_$segptr ("", "dseg", dsegp, code);
		     if code ^= 0 then do;
			warn = "Error getting pointer to dseg.";
			goto bummer;
		     end;

		     call get_sdw ("dn355_data", dn355_datap, addr (ddata_sdw));
		     if no_acc_sw =  true then return;


		     sdwp = addr (ddata_sdw);
		     dn355_data_len = (bin (sdw.bound, 14) + 1) * 16;


		     infop = datanet_infop;
		     call ring_zero_peek_ (dn355_datap, infop, dn355_data_len, code);
		     if code ^= 0 then do;
			warn = "Error getting information from dn355_data (ring 0).";
			goto bummer;
		     end;


		     do fnp = 1 to max_no_355s;	/* need to see how many FNPs */
			fnpp = addr (datanet_info.per_datanet (fnp));
			if fnp_info.running then do;
			     fnp_name = rtrim(get_fnp_name_ (fnp));

			     call setup_module_table (code);
			     if code ^= 0 then do;
				if code = error_table_$moderr then no_acc_sw = true;
				return;
			     end;

			     do xx = 1 to fnptab.per_fnp (fnp).nmodules
				while (entryname ^= fnptab.per_fnp (fnp).per_module (xx).name);
			     end;
						/* find the module we need;	       */
			     if xx <= fnptab.per_fnp (fnp).nmodules then

				call ioa_ ("FNP ^a: Module ^a STI ^a", fnp_name,
				fnptab.per_fnp (fnp).per_module (xx).name,
				fnptab.per_fnp (fnp).per_module (xx).sti);
			end;
		     end;
		     code = -1;			/* avoid the print_it proc from printing */

		end;
	     end;


	     return;
	end find_lib_info;

						/* \014 */

/* Procedure to setup internal static fnp table */

setup_module_table: proc (code);

dcl (i, j) fixed bin;
dcl  chainloc fixed bin;
dcl  mod_name char (8);
dcl  mod_sti char (12);
dcl 01 chain aligned,				/* Entry in module chain */
    02 next bit (18) unal,
    02 name (6) bit (6) unal,
    02 start bit (18) unal,
    02 date (6) bit (6) unal,
    02 sti (12) bit (6) unal;
dcl  code fixed bin (35);

	     if fnptab.modtab_init (fnp) then return;	/* Table all setup */

/* need to get start of module chain */
	     symbol_tablep = addr (db_fnp_symbols_$db_fnp_symbols_);

	     do i = 1 to symbol_table.cnt;
		symp = addr (symbol_table.entry (i));
		if ".crmod" = sym.name then do;
		     crmod = sym.value;		/* got the starting point	       */
		end;
	     end;


	     call fnp_fetch (crmod, 1, addr (chain.next), code);
						/* Get module chain start */
	     if code ^= 0 then do;
		if code = error_table_$moderr then
		     call ioa_ ("No access to phcs_ gate; unable to read FNP memory.");
		return;
	     end;

	     chainloc = bin (chain.next);		/* First chain is here */


	     i = 0;

	     do while ((chainloc ^= 0) & (i < hbound (fnptab.per_module, 2)));
		call fnp_fetch (chainloc, 10, addr (chain), code);

		i = i+1;
		fnptab.start (fnp, i) = bin (chain.start);

		mod_name = "";
		do j = 1 to 6;			/* Convert name */
		     substr (mod_name, j, 1) = xlate (bin (chain.name (j)));
		end;
		fnptab.name (fnp, i) = translate (rtrim(mod_name), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ");

		do j = 1 to 6;			/* Convert date */
		     substr (fnptab.date (fnp, i), j, 1) = xlate (bin (chain.date (j)));
		end;
		chainloc = bin (chain.next);		/* Next pointer */

		mod_sti = "";
		do j = 1 to 12;			/* Convert name */
		     substr (mod_sti, j, 1) = xlate (bin (chain.sti (j)));
		end;
		fnptab.sti (fnp, i) = mod_sti;
	     end;


	     fnptab.nmodules (fnp) = i;
	     fnptab.modtab_init (fnp) = "1"b;
	     return;


	end setup_module_table;

/* \014 */

fnp_fetch: proc (fnp_addr, arg_fnp_len, arg_data_ptr, code);

dcl  fnp_mem (fnp_len) bit (18) unal based;
dcl  fnp_addr fixed bin (17);
dcl  arg_fnp_len fixed bin (17);
dcl  arg_data_ptr ptr;
dcl  fnp_len fixed bin;
dcl  call_type fixed bin;
dcl  code fixed bin (35);
dcl  state fixed bin;

	     fnp_len = arg_fnp_len;
	     call_type = 0;
	     fnp_infos.fnp_len = arg_fnp_len;
	     fnp_infos.data_ptr = arg_data_ptr;
	     fnp_infos.fnp_addr = fnp_addr;
	     fnp_infos.prev_data_ptr = null;

	     do while (fnp_len > 0);
		fnp_infos.fnp_len = min (fnp_len, 64);
		if call_type = 0 then do;
		     on linkage_error go to call_1_failed;
		     call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_infos), state, code);
		     revert linkage_error;		/* It worked */
		     call_type = 1;
		     go to check_fetch_code;
call_1_failed:	     on linkage_error go to call_2_failed;
		     call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_infos), code);
		     revert linkage_error;
		     call_type = 2;
		     go to check_fetch_code;
call_2_failed:	     revert linkage_error;
		     code = error_table_$moderr;
		     return;
		end;
		else if call_type = 1 then call phcs_$tty_order (fnp, "dump_fnp", addr (fnp_infos), state, code);
		else call phcs_$tty_control (fnp_name, "dump_fnp", addr (fnp_infos), code);

check_fetch_code:
		if code = error_table_$undefined_order_request then do;
		     code = 0;			/* dump_fnp order was not defined for the FNP in question */
		     return;			/* don't worry about it.  Nothing will get printed */
		end;
		if code ^= 0 then return;

		fnp_infos.fnp_addr = fnp_infos.fnp_addr + fnp_infos.fnp_len;
						/* Check next address */
		fnp_infos.data_ptr = addr (fnp_infos.data_ptr -> fnp_mem (fnp_infos.fnp_len + 1));
		fnp_len = fnp_len - fnp_infos.fnp_len;
	     end;

	end fnp_fetch;


/* \014 */
get_sdw:
	proc (seg_name, ring_zero_ptr, sdw_ptr);

dcl  seg_name char (*);
dcl  ring_zero_ptr ptr;
dcl  sdw_ptr ptr;


	     call ring0_get_$segptr ("", seg_name, ring_zero_ptr, code);
						/* get pointer to ring 0 seg */
	     if code ^= 0 then do;
		warn = "Error trying to read sdw for dn355_data.";
		no_acc_sw = true;
		return;
	     end;
	     call ring_zero_peek_ (addr (dsegp -> sdwa (bin (baseno (ring_zero_ptr), 18))), sdw_ptr, size (sdw), code);
	     if code ^= 0 then do;
		warn = "Error trying to read sdw for dn355_data.";
		no_acc_sw = true;
		return;
	     end;
	     return;
	end get_sdw;


						/* \014 */
out_info:	proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure will select the information for	       */
/* output to the user. The arguments -all, -match and    */
/* -name will be acted on and the information will be    */
/* passed to print_it for final formatting by the other  */
/* arguments that can be used.		       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
dcl (ii, j) fixed bin;


	     if ^long_flag then brief_flag = true;	/* need one but not both   */

	     if match_flag then do;			/* only want one product	       */
		do i = 1 to product.prod_number while (MI_name ^= product.num (i).MI);
		end;
		print_prod = i;


		if i > product.prod_number then do;	/* oops!	       */
		     warn = "Illegal or unknown marketing identifier used "|| MI_name||".";
		     code = error_table_$bad_arg;
		     goto bummer;
		end;

/* this product is made up of other products, so use them instead */

		if product.num (i).prod_use (1) ^= "" then do;
		     do j = 1 to 10 while (product.num (i).prod_use (j) ^= "");

			do ii = 1 to product.prod_number while (product.num (i).prod_use (j) ^= product.num (ii).MI);
			end;

			if ii > product.prod_number then do; /* oops!	       */
			     warn = "Illegal or unknown marketing identifier from psp_info_ used "|| MI_name||".";
			     code = error_table_$bad_arg;
			     goto bummer;
			end;
			print_prod = ii;
			call print_it;
		     end;
		end;

		else				/* the product is defined use it     */
		call print_it;
	     end;

	     else if name_flag then do;		/* only want one product	       */

		do i = 1 to product.prod_number while (generic_name ^= product.num (i).prod_name);
		end;

		if i > product.prod_number then do;	/* oops!	       */
		     warn = "Illegal or unknown name used "|| generic_name||".";
		     code = error_table_$bad_arg;
		     goto bummer;
		end;

		print_prod = i;

/* this product is made up of other products, so use them instead */

		if product.num (i).prod_use (1) ^= "" then do;
						/* if many products make up this product */
		     do j = 1 to 10 while (product.num (i).prod_use (j) ^= "");

			do ii = 1 to product.prod_number while (product.num (i).prod_use (j) ^= product.num (ii).MI);
			end;			/* check if real product in psp_info_ */


			if ii > product.prod_number then do; /* oops!	       */
			     warn = "Illegal or unknown marketing identifier from psp_info_ used "|| MI_name||".";
			     code = error_table_$bad_arg;
			     goto bummer;
			end;
			print_prod = ii;
			call print_it;
		     end;
		end;

		else				/* use this product no other	       */
		call print_it;
	     end;

	     else					/* all is the default	       */

	     do i = 1 to product.prod_number;


		print_prod = i;			/* bump the count of the product     */


/* just be sure this is a real product, not made up of other products */
		if product.num (i).prod_use (1) = "" then call print_it;

	     end;

	     return;

	end out_info;
						/* \014 */

print_it:	proc;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*					       */
/* This procedure will output the information in a       */
/* format asked for by the user. The options are -long,  */
/* -brief or -copyright.			       */
/*					       */
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



	     if long_flag then do;			/* print all info		       */


		call ioa_ ("^/^a.", rtrim (product.num (print_prod).prod_title));
		call ioa_ ("Marketing identifier           ^a.", product.num (print_prod).MI);

		call validate_macro			/* now get source info	       */
		     ((product.num (print_prod).source_path.dirname),
		     (product.num (print_prod).source_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then do;
		     call ioa_ ("STI                            ^a.", Pnotice.source_STI);
		     call ioa_ ("Protection notice from         ^a. ^/^a",
			product.num (print_prod).source_path.entryname,
			ltrim (rtrim (rtrim (Pnotice.source_C), QUOTE), QUOTE));
		end;

/* output object info long format    */

		call validate_macro			/* now get object info	       */
		     ((product.num (print_prod).object_path.dirname),
		     (product.num (print_prod).object_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then do;		/* can't complain if not found       */

		     call ioa_ ("STI                            ^a.", Pnotice.object_STI);
		     call ioa_ ("Protection Notice from         ^a ^/^a",
			product.num (print_prod).object_path.entryname, Pnotice.object_C);
		end;


		call validate_macro			/* now get executable info	       */
		     ((product.num (print_prod).x_path.dirname),
		     (product.num (print_prod).x_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then do;
		     call ioa_ ("STI                            ^a.", Pnotice.xecute_STI);
		     call ioa_ ("Protection Notice from         ^a ^/^a",
			product.num (print_prod).x_path.entryname, Pnotice.xecute_C);

		end;
	     end;

	     else if copyw_flag then do;		/* print the copyright     */

		call validate_macro
		     ((product.num (print_prod).source_path.dirname),
		     (product.num (print_prod).source_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then do;

		     call ioa_ ("Protection notice from            ^a ^/^a",
			product.num (print_prod).source_path.entryname, rtrim (Pnotice.source_C));
		end;


		call validate_macro			/* now do the object info	       */
		     ((product.num (print_prod).object_path.dirname),
		     (product.num (print_prod).object_path.entryname),
		     (product.num (print_prod).prod_name));
		if code = 0 then do;

		     call ioa_ ("Protection notice from            ^a ^/^a",
			product.num (print_prod).object_path.entryname, rtrim (Pnotice.object_C));
		end;

		call validate_macro			/* now do the executable info	       */
		     ((product.num (print_prod).x_path.dirname),
		     (product.num (print_prod).x_path.entryname),
		     (product.num (print_prod).prod_name));
		if code = 0 then do;

		     call ioa_ ("Protection notice from            ^a ^/^a",
			product.num (print_prod).x_path.entryname, rtrim (Pnotice.xecute_C));

		end;
	     end;

	     else if brief_flag then do;		/* print only the STI	       */
		call ioa_ ("^/^a.", rtrim (product.num (print_prod).prod_title));
		call validate_macro
		     ((product.num (print_prod).source_path.dirname),
		     (product.num (print_prod).source_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then
		     call ioa_ ("^a", Pnotice.source_STI);



/* now do for the object	       */
		call validate_macro
		     ((product.num (print_prod).object_path.dirname),
		     (product.num (print_prod).object_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then call ioa_ ("^a", Pnotice.object_STI);


/* now do for the executable segment */
		call validate_macro
		     ((product.num (print_prod).x_path.dirname),
		     (product.num (print_prod).x_path.entryname),
		     (product.num (print_prod).prod_name));

		if code = 0 then call ioa_ ("^a", Pnotice.xecute_STI);

	     end;

	     return;
	end print_it;
						/*  \014 */

validate_macro:
	procedure (dirname, entryname, prod_name);

dcl  dirname char (168);
dcl  entryname char (32);
dcl  prod_name char (24);

	     if dirname = "" & entryname = "" then do;
	          code = -1;
		return;
	     end;

	     call find_lib_info (dirname, entryname, prod_name);


	     if code ^= 0 then do;

		if code = error_table_$noentry then do;
		     call com_err_ (code, prog_name, "^/^a not found.",
		        pathname_ (dirname, entryname));
		     code = -1;
		     return;
		end;

		if code = error_table_$improper_data_format then do;
		     call com_err_ (code, prog_name,
			"^/Could not get pnotice information from ^a.",
			pathname_ (dirname, entryname));
		     code = -1;
		     return;
		end;

		if code = error_table_$no_info then do;
			call com_err_ (code, prog_name, "^/You do not have access to read information from the datanet.");
			code = -1;
			return;
		end;

		if code = error_table_$no_dir then do;
		     call com_err_ (code, prog_name, "^/The path ^a not found installed.", dirname);
		     code = -1;
		     return;
		end;

		else if code = error_table_$moderr then do;
		     call com_err_ (code, prog_name, "^/The entry ^a", entryname);
		     code = -1;
		     return;
		end;
		else if code = error_table_$incorrect_access then do;
		     call com_err_ (code, prog_name, "^/The entry ^a", entryname);
		     code = -1;
		     return;
		end;

		else if code = error_table_$no_component then do;
		     call com_err_ (code, prog_name, "^/archive ^a",
		        pathname_ (dirname, entryname));
		     code = -1;
		     return;
		end;

		else if code = -1 then return;	/* this is an fnp module   */

		warn = "Error while finding library information for "
		     ||rtrim (product.num (print_prod).object_path.entryname)||".";

		goto bummer;

	     end;
	end validate_macro;


/* \014 */
janitor:	proc;

dcl  Ccode fixed bin (35);


	     if Sptr ^= null then
		call release_temp_segment_ ((prog_name), Sptr, Ccode);
						/* release temp segment used for product structure */

	     if datanet_infop ^= null then
		call release_temp_segment_ ((prog_name), datanet_infop, Ccode);
						/* release temp segment used for FNP info	       */


	end janitor;

bad_arg:

	code = error_table_$bad_arg;
	warn = arg;
	goto bummer;


dup_arg:
	code = error_table_$inconsistent;
	warn = arg || " appears twice on the command line.";
	goto bummer;


bummer:
	if af_flag then call active_fnc_err_ (code, prog_name, "^/^a", warn);
	else call com_err_ (code, prog_name, "^/^a", warn);
	call janitor;
	return;

fini:
	call janitor;
	return;

%include software_pnotice_info_;
%include pnotice;
%include dn355_data;
%include sdw;
%include debug_fnp_data;

     end display_psp;




		    generate_pnotice.pl1            02/13/86  1224.3rew 02/13/86  1217.2      664947



/* ***********************************************************
   *                                                         *
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *                                                         *
   *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-09-27,LJAdams), approve(85-09-27,MCR7150),
     audit(86-02-07,Wallman), install(86-02-13,MR12.0-1017):
     The following
     changes were made:  (1) Accept -dc, -dts, and public_domain as valid
     pnotice names, (2) Accept multiple component prefixes for pnotice names,
     (3) Accept new format of template name without the date, and (4)
     compatibiltiy and validity checking of template names of user input and of
     psp_info_.
                                                   END HISTORY COMMENTS */


generate_pnotice:
	proc;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* NAME:	        generate_pnotice						*/
	/*									*/
	/* FUNCTION:								*/
	/*     This program is the tool that provides software protection notices (pnotices) for	*/
	/* the various Multics Priced Software Products (PSPs). There are numerous checks built	*/
	/* into the program to check the consistency and accuracy of the psp_info_ database,	*/
	/* which is the driver data structure for each PSP's protection notices. This program	*/
	/* also provides the Software Technical Identifiers (STIs) for each product. The method	*/
	/* used to protect each product is, basically, to build an ALM source  containing	*/
	/* pnotices and STIs. This source is put into the source archive (primary archive) of	*/
	/* the PSP. The ALM source is compiled, and that is put into the corresponding object	*/
	/* archive of the PSP.							*/
	/*									*/
	/* CREATED:     May 1981 by JM Stansbury.					*/
	/*									*/
	/* Modified:    June 1982 by JM Stansbury.					*/
	/*              1. To force access if necessary to archives if -special is used.	*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

%page;
	

/*  A U T O M A T I C  */
dcl Fany		          bit (1),			/* flag to say that any args other than		*/
						/*  "-special" have been supplied.		*/
    Fcopy_right               bit (1),
    Fdcopy_right		bit (1),                      /* flag for indicating default copyright	*/
    Fdtrade_secret            bit (1),                      /* flag for indicating default trade secret	*/
    Fname		          bit (1),			/* flag for indication of the "-name" arg	*/
    Fmust_reset_object        bit (1),			/* indicate actions on acl			*/
    Fmust_reset_source	bit (1),
    Fsti		          bit (1),			/* flag for indication of the "-sti" arg	*/
    Fpublic_domain            bit (1),                      /* flag for indicating public domain		*/
    Fmid		          bit (1),			/* flag for indication of the "-id" arg for MIDs	*/
    Fspec		          bit (1),			/* flag for indication of the "-special" arg	*/
    Ftrade_secret             bit (1),                      
    Idx		          fixed bin,		/* general purpose indices			*/
    Idx1		          fixed bin,
    Idx2		          fixed bin,
    Idx3		          fixed bin,
    Isnotice	          fixed bin,
    Ionotice	          fixed bin,
    Larg		          fixed bin (21),		/* lgth of current argument			*/
    Ltemp		          fixed bin,		/* lgth of a single pnotice			*/
    Ltotal		fixed bin,		/* lgth of multiple pnotices			*/
    Nargs		          fixed bin,		/* no. of input args			*/
    Parg		          ptr,			/* ptr to current argument			*/
    P_line	          ptr,			/* ptr to a command line for cu_$cp		*/
    Piocb		          ptr,
    Pnotices	          ptr,			/* ptr to Ppaths temp seg for pnotice_paths_	*/
    Po_archive	          ptr,			/* ptr to the object archive			*/
    Ppsp_info                 ptr,                          /* ptr to psp_info_ structure			*/
    Ps_archive	          ptr,			/* ptr to the source archive			*/
    Ptemp		          ptr,			/* ptr to temp segment			*/
    answer		char (168) var,		/* from command_query_			*/
    sbit_count	          fixed bin (24),		/* bit count of source archive		*/
    obit_count	          fixed bin (24),		/* bit count of object archive		*/
    case		          fixed bin,
    code		          fixed bin (35),
    component_name	          char (32),		/* name of PNOTICE seg in an archive		*/
    current_year_a            char(4),
    Iyr                       fixed bin(24),
    sdir		          char (168),
    odir		          char (168),
    match_found		bit (1),			/* checks correspondence between source & object	*/
    object_pnotices	          fixed bin,		/* count of object pnotices			*/
    oentry		char (32),
    path		          char (168),
    pn		          char (512) var,		/* string containing text of multiple pnotices	*/
    prod		          char (20),		/* generic product name			*/
    prod_mid		char (7),			/* product marketing ID, if supplied via args	*/
    prod_object_pnotice       (10) char (32) var,
    prod_object_ename         char (32),
    prod_source_pnotice       (10) char (32) var,		/* use the primary name of template		*/
    prod_source_ename         char (32),
    prod_sti	          char (12),		/* product's STI number			*/
    sentry		char (32),
    source_pnotices	          fixed bin,		/* count of source pnotices			*/
    this_is_object_archive    bit(1),
    this_is_source_archive    bit(1),
    user_on_source_acl	bit(1),
    user_on_object_acl        bit(1),
    working_dir		char (168);
	

/*  B A S E D    A N D   S T R U C T U R E S */
dcl argument	          char (Larg) based (Parg);
dcl temp		          char (Ltemp) based (Ptemp);
dcl 1 ACI,
      2 aci like archive_component_info;		/* structure filled in by 			*/
						/* archive_$get_component_info		*/
dcl 1 ACIS		aligned int static options (constant),
      2 vers		fixed bin init (1),
      2 bc		fixed bin (24),
      2 c_ptr	          ptr,
      2 nm		char (32) unaligned,
      2 tmod	          fixed bin (71),
      2 tupd	          fixed bin (71),
      2 c_lgth	          fixed bin (19),
      2 acl		bit (36) unaligned;

						/* structure used by command_query_		*/
dcl 1 query_info	          aligned int static,
      2 version		fixed bin init (1),
      2 switches,
        3 yes_or_no_sw        bit (1) unal init ("0"b),
        3 suppress_name_sw    bit (1) unal init ("1"b),
        3 suppress_spacing_sw bit (1) unal init ("1"b),
        3 cp_escape_control   bit (2) unal init ("00"b),
        3 pad	          bit (31) unal,
      2 status_code	          fixed bin (35) init (0),
      2 query_code	          fixed bin (35) init (0),
      2 question_iocbp        ptr init (null),
      2 answer_iocbp	ptr init (null),
      2 repeat_time	          fixed bin (71) init (0);
	


/*  B U I L T I N  */
dcl (addr,
     after,
     before,
     clock,
     dim,
     hbound,
     index,
     length,
     null,
     reverse,
     rtrim,
     substr,
     unspec)	          builtin;

/*  C O N D I T I O N S  */
dcl (cleanup,
     not_in_write_bracket,
     no_write_permission)     condition;

/*  E N T R I E S  */
dcl alm			entry options(variable),
    archive		entry options(variable),
    archive_$get_component_info
			entry (ptr, fixed bin(24), char(*), ptr, fixed bin(35)),
    check_entryname_	entry (char(*), fixed bin(35)),
    com_err_		entry() options(variable),
    command_query_		entry() options(variable),
    cu_$arg_count		entry (fixed bin, fixed bin(35)),
    cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
    date_time_$format         entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
    delete_$path		entry (char(*), char(*), bit(6), char(*), fixed bin(35)),
    expand_pathname_	entry (char(*), char(*), char(*), fixed bin(35)),
    get_group_id_		entry() returns(char(32)),
    get_temp_segment_	entry (char(*), ptr, fixed bin(35)),
    get_wdir_		entry() returns(char(168)),
    hcs_$add_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
    hcs_$delete_acl_entries	entry (char(*), char(*), ptr, fixed bin, fixed bin(35)),
    hcs_$initiate_count	entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)),
    hcs_$list_acl		entry (char(*), char(*), ptr, ptr, ptr, fixed bin, fixed bin(35)),
    ioa_			entry() options(variable),
    ioa_$ioa_switch		entry() options(variable),
    iox_$attach_ioname	entry (char(*), ptr, char(*), fixed bin(35)),
    iox_$close		entry (ptr, fixed bin(35)),
    iox_$detach_iocb	entry (ptr, fixed bin(35)),
    iox_$open		entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)),
    list_pnotice_names	entry options(variable),
    parse_pnotice_info_       entry (ptr, fixed bin (35)),
    parse_pnotice_info_$validate_sti
			entry (char(12)) returns(bit(1)),
    pnotice_paths_		entry (char(*), bit(*), ptr, fixed bin(35)),
    release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
    terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));
    

/*  E X T E R N A L   S T A T I C  */
dcl error_table_$badopt	          fixed bin(35) ext static,
    error_table_$name_not_found	fixed bin(35) ext static,
    error_table_$active_function        fixed bin(35) ext static,
    error_table_$no_w_permission	fixed bin(35) ext static,
    error_table_$lower_ring   	fixed bin(35) ext static,
    error_table_$no_component	          fixed bin(35) ext static,
    error_table_$noentry		fixed bin(35) ext static,
    error_table_$wrong_no_of_args	fixed bin(35) ext static;
	
	

/*  I N T E R N A L   S T A T I C  */
dcl ME			char (16) int static options (constant) init ("generate_pnotice"),
    NL		          char (1) int static options (constant) init ("
"),
    True		          bit (1) int static options (constant) init ("1"b),
    False		          bit (1) int static options (constant) init ("0"b);
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


	on cleanup call clean_up;
	call init;
	call cu_$arg_count (Nargs, code);
	if code = error_table_$active_function then
	     goto USAGE;
	else if Nargs = 0 then do;
	     code = error_table_$wrong_no_of_args;
	     go to USAGE;
	     end;
	do Idx = 1 to Nargs;
	     call cu_$arg_ptr (Idx, Parg, Larg, code);
	     if code ^= 0 then do;
		call com_err_ (code, ME, argument);
		return;
		end;
	     else if substr(argument, 1, 1) ^= "-" then
		goto USAGE;
	     else if argument = "-name" | argument = "-nm" then do;
		Idx = Idx + 1;
		call cu_$arg_ptr (Idx, Parg, Larg, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Arg= ^a", argument);
		     return;
		     end;
		prod = argument;			/* should be generic name of product.		*/
		Fany = True;
		Fname = True;
		end;
	     else if argument = "-id" then do;
		Idx = Idx + 1;
		call cu_$arg_ptr (Idx, Parg, Larg, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Arg= ^a", argument);
		     return;
		     end;
		prod_mid = argument;		/* product's marketing ID.			*/
		Fany = True;
		Fmid = True;
		end;
	     else if argument = "-sti" then do;		/* product STI. Input if user wants to 		*/
						/* over-ride psp_info_			*/
		Idx = Idx + 1;
		call cu_$arg_ptr (Idx, Parg, Larg, code);
		if code ^= 0 then do;
		     call com_err_ (code, ME, "Arg= ^a", argument);
		     return;
		     end;
		prod_sti = argument;
		if ^parse_pnotice_info_$validate_sti (prod_sti) then do;
		     call ioa_ ("Error - invalid STI: ^a", argument);
		     return;
		     end;
		Fany = True;
		Fsti = True;
		end;
	     else if argument = "-special" then
		Fspec = True;			/* user wants to provide most of the info.	*/
	     else do;
		code = error_table_$badopt;
		goto USAGE;
		end;
	     end;
MORE_TRASH:
	if Fname & Fmid then do;
	     call ioa_ ("The name and match args are mutually exclusive.");
	     code = error_table_$wrong_no_of_args;
	     goto USAGE;
	     end;
	else if Fspec & Fany then do;
	     call ioa_ ("The special arg is to be used alone.");
	     code = error_table_$wrong_no_of_args;
	     goto USAGE;
	     end;
	else go to WORK;
USAGE:	call com_err_ (code, ME, "
Usage:  generate_pnotice {-name | -nm <generic name>}
                         {-id <MID>}
		     {-sti <STI>}
		     {-special}");
	return;
WORK:	call get_temp_segment_ (ME, Ppsp_info, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "getting temp seg for psp_info.");
	     return;
	     end;
	SI_ptr = Ppsp_info;
	call parse_pnotice_info_ (SI_ptr, code);	/* fill in the psp_info structure		*/
	if code ^= 0 then do;
	     call com_err_ (code, ME, "filling in psp_info.");
	     call release_temp_segment_ (ME, Ppsp_info, code);
	     return;
	     end;
	call pnotice_paths_ (ME, "00"b, Ppaths, code);	/* fill in template information		*/
	if code ^= 0 then				/* pnotice_paths_ will complain for us.		*/
	     goto CLEAN;				/* get out of this				*/
	pnotice_paths.templates(*).primary_name = before(pnotice_paths.templates(*).primary_name, ".pnotice");
						/* this program was written before pnotice_paths_ */
						/* was trained to return the entire name.	*/
	working_dir = get_wdir_ ();			/* use wdir for archives and PNOTICEs		*/
	if Fspec then do;
	     call get_PNOTICE_info;
	     goto CHECK_PN;
	     end;
	else if Fname then do;
	     do Idx3 = 1 to product.prod_number while (prod ^= product.num(Idx3).prod_name);
		end;
	     if Idx3 > product.prod_number then do;
		code = error_table_$name_not_found;
		call com_err_ (code, ME, "^/Looking for ""^a"" in psp_info_", prod);
		call clean_up;
		return;
		end;
	     end;
	else if Fmid then do;
	     do Idx3 = 1 to product.prod_number while (prod_mid ^= product.num(Idx3).MI);
		end;
	     if Idx3 > product.prod_number then do;
		code = error_table_$name_not_found;
		call com_err_ (code, ME, "^/Specified MID was not found in psp_info_.", prod_mid);
		call clean_up;
		end;
	     end;
	prod = product.num(Idx3).prod_name;		/* generic name				*/
	if product.num(Idx3).prod_use(1) ^= "" then do;
	     call ioa_ ("Multiple products found in psp_info_.
                 ^/Please use this command with each product.");
	     call clean_up;
	     return;
	     end;
	if ^Fsti then
	     prod_sti = product.num(Idx3).prod_STI;	/* STI in psp_info_ is for source code		*/
          Idx = 0;                                          /*Initialize index to 0			*/
	do Idx2 = 1 to 10 while (product.num(Idx3).source_C(Idx2) ^= "");
						/* get all source pnotice names		*/
	     prod_source_pnotice(Idx2) = product.num(Idx3).source_C(Idx2);
               Idx1 = check_name(prod_source_pnotice(Idx2));
               if Idx1 > pnotice_paths.Ntemplates then do;
                 code = error_table_$name_not_found;
                 call com_err_ (code, ME, "^/Invalid psp_info_ name - ^a.", prod_source_pnotice(Idx2));
                 goto CLEAN;
                 end;
               Idx = Idx + 1;
               if Idx > 1 then
                 if ^templates_compatible(prod_source_pnotice) then do;
                  call com_err_ (code, ME, "^a - ^/pnotice types not compatible.", prod);
                  goto CLEAN;
	        end;
	     source_pnotices = source_pnotices + 1;	/* count them				*/
	     end;
          Idx = 0;                                          /* Initialize index to 0			*/
	do Idx2 = 1 to 10 while (product.num(Idx3).object_C(Idx2) ^= "");
						/* get all object pnotice names		*/
	     prod_object_pnotice(Idx2) = product.num(Idx3).object_C(Idx2);
               Idx1 = check_name(prod_object_pnotice(Idx2));
               if Idx1 > pnotice_paths.Ntemplates then do;
                 code = error_table_$name_not_found;
                 call com_err_ (code, ME, "^/Invalid psp_info_ name - ^a.", prod_object_pnotice(Idx2));
                 goto CLEAN;
                 end;
               Idx = Idx + 1;
               if Idx > 1  then
                 if ^templates_compatible(prod_object_pnotice) then do;
                  call com_err_ (code, ME, "^a - ^/pnotice types not compatible.", prod);
                  goto CLEAN;
	        end;
	     object_pnotices = object_pnotices + 1;	/* count these too				*/
	     end;
						/* next, get source archive name		*/
	prod_source_ename = product.num(Idx3).source_path.entryname;
						/* next, get object archive name		*/
	prod_object_ename = product.num(Idx3).object_path.entryname;
CHECK_PN: 
	if source_pnotices = 1 & object_pnotices = 1 then do;
	     if prod_source_pnotice(1) = prod_object_pnotice(1) then
		case = 1;				/* only one PNOTICE source has to be made	*/
	     else case = 3;				/* two PNOTICE source segs needed		*/
	     end;
	else do;

	     if ^check_multiple_pnotices() then do;
		call ioa_ ("Unexpected errors encountered - procedure terminated.");
		call clean_up;
		return;
		end;
	     if source_pnotices ^= object_pnotices then do;
		case = 4;
		goto CONTINUE;
		end;
	     else do Idx = 1 to source_pnotices;	/* check to see if there is an object		*/
						/* pnotice corresponding to each source pnotice	*/
		match_found = False;
		do Idx2 = 1 to object_pnotices;
		     if prod_object_pnotice(Idx2) = prod_source_pnotice(Idx) then
			match_found = True;
		     end;
		if ^match_found then do;
		     case = 4;
		     goto CONTINUE;
		     end;
		end;
	     case = 2;
	     end;
	
CONTINUE: 
	call make_PNOTICE (case);			/* create the ALM source and object segs	*/
	if Fspec then
	     call archive_PNOTICE (sdir, odir);
	else
	     call archive_PNOTICE (working_dir, working_dir);
						/* put them into proper archives		*/
CLEAN:	call clean_up;				/* logical exit from the program		*/
	return;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
check_archive:
	proc (Adir, Aentry, Aptr);
	
dcl Adir		   char(*),
    Aentry	   char(*),
    Aptr		   ptr;
dcl one_word	   char(4) based;

	on not_in_write_bracket begin;
	     call com_err_ (error_table_$lower_ring, ME, "^/Writing ^a>^a.", Adir, Aentry);
	     goto CLEAN;
	     end;
	on no_write_permission goto COMPLAIN;
	Aptr -> one_word = Aptr -> one_word;		/* try to write the first word		*/
	return;					/* if it worked, everything is OK		*/
COMPLAIN: call com_err_ (error_table_$no_w_permission, ME, "^/Checking ACL of ^a>^a.", Adir, Aentry);
	goto CLEAN;
	end check_archive;

%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

clean_up: proc;

	if Ppaths ^= null then do;
	     do Idx = 1 to dim(pnotice_paths.templates, 1);
						/* terminate all templates first		*/
		call terminate_file_ (pnotice_paths.templates(Idx).Ptemplate,
		  pnotice_paths.templates(Idx).Ltemplate * 9, TERM_FILE_TERM, code);
		end;
	     call release_temp_segment_ (ME, Ppaths, code);
						/* now release temp seg			*/
	     end;

	if Ppsp_info ^= null then
	     call release_temp_segment_ (ME, Ppsp_info, code);

	if Fspec then do;
	     if Fmust_reset_source then
		call check_acl$reset_acl (Ps_archive, sdir, sentry, "1"b, user_on_source_acl);
	     if Fmust_reset_object then
		call check_acl$reset_acl (Po_archive, odir, oentry, "0"b, user_on_object_acl);
	     end;
	if Ps_archive ^= null then
	     call terminate_file_ (Ps_archive, sbit_count, TERM_FILE_TERM, code);
	if Po_archive ^= null then
	     call terminate_file_ (Po_archive, obit_count, TERM_FILE_TERM, code);
	end clean_up;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init:	proc;

	Fmust_reset_source, Fmust_reset_object = False;
	Idx = 0;
	Idx2 = 0;
	Idx3 = 0;
	Isnotice = 0;
	Ionotice = 0;
	Ps_archive = null;
	Po_archive = null;
	Ppaths = null;
	Ptemp = null;
	P_line = null;
	Ppsp_info = null;
	Pnotices = null;
	Ltotal = 0;
	pn = "";
	source_pnotices = 0;
	object_pnotices = 0;
	prod_source_pnotice(*) = "";
	prod_object_pnotice(*) = "";
	unspec (ACI) = unspec (ACIS);
	match_found = False;
	Fany = False;
	Fname = False;
	Fsti = False;
	Fspec = False;
	Fmid = False;
	case = 0;
       
          current_year_a = date_time_$format("^9999yc",clock(),"","");
	end init;

%page;
	

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

make_PNOTICE:
	proc (CASE);



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This internal procedure creates the ALM source macro and the corresponding object	*/
	/* segment for inclusion into the proper source and object archives as shown in		*/
	/* psp_info_. There are four cases depicted in this procedure. They are:		*/
	/*									*/
	/* 1) Both source and object are protected by single pnotices, and so only one PNOTICE	*/
	/* source segment needs to be created and compiled.				*/
	/*									*/
	/* 2) Source and object are protected by more than one pnotice (i.e. multiple		*/
	/* copyrights), but these are the same ones. So, again only one PNOTICE source is	*/
	/* required.								*/
	/*									*/
	/* 3) Source and object are protected by only one pnotice each, but these pnotices are	*/
	/* different (i.e. source ->Trade Secret and object -> Copyright). This requires that	*/
	/* two PNOTICE source segments be created, since the notices in each are different. In	*/
	/* this case, the PNOTICE source destined for the object archive is created first,	*/
	/* compiled, and then the source is deleted. Then, the PNOTICE source destined for the	*/
	/* source archive is created, but not compiled.					*/
	/*									*/
	/* 4) Source and object are protected by multiple pnotices, and these are not identical.	*/
	/* So, again multiple PNOTICE segments must be created as outlined above in (3).	*/
	/*									*/
	/* A second temporary segment has been set up to hold the pnotice			*/
	/* with the current date inputted in place of the <yr> deliminator.			*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

dcl CASE			          fixed bin;
	

	goto PNOTICE (CASE);

PNOTICE(1):					/* one PNOTICE source req'd and not 		*/
						/* multiple notices				*/

	Piocb = null;
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
	call ioa_ ("Creating ^a>PNOTICE_^a.alm.", rtrim(working_dir), prod);
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", source_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	if substr (prod_source_pnotice(1), 1, 8) = "default." then
						/* if it is a default copyright...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultC then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current date			*/
		end;
	     end;
	else if substr (prod_source_pnotice(1), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultTS then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		pn = pn || "          acc       " || """" || temp || """" || NL;
		end;
	     end;
						/* otherwise, look for a matching pnotice...	*/
	else do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).primary_name = prod_source_pnotice(1) then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current date			*/
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + source_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	call ioa_ ("Creating ^a>PNOTICE_^a.", rtrim(working_dir), prod);
	call alm (rtrim(working_dir) || ">PNOTICE_" || prod);
	return;

PNOTICE(2):					/* one PNOTICE source, multiple pnotices	*/
	

	Piocb = null;
	working_dir = get_wdir_ ();
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
	call ioa_ ("Creating ^a>PNOTICE_^a.alm.", rtrim(working_dir), prod);
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", source_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	do Idx = 1 to source_pnotices;
						/* this time, there are multiple pnotices, so	*/
						/* they must all be processed.		*/
	     if substr (prod_source_pnotice(Idx), 1, 8) = "default." then
						/* if it is a default copyright...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultC then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     end;
		end;
	     else if substr (prod_source_pnotice(Idx), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultTS then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		     pn = pn || "          acc       " || """" || temp || """" || NL;
						/* add it to the list of pnotices.		*/
		     end;
		end;
						/* otherwise, look for a matching pnotice...	*/
	     else do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).primary_name = prod_source_pnotice(Idx) then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     

		     end;
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + source_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	call ioa_ ("Creating ^a>PNOTICE_^a.", rtrim(working_dir), prod);
	call alm (rtrim(working_dir) || ">PNOTICE_" || prod);
	return;

PNOTICE(3):					/* two PNOTICE source segs, single pnotices	*/
	

	Piocb = null;
	working_dir = get_wdir_ ();
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
						/* create the source PNOTICE for object 	*/
						/* archive first, compile it, and then delete it	*/
						/*  before going to work on the PNOTICE for the	*/
						/*  source archive.				*/
	call ioa_ ("Multiple PNOTICE segs required. Object will be done first.");
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", object_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	if substr (prod_object_pnotice(1), 1, 8) = "default." then
						/* if it is a default copyright...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultC then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current_date			*/
		end;
	     end;
	else if substr (prod_object_pnotice(1), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultTS then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		pn = pn || "          acc       " || """" || temp || """" || NL;
						/* add it to the list of pnotices.		*/
		end;
	     end;
						/* otherwise, look for a matching pnotice...	*/
	else do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).primary_name = prod_object_pnotice(1) then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current date			*/
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + object_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	call ioa_ ("Creating ^a>PNOTICE_^a.", rtrim(working_dir), prod);
	call alm (rtrim(working_dir) || ">PNOTICE_" || prod);
	call delete_$path (working_dir, "PNOTICE_" || rtrim(prod) || ".alm", "100100"b, ME, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Deleting PNOTICE source for the object archive.");
						/* now create PNOTICE for the source archive.	*/
	Piocb = null;
	Ltotal = 0;				/* don't use anything from the object PNOTICE.	*/
	pn = "";					/* ditto					*/
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
	call ioa_ ("Creating ^a>PNOTICE_^a.alm.", rtrim(working_dir), prod);
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", source_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	if substr (prod_source_pnotice(1), 1, 8) = "default." then
						/* if it is a default copyright...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultC then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current date			*/
		end;
	     end;
	else if substr (prod_source_pnotice(1), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
	     do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).defaultTS then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		pn = pn || "          acc       " || """" || temp || """" || NL;
						/* add it to the list of pnotices.		*/
		end;
	     end;
						/* otherwise, look for a matching pnotice...	*/
	else do Idx2 = 1 to pnotice_paths.Ntemplates;
	     if pnotice_paths.templates(Idx2).primary_name = prod_source_pnotice(1) then do;
		Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                    call get_year;                          /*put in current date			*/
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + source_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	return;

PNOTICE(4):					/* two PNOTICE source segs, multiple pnotices	*/
	

	Piocb = null;
	working_dir = get_wdir_ ();
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
						/* create the source PNOTICE for object archive 	*/
						/* first, compile it, and then delete it before 	*/
						/* going to work on the PNOTICE for the source	*/
						/*  archive.				*/
	call ioa_ ("Multiple PNOTICE segs required. Object will be done first.");
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", object_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	do Idx = 1 to object_pnotices;
						/* this time, there are multiple pnotices, so	*/
						/* they must all be processed.		*/
	     if substr (prod_object_pnotice(Idx), 1, 8) = "default." then
						/* if it is a default copyright...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultC then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     end;
		end;
	     else if substr (prod_object_pnotice(Idx), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultTS then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		     pn = pn || "          acc       " || """" || temp || """" || NL;
						/* add it to the list of pnotices.		*/
		     end;
		end;
						/* otherwise, look for a matching pnotice...	*/
	     else do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).primary_name = prod_object_pnotice(Idx) then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     end;
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + object_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	call ioa_ ("Creating ^a>PNOTICE_^a.", rtrim(working_dir), prod);
	call alm (rtrim(working_dir) || ">PNOTICE_" || prod);

	call delete_$path (working_dir, "PNOTICE_" || rtrim(prod) || ".alm", "100100"b, ME, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Deleting PNOTICE source for the object archive.");
						/* now create PNOTICE for the source archive.	*/
	Piocb = null;
	Ltotal = 0;				/* don't use anything from the object PNOTICE.	*/
	pn = "";					/* ditto					*/
	call iox_$attach_ioname (ME, Piocb, "vfile_ " 
	     || rtrim(working_dir) || ">" || "PNOTICE_" 
	     || rtrim(prod) || ".alm", code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Attaching PNOTICE segment.");
	     return;
	     end;
	call iox_$open (Piocb, 2, "0"b, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Opening PNOTICE seg switch for output.");
	     return;
	     end;
	call ioa_ ("Creating ^a>PNOTICE_^a.alm.", rtrim(working_dir), prod);
	call ioa_$ioa_switch (Piocb, "^-dec^-1^3-""version 1 structure");
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""no. of pnotices", source_pnotices);
	call ioa_$ioa_switch (Piocb, "^-dec^-3^3-""no. of STIs");
						/* this may change eventually			*/
	do Idx = 1 to source_pnotices;		/* there may also be multiple pnotices here.	*/
	     if substr (prod_source_pnotice(Idx), 1, 8) = "default." then
						/* if it is a default copyright...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultC then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     end;
		end;
	     else if substr (prod_source_pnotice(Idx), 1, 20) = "default_trade_secret" then
						/* if it is a default TS pnotice...		*/
		do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).defaultTS then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off			*/
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
		     pn = pn || "          acc       " || """" || temp || """" || NL;
						/* add it to the list of pnotices.		*/
		     end;
		end;
						/* otherwise, look for a matching pnotice...	*/
	     else do Idx2 = 1 to pnotice_paths.Ntemplates;
		if pnotice_paths.templates(Idx2).primary_name = prod_source_pnotice(Idx) then do;
		     Ltotal = Ltotal + pnotice_paths.templates(Idx2).Ltemplate - 1;
						/* leave the new line off the lgth		*/
		     Ltemp = pnotice_paths.templates(Idx2).Ltemplate - 1;
		     Ptemp = pnotice_paths.templates(Idx2).Ptemplate;
                         call get_year;                     /*put in current date			*/
		     end;
		end;
	     end;
	call ioa_$ioa_switch (Piocb, "^-dec^-^d^3-""lgth of all pnotices + no. of pnotices", Ltotal + source_pnotices);
	call ioa_$ioa_switch (Piocb, "^a", pn);		/* insert all pnotices			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", prod_sti);
						/* STI for source code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "2" || substr(prod_sti, 3));
						/* STI for object code			*/
	call ioa_$ioa_switch (Piocb, "^-aci^-""^a""", substr(prod_sti, 1, 1) || "3" || substr(prod_sti, 3));
						/* STI for executable code			*/
	call ioa_$ioa_switch (Piocb, "^-end");
	call iox_$close (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Closing PNOTICE switch.");
	call iox_$detach_iocb (Piocb, code);
	if code ^= 0 then
	     call com_err_ (code, ME, "Detaching PNOTICE switch.");
						/* finished with source segment now		*/
	

	return;


get_year: 
  proc;

  dcl temp2                    char(Ltemp);
  
  Iyr = index(Ptemp->temp,"<yr>");
  if Iyr = 0 then
    pn = pn || "          acc       " || """" || temp || """" || NL;
  else do;
    temp2 = Ptemp->temp;
    substr(temp2,Iyr,4) = current_year_a;
    pn = pn || "          acc       " || """" || temp2 || """" || NL;
    end;
 return;
 end get_year;


end make_PNOTICE;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

archive_PNOTICE:
	proc (source_dir, object_dir);


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This internal procedure provides the capability for appending or replacing the	*/
	/* PNOTICE segments in both source and object archives. In order to do so, the archive	*/
	/* command itself is called....which may be questionable....but it was in the specs, so	*/
	/* it was done.								*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl source_dir	        char(*),
    object_dir	        char(*);
	

S_ARCHIVE:
	component_name = "PNOTICE_" || rtrim(prod) || ".alm";
	if Fspec then do;				/* if "-special" has been used		*/
	     this_is_source_archive = True;
	     call check_acl (Ps_archive, sdir, sentry, Fmust_reset_source);
	     goto S_INFO;				/* archive is already known			*/
	     end;
	call hcs_$initiate_count (source_dir, prod_source_ename, "", sbit_count, 0, Ps_archive, code);
	if Ps_archive = null then do;
	     call com_err_ (code, ME, "Initiating source archive - Procedure terminated.");
	     return;
	     end;
S_INFO:	call archive_$get_component_info (Ps_archive, sbit_count, component_name, addr(ACI), code);
	if code = error_table_$no_component then
	     goto NO_S_COMPONENT;
	else if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Getting source archive component info, PNOTICE not appended.");
	     return;
	     end;
	else do;
	     call ioa_ ("Replacing ^a in ^a in ^a.", component_name, prod_source_ename, source_dir);
	     call archive ("rd", rtrim(source_dir) || ">" || rtrim(prod_source_ename),
	       rtrim(working_dir) || ">" || rtrim(component_name));
						/* Replace and Delete			*/
	     goto O_ARCHIVE;
	     end;
	
NO_S_COMPONENT:
	call ioa_ ("Appending ^a to ^a in ^a.", component_name, prod_source_ename, source_dir);
	call archive ("ad", rtrim(source_dir) || ">" || rtrim(prod_source_ename),
	  rtrim(working_dir) || ">" || rtrim(component_name));
						/* Append and Delete			*/
	

O_ARCHIVE:
	component_name = rtrim("PNOTICE_" || rtrim(prod));
	if Fspec then do;
	     this_is_object_archive = True;
	     call check_acl (Po_archive, odir, oentry, Fmust_reset_object);
	     goto O_INFO;
	     end;
	call hcs_$initiate_count (object_dir, prod_object_ename, "", obit_count, 0, Po_archive, code);
	if Po_archive = null then do;
	     call com_err_ (code, ME, "Initiating object archive - Procedure terminated.");
	     return;
	     end;
O_INFO:	call archive_$get_component_info (Po_archive, obit_count, component_name, addr(ACI), code);
	if code = error_table_$no_component then
	     goto NO_O_COMPONENT;
	else if code ^= 0 then do;
	     call com_err_ (code, ME, "^/Getting object archive component info, PNOTICE not appended.");
	     return;
	     end;
	else do;
	     call ioa_ ("Replacing ^a in ^a in ^a.", component_name, prod_object_ename, object_dir);
	     call archive ("rd", rtrim(object_dir) || ">" || rtrim(prod_object_ename),
	       rtrim(working_dir) || ">" || rtrim(component_name));
						/* Replace and Delete			*/
	     goto END_ARCHIVE;
	     end;
NO_O_COMPONENT:
	call ioa_ ("Appending ^a to ^a in ^a.", component_name, prod_object_ename, object_dir);
	call archive ("ad", rtrim(object_dir) || ">" || rtrim(prod_object_ename),
	  rtrim(working_dir) || ">" || rtrim(component_name));
						/* Append and Delete			*/
	

END_ARCHIVE:
	return;
	end archive_PNOTICE;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_acl:
	proc (Aptr, Adir, Aentry, Areset_acl);

	
dcl Aptr	              ptr,  			/* IN					*/
    Adir	              char(*),			/* IN					*/
    Aentry              char(*),			/* IN					*/
    Atype               bit(1),			/* IN, True = source and False = object		*/
    Areset_acl          bit(1);			/* OUT					*/
dcl Acode	              fixed bin (35),
    original_source_mode     bit(36) aligned,
    original_object_mode     bit(36) aligned;

dcl 1 acle(1),					/* structure for the list_acl and		*/
						/* add_acl_entries calls			*/
      2 name		 char(32) aligned,
      2 mode		 bit(36) aligned,
      2 mbz		 bit(36) aligned,
      2 code		 fixed bin (35);

dcl 1 del_acl(1),					/* structure for the delete_acl_entries call	*/
      2 name		 char(32) aligned,
      2 code		 fixed bin (35);

dcl one_word			char(4) based,
    error_table_$user_not_found	fixed bin(35) ext static;

	on no_write_permission goto FORCE_ACL;
	Aptr -> one_word = Aptr -> one_word;		/* try to write the first word of the seg.	*/
	return;					/* no need to go further if it worked.		*/
	

FORCE_ACL:
	acle(1).name = get_group_id_ ();
	acle(1).mode = "0"b;
	acle(1).mbz = "0"b;
	acle(1).code = 0;
	call hcs_$list_acl (Adir, Aentry, null, null, addr(acle), 1, Acode);
	if acle(1).code ^= 0 then
	     if acle(1).code = error_table_$user_not_found then do;
						/* this user not in ACL			*/
		if this_is_source_archive then
		     user_on_source_acl = False;
		if this_is_object_archive then
		     user_on_object_acl = False;
		end;
	     else
		goto ERROR;
	else do;
	     if Acode ^= 0 then do;
		acle(1).code = Acode;
		goto ERROR;
		end;
	     if this_is_source_archive then do;
		user_on_source_acl = True;
		original_source_mode = acle(1).mode;	/* save current mode for restoring		*/
		end;
	     if this_is_object_archive then do;
		user_on_object_acl = True;
		original_object_mode = acle(1).mode;
		end;
	     end;
	acle(1).mode = "101"b;			/* we need rw access			*/
	acle(1).mbz = "0"b;
	acle(1).code = 0;
	call hcs_$add_acl_entries (Adir, Aentry, addr(acle), 1, Acode);
	if Acode ^= 0 then do;
	     call com_err_ (Acode, ME, "
Unable to force write access for ^a to ^a>^a.", acle(1).name, Adir, Aentry);
	     goto CLEAN;
	     end;
	Areset_acl = True;				/* some resetting will be required		*/
	return;
ERROR:	call com_err_ (acle(1).code, ME, "
When listing ^a's access to ^a>^a", acle(1).name, Adir, Aentry);
	goto CLEAN;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


check_acl$reset_acl:
	entry (Aptr, Adir, Aentry, Atype, Areset_acl);

	acle(1).name = get_group_id_ ();		/* this proc has its own stack frame, so don't	*/
						/* rely on earlier name being there...		*/
	if Areset_acl then do;			/* we must restore old mode			*/
	     if Atype = True then
		acle(1).mode = original_source_mode;
	     else
		acle(1).mode = original_object_mode;
	     acle(1).mbz = "0"b;
	     acle(1).code = 0;
	     call hcs_$add_acl_entries (Adir, Aentry, addr(acle), 1, Acode);
	     if acle(1).code ^= 0 then do;
		call com_err_ (Acode, ME, "
Restoring access for ^a to ^a>^a.", acle(1).name, Adir, Aentry);
		return;
		end;
	     end;
	else do;
	     del_acl(1).name = acle(1).name;
	     del_acl(1).code = 0;
	     call hcs_$delete_acl_entries (Adir, Aentry, addr(del_acl), 1, Acode);
	     if Acode ^= 0 then
		call com_err_ (Acode, ME, "
Removing access for ^a to ^a>^a.", del_acl(1).name, Adir, Aentry);
	     return;
	     end;
	return;

	end check_acl;

%page;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


check_multiple_pnotices:
	proc returns (bit (1));

dcl Idx1	           fixed bin,
    Idx2	           fixed bin,
    value	           bit (1),
    TS	           bit (1),
    CP	           bit (1);

	value = True;				/* assume things are OK			*/
	TS = False;
	CP = False;
	do Idx = 1 to source_pnotices;
	     if after(prod_source_pnotice(Idx), ".") = "trade_secret.pnotice" then
		TS = True;
	     else
		CP = True;
	     do Idx1 = 1 to source_pnotices;
		do Idx2 = Idx1 + 1 to source_pnotices;
		     if prod_source_pnotice(Idx1) = prod_source_pnotice(Idx2) then
			call ioa_ ("Error in psp_info_ for ^a: Duplicate source notices.", prod);
		     end;
		end;
	     end;
	if CP & TS then do;
	     call ioa_ ("Error in psp_info_ for ^a: mixed copyright and Trade Secret for source.", prod);
	     value = False;
	     end;
						/* now check object too			*/
	TS = False;
	CP = False;
	do Idx = 1 to object_pnotices;
	     if after(prod_object_pnotice(Idx), ".") = "trade_secret.pnotice" then
		TS = True;
	     else
		CP = True;
	     do Idx1 = 1 to object_pnotices;
		do Idx2 = Idx1 + 1 to object_pnotices;
		     if prod_object_pnotice(Idx1) = prod_object_pnotice(Idx2) then
			call ioa_ ("Error in psp_info_ for ^a: duplicate object notices.", prod);
		     end;
		end;
	     end;
	if CP & TS then do;
	     call ioa_ ("Error in psp_info_ for ^a: mixed copyright and Trade Secret for object.", prod);
	     value = False;
	     end;
	

	return (value);
	end check_multiple_pnotices;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


get_PNOTICE_info:
	proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This internal procedure is used only when the "-special" control argument has been	*/
	/* specified. A user of this command must have good reason to use this argument because	*/
	/* it basically over-rides psp_info_, and in most cases, ignores it. The presumed major	*/
	/* use of this functionality would be to create PNOTICEs for pre-release software or	*/
	/* RPQ'd software. It is presumed that the user has proper legal and other documentation	*/
	/* necessary to correctly protect and identify the software in question.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
dcl product_known	     bit(1),
    prodno	     fixed bin;
	

	call ioa_ ("Type ""?"" for more info on any question.");
	call ioa_ ("Type ""exit"" at any time to exit prematurely.");
ASK_PROD: call command_query_ (addr(query_info), answer, ME, "-> Generic name? ");
	if answer = "exit" then
	     goto CLEAN;
	if answer = "?" then do;
	     call ioa_ ("Generic name (<= 20 chars).
	     ^/A descriptive short name for the software module(s) to be protected.");
	     goto ASK_PROD;
	     end;
	else do;
	     call check_entryname_ ("PNOTICE_" || answer || ".alm", code);
						/* check the source form of the name		*/
	     if code ^= 0 then do;			/* if its bad, complain			*/
		call com_err_ (code, ME, "
Your answer would form an illegal name:^/PNOTICE_^a.alm", answer);
		goto ASK_PROD;
		end;
	     else
		prod = answer;			/* else accept it				*/
	     end;
	do prodno = 1 to product.prod_number while (prod ^= product.num(prodno).prod_name);
						/* find out if it is a known product		*/
	     end;
	if prodno > product.prod_number then
	     product_known = False;			/* it is not known				*/
	else product_known = True;			/* it IS known				*/
	if product_known & product.num(prodno).prod_use(1) ^= "" then do;
	     call ioa_ ("Multiple products found in psp_info_.
                ^/Please use this command for each product.");
						/* This msg is produced if the user tries this	*/
						/* command and finds only a "Use: " statement	*/
	     

	     goto CLEAN;
	     end;
	if product_known then
	     call ioa_ ("^a is in psp_info_, type ""pr"" to see the STI, else input new STI.", prod);
ASK_STI:	call command_query_ (addr(query_info), answer, ME, "-> STI? ");
	if answer = "exit" then
	     goto CLEAN;
	if answer = "?" then do;
	     call ioa_ ("STI (12 chars).
Software Technical ID. May be blank for non-product software.
Type CR for blank STI.^/Type ""..help sti.gi"" for more information.");
	     goto ASK_STI;
	     end;
	else if answer = "pr" then do;
	     if product_known then
		call ioa_ ("STI for ^a:^-^a", prod, product.num(prodno).prod_STI);
	     else
		call ioa_ ("^a is not in psp_info_, there is no STI.", prod);
	     goto ASK_STI;
	     end;
	else if product_known then do;			/* there is such a product		*/
	     if answer = "" then do;
		call ioa_ ("Error - ^a is in psp_info_. You must supply an updated STI.", prod);
		call ioa_ ("Type ""pr"" to see STI, type ""..help sti.gi"" for more information.");
		goto ASK_STI;
		end;
	     else if length(answer) ^= 12 then do;
		call ioa_ ("Error - the STI must be 12 characters long.");
		goto ASK_STI;
		end;
	     prod_sti = answer;
	     if ^parse_pnotice_info_$validate_sti (prod_sti) then do;
		call ioa_ ("Error - invalid STI: ^a", prod_sti);
		goto ASK_STI;
		end;
	     end;
	else do;					/* there is no product in psp_info_		*/
	     if answer = "" then do;
		prod_sti = answer;			/* accept blank for non-products		*/
		goto ASK_PNOTICE;
		end;

	     else if length(answer) ^= 12 then do;
		call ioa_ ("Error - the STI must be 12 characters long.^/Type ""..help sti.gi"" for more information.");
		goto ASK_STI;
		end;
	     prod_sti = answer;
	     if ^parse_pnotice_info_$validate_sti (prod_sti) then do;
		call ioa_ ("Error - Invalid Software Technical Identifier.");
		goto ASK_STI;
		end;
	     end;
	answer = "";				/* avoid possible problems			*/
ASK_PNOTICE:
	if product_known then do;			/* if there is already a product, ask if they	*/
						/* should be included or not.			*/
	     call ioa_ ("^a is in psp_info_.^/Type ""ls"" for list of notice names in psp_info_ for ^a.", prod, prod);
	     call ioa_ ("Type ""lpn"" to see all available notice names.
Type ""yes"" to include notices already in psp_info_, or ""no"" to input your own notices.");
ASK1:	     call command_query_ (addr(query_info), answer, ME,
	        "Include the notices from psp_info_? Type ""yes"" or ""no"".");
	     if answer = "exit" then			/* just want out				*/
		goto CLEAN;
	     if answer = "yes" then do;		/* get names from psp_info_			*/
                    Idx = 0;                                /*Initialize index to 0			*/
		do Idx3 = 1 to hbound (product.num.source_C, 2);
		     if product.num(prodno).source_C(Idx3) = "" then;
		     else do;
			prod_source_pnotice(Idx3) = product.num(prodno).source_C(Idx3);
                              Idx1 = check_name(prod_source_pnotice(Idx3));
                              if Idx1 > pnotice_paths.Ntemplates then do;
                                code = error_table_$name_not_found;
                                call com_err_ (code, ME, "^/Invalid psp_info_ name - ^a.", prod_source_pnotice(Idx3));
                                goto CLEAN;
                                end;
                              Idx = Idx + 1;
                              if Idx > 1 then
                                if ^templates_compatible(prod_source_pnotice) 
                                  then do; 
                                    call com_err_ (code, ME, "^a - ^/pnotice types not compatible", prod);
                                    goto CLEAN;
                                    end;
			source_pnotices = source_pnotices + 1;
			end;
		     end;
                    Idx = 0;                                /* Initialize index to 0			*/
		do Idx3 = 1 to hbound (product.num.object_C, 2);
		     if product.num(prodno).object_C(Idx3) = "" then;
		     else do;
			prod_object_pnotice(Idx3) = product.num(prodno).object_C(Idx3);
                              Idx1 = check_name(prod_object_pnotice(Idx3));
                              if Idx1 > pnotice_paths.Ntemplates then do;
                                code = error_table_$name_not_found;
                                call com_err_ (code, ME, "^/Invalid psp_info_ name - ^a.", prod_object_pnotice(Idx3));
                                goto CLEAN;
                                end;
                              Idx = Idx + 1;
                              if Idx > 1  then
                                if ^templates_compatible(prod_object_pnotice)
                                  then do; 
                                    call com_err_ (code, ME, "^a - ^/pnotice types not compatible", prod);
                                    goto CLEAN;
                                    end;
			object_pnotices = object_pnotices + 1;
			end;
		     end;
		goto GOT_PSP;			/* got'em					*/
		end;

	     else if answer = "lpn" then do;
						/* tell me what's available			*/
		call list_pnotice_names ();
		goto ASK1;
		end;
	     else if answer = "ls" then do;		/* tell me what's in psp_info_		*/
		call ioa_ ("Source notices in psp_info_ for ^a:", prod);
		do Idx = 1 to hbound(product.num.source_C, 2) while (product.num(prodno).source_C(Idx) ^= "");
		     call ioa_ ("^3x^a", product.num(prodno).source_C(Idx));
		     end;
		call ioa_ ("Object notices in psp_info_ for ^a:", prod);
		do Idx = 1 to hbound(product.num.object_C, 2) while (product.num(prodno).object_C(Idx) ^= "");
		     call ioa_ ("^3x^a", product.num(prodno).object_C(Idx));
		     end;
		goto ASK1;
		end;
	     else if answer = "no" then do;
		source_pnotices = 0;
		object_pnotices = 0;
		goto START_PN;
		end;
	     else do;
		call ioa_ ("Unrecognized answer - ^a", answer);
		goto ASK_PNOTICE;
		end;
GOT_PSP:	     call ioa_ ("Notices from psp_info_ have been included.");
	     call command_query_ (addr(query_info), answer, ME, "->Do you wish to input more? Type ""yes"" or ""no"":");
	     if answer = "exit" then
		goto CLEAN;
	     if answer = "yes" then do;
START_PN:		call ioa_ ("Input source pnotice names, type ""q"" when done.");
		Idx = 0;
GET_PN:		do Idx3 = source_pnotices to hbound(prod_source_pnotice, 1);
ASK_SNAME:	     call command_query_ (addr(query_info), answer, ME, "-> Source pnotice name? ");
		     if answer = "exit" then
			goto CLEAN;
		     else if answer = "q" then do;
			if source_pnotices = 0 then do;
			     call ioa_ ("There must be at least one source notice.");
			     goto ASK_SNAME;
			     end;
			else
			     goto BEGIN_ONAME;
			end;
		     else if answer = "?" then do;
			call ioa_ ("Source pnotice name (<= 24 chars).
^/Primary name of a pnotice template, without the "".pnotice"" suffix.");
			goto ASK_SNAME;
			end;
		     else if answer = "lpn" then do;
			call list_pnotice_names ();
			goto ASK_SNAME;
			end;
		     else if index (answer, "pnotice") ^= 0 then do;
			call ioa_ ("Error - Type template primary name, without the ""pnotice"" suffix.");
			goto ASK_SNAME;
			end;
		     else do;
                              Idx2 = check_name(answer);
			if Idx2 > pnotice_paths.Ntemplates then do;
			     code = error_table_$name_not_found;
			     call com_err_ (code, ME, "^/The template was not found - ^a.", answer);
			     call ioa_ ("Type ""lpn"" for template names.");
			     goto ASK_SNAME;
			     end;
			Idx = Idx + 1;
			prod_source_pnotice(Isnotice + Idx) = 
                                templates(Idx2).primary_name;
						/* add this one to the list			*/
                              if Idx > 1 then
                                if ^templates_compatible(prod_source_pnotice)
                                  then do;
                                    call com_err_ (code, ME, "^a - ^/pnotice types not compatible", prod);
                                    goto ASK_SNAME;
                                    end;
			end;
		     source_pnotices = Idx;
		     end;
BEGIN_ONAME:	call ioa_ ("Input object pnotice names, type ""q"" when done.");
		Idx = 0;
		do Idx3 = object_pnotices to hbound(prod_object_pnotice, 1);
ASK_ONAME:	     call command_query_ (addr(query_info), answer, ME, "-> Object pnotice name? ");
		     if answer = "exit" then
			goto CLEAN;
		     if answer = "q" then do;
			if object_pnotices = 0 then do;
			     call ioa_ ("There must be at least one object notice.");
			     goto ASK_ONAME;
			     end;
			else
			     goto ASK_SARCHIVE;
			end;
		     else if answer = "?" then do;
			call ioa_ ("Object pnotice name (<= 24 chars).
			^/Primary name of a pnotice template, without the "".pnotice"" suffix.");
			goto ASK_ONAME;
			end;
		     else if answer = "lpn" then do;
			call list_pnotice_names ();
			goto ASK_ONAME;
			end;
		     else if index (answer, "pnotice") ^= 0 then do;
			call ioa_ ("Error - Type template primary name, without the ""pnotice"" suffix.");
			goto ASK_ONAME;
			end;
		     else do;
			Idx2 = check_name(answer);
			if Idx2 > pnotice_paths.Ntemplates then do;
			     code = error_table_$name_not_found;
			     call com_err_ (code, ME, "^/The template was not found - ^a.", answer);
			     call ioa_ ("^/Type ""lpn"" for template names.");
			     goto ASK_ONAME;
			     end;
			Idx = Idx + 1;
			prod_object_pnotice(Ionotice + Idx) = 
                                templates(Idx2).primary_name;
						/* add this one to the list			*/
                              if Idx > 1 then
                                if ^templates_compatible(prod_object_pnotice)
                                  then do;
                                    call com_err_ (code, ME, "^a - ^/pnotice types not compatible", prod);
                                    goto ASK_ONAME;
                                    end;			end;
		     object_pnotices = Idx;
		     end;
		end;
	     end;
	else do;					/* if there is no psp_info_ entry		*/
	     Idx = 0;
	     call ioa_ ("Input source pnotice names.
Type ""q"" when done.^/Type ""lpn"" to see all available notice names.");
	     do Idx3 = object_pnotices to hbound(prod_object_pnotice, 1);
ASK_SNAME_ALL:	call command_query_ (addr(query_info), answer, ME, "-> Source pnotice name? ");
		if answer = "exit" then
		     goto CLEAN;
		if answer = "?" then do;
		     call ioa_ ("Source pnotice name (<= 24 chars).
Primary name of a pnotice template, without the "".pnotice"" suffix.
Type ""lpn"" for available names. Type ""q"" when finished.");
		     goto ASK_SNAME_ALL;
		     end;
		else if answer = "lpn" then do;
		     call list_pnotice_names ();
		     goto ASK_SNAME_ALL;
		     end;
		else if index (answer, "pnotice") ^= 0 then do;
		     call ioa_ ("Error - Type template primary name, without the ""pnotice"" suffix.");
		     goto ASK_SNAME_ALL;
		     end;
		else if answer = "" then do;
		     call ioa_ ("Error - A pnotice primary name is required.");
		     goto ASK_SNAME_ALL;
		     end;
		else if answer = "q" & source_pnotices > 0 then
		     goto BEGIN_ONAME_ALL;
		else do;
		     Idx2 = check_name(answer);
		     if Idx2 > pnotice_paths.Ntemplates then do;
			code = error_table_$name_not_found;
			call com_err_ (code, ME, "^/The template was not found - ^a.", answer);
			call ioa_ ("Type ""lpn"" for available names.");
			goto ASK_SNAME_ALL;
			end;
		     Idx = Idx + 1;
		     prod_source_pnotice(Idx) = 
                           templates(Idx2).primary_name;
						/* add this one to the list			*/
                         if Idx > 1 then
                           if ^templates_compatible(prod_source_pnotice) then
                           goto ASK_SNAME_ALL;
		     end;
		source_pnotices = Idx;
		end;
BEGIN_ONAME_ALL:
	     Idx = 0;
	     call ioa_ ("Input object pnotice names. Type ""q"" when done.");
	     do Idx3 = object_pnotices to hbound(prod_object_pnotice, 1);
ASK_ONAME_ALL:	call command_query_ (addr(query_info), answer, ME, "-> Object pnotice name? ");
		if answer = "exit" then
		     goto CLEAN;
		if answer = "?" then do;
		     call ioa_ ("Object pnotice name (<= 24 chars).
Primary name of a pnotice template, without the "".pnotice"" suffix. 
Type ""lpn"" for available names. Type ""q"" when finished.");
		     goto ASK_ONAME_ALL;
		     end;
		else if answer = "lpn" then do;
		     call list_pnotice_names ();
		     goto ASK_ONAME_ALL;
		     end;
		else if index (answer, "pnotice") ^= 0 then do;

		     call ioa_ ("Error - Type template primary name, without the ""pnotice"" suffix.");
		     goto ASK_ONAME_ALL;
		     end;
		else if answer = "" then do;
		     call ioa_ ("Error - A pnotice primary name is required.");
		     goto ASK_ONAME_ALL;
		     end;
		else if answer = "q" & object_pnotices > 0 then
		     goto ASK_SARCHIVE;
		else do;
		     Idx2 = check_name(answer);
		     if Idx2 > pnotice_paths.Ntemplates then do;
			code = error_table_$name_not_found;
			call com_err_ (code, ME, "^/The template was not found - ^a.", answer);
			call ioa_ ("^/Type ""lpn"" for available names.");
			goto ASK_ONAME_ALL;
			end;
		     Idx = Idx + 1;
		     prod_object_pnotice(Idx) = 
                           templates(Idx2).primary_name;
						/* add this one to the list			*/
                         if Idx > 1 then
                           if ^templates_compatible(prod_object_pnotice) then
                           goto ASK_ONAME_ALL;              /*templates in prod_object_pnotice not compatible */
						/* - reinput correctly			*/
		     end;
		object_pnotices = Idx;
		end;
	     end;
ASK_SARCHIVE:
	call command_query_ (addr(query_info), answer, ME, "-> Pathname of source archive? ");
	if answer = "exit" then
	     goto CLEAN;
	if answer = "?" then do;
	     call ioa_ ("Archive pathname of source archive.
^/Example: >exl>new_dir>source>bound_new_.s");
	     goto ASK_SARCHIVE;
	     end;
	if index(answer, ".archive") = 0 then
	     path = answer || ".archive";
	else
	     path = answer;
	call expand_pathname_ (path, sdir, sentry, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a.", path);
	     goto CLEAN;
	     end;
	call hcs_$initiate_count (sdir, sentry, "", sbit_count, 0, Ps_archive, code);
	if Ps_archive = null then do;
	     if code = error_table_$noentry then do;
		call com_err_ (code, ME, "^a.", path);
		goto ASK_SARCHIVE;
		end;
	     else do;
		call com_err_ (code, ME, "^a. ^/Terminating this procedure.", path);
		goto CLEAN;
		end;
	     end;
	if ^Fspec then
	     call check_archive (sdir, sentry, Ps_archive);
	prod_source_ename = sentry;			/* save entry name				*/
	

ASK_OARCHIVE:
	call command_query_ (addr(query_info), answer, ME, "-> Pathname of object archive? ");
	if answer = "exit" then
	     goto CLEAN;
	if answer = "?" then do;
	     call ioa_ ("Archive pathname of object archive.
^/Example: >exl>new_dir>object>bound_new_");
	     goto ASK_OARCHIVE;
	     end;
	if index(answer, ".archive") = 0 then
	     path = answer || ".archive";
	else
	     path = answer;
	call expand_pathname_ (path, odir, oentry, code);
	if code ^= 0 then do;
	     call com_err_ (code, ME, "^a.", path);
	     goto CLEAN;
	     end;
	call hcs_$initiate_count (odir, oentry, "", obit_count, 0, Po_archive, code);
          if Po_archive = Ps_archive then do;               /*cannot use same archive for both source and 	*/
						/* object pnotices				*/
            call ioa_ ("The same archive may not be used for both source and object pnotices.");
            call com_err_ (code, ME, "^a. ^/Terminating this procedure.",path);
            goto CLEAN;
            end;
	if Po_archive = null then do;
	     if code = error_table_$noentry then do;
		call com_err_ (code, ME, "^a.", path);
		goto ASK_OARCHIVE;
		end;
	     else do;
		call com_err_ (code, ME, "^a. ^/Terminating this procedure.", path);
		goto CLEAN;
		end;
	     end;
	if ^Fspec then
	     call check_archive (odir, oentry, Po_archive);
	prod_object_ename = oentry;			/* save entry name				*/
	

 
              

	end get_PNOTICE_info;

%page;
check_template_name:
  proc;
check_name:
          entry(name_in) returns (fixed bin);

dcl name_in                    char(*) var,
    count_of		 fixed bin;
	
Fdcopy_right = False;
Fdtrade_secret = False;

if name_in = "-trade_secret" | name_in = "-dts" then
  Fdtrade_secret = True;

if name_in = "-default_copyright" | name_in = "-dc" then
  Fdcopy_right = True;

if Ftrade_secret then do count_of = 1 to pnotice_paths.Ntemplates while (^pnotice_paths.templates(count_of).defaultTS);
   end;

if Fdcopy_right then do count_of = 1 to pnotice_paths.Ntemplates while (^pnotice_paths.templates(count_of).defaultC);
  end;      

if ^Fdcopy_right & ^Fdtrade_secret then
  do count_of = 1 to pnotice_paths.Ntemplates while (name_in ^= templates(count_of).primary_name);
  end;

return(count_of);

end check_template_name;
%page;
templates_compatible:
  proc(name_in) returns(bit(1));
  
  dcl name_in (10)             char(32) varying,
      i			 fixed bin(24);
  
  Ftrade_secret = False;
  Fdtrade_secret = False;
  Fpublic_domain = False;
  Fcopy_right = False;
  Fdcopy_right = False;
  
  do i = 1 to Idx by 1;
     if name_in(i) = "-default_trade_secret" | name_in(i) = "-dts" then
       Fdtrade_secret = True;
     else
       if name_in(i) = "-default_copy_right" | name_in(i) = "-dc" then
          Fdcopy_right = True;
       else
          if name_in(i) = "public_domain" then
            Fpublic_domain = True;
          else
            if reverse(before(reverse(name_in(i)),".")) = "trade_secret" then
              Ftrade_secret = True;
	  else
              Fcopy_right = True;
  end;

  if (Fcopy_right | Fdcopy_right | Ftrade_secret| Fdtrade_secret) &
    Fpublic_domain then do;
    call ioa_ ("A public domain pnotice can only exist by itself");
    Idx = Idx - 1;
    return(False);
    end;
  if (Fcopy_right | Fdcopy_right | Fpublic_domain) & (Ftrade_secret |
    Fdtrade_secret) then do;
     call ioa_("Trade secret pnotices can only exist by themselves");
     return(False);
     end;
  
  return(True);
  
end templates_compatible;
%page;
%include archive_component_info;
%page;
%include pnotice_paths;
%page;
%include software_pnotice_info_;
%page;
%include terminate_file;

	end generate_pnotice;




		    hcom.pl1                        11/12/86  1543.0rew 11/12/86  1527.0      391968



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     This is the driver program for the history
     comment programs that provide tracking of software changes and ensure that
     the format and placement of software change notices are standard.
  2) change(86-04-17,LJAdams), approve(86-04-17,MCR7386),
     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
     When using an active function, if there is an invalid argument given set
     return string to false.  If there was an invalid argument do not take
     operand of argument as a comment spec for ADD, CHECK, or INSTALL.
  3) change(86-05-05,LJAdams), approve(86-05-05,MCR7386),
     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
     Added ability to fill or not fill comments using the -fill or -no_fill
     arguments.
  4) change(86-09-02,LJAdams), approve(86-09-02,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Reformatted error messages to be consistent.
     
     hcom get with no fields specified was not returning all fields available.
                                                   END HISTORY COMMENTS */

history_comment:
hcom:
     proc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* This command is used to insert history_comments into source_programs.        	*/
/* The command uses the pnotice_language_info_ database (created by CDS) to obtain        */
/* information on the source language segment.			          	*/
/*									*/
/* Status:								*/
/* 0) Created	   June 1985 by LJ Adams					*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/*  A U T O M A T I C  */
	dcl     code		 fixed bin (35),
	        control		 fixed bin,
	        current_date	 char (8),
	        error_msg		 char (100) varying,
	        (i, j)		 fixed bin (24),
	        operation		 fixed bin,	/* used to indicate if operation has been set	*/
	        Sactive_function_err	 bit (1),
	        Sfill_arg		 bit (1),
	        user_name		 char (24),
	        valid		 bit (1) init ("0"b);


/*  E X T E R N A L   E N T R I E S  */
	dcl     cu_$generate_call	 entry (entry, ptr),
	        cv_entry_		 entry (char (*), ptr, fixed bin (35)) returns (entry),
	        date_time_$format	 entry (char (*), fixed bin (71), char (*), char (*)) returns (char (250) var),
	        get_temp_segments_	 entry (char (*), (*) ptr, fixed bin (35)),
	        hcom_cfix_validate_	 entry (char (*) var, char (*) var, char (*) var, bit (1), char (*) var, char (*) var, char (100) var),
	        hcom_default_validate_ entry (char (*) var, char (*) var, char (*) var, bit (1), char (*) var, char (*) var, char (100) var),
	        hcom_site_validate_	 entry options (variable),
	        hcom_process_path_	 entry (ptr),
	        ioa_		 entry () options (variable),
	        release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)),
	        requote_string_	 entry (char (*)) returns (char (*)),
	        user_info_		 entry (char (*), char (*), char (*));

/*  I N T E R N A L   S T A T I C  */
	dcl     FALSE		 bit (1) int static options (constant) init ("0"b),
	        NL		 char (1) int static options (constant) init ("
"),
	        TRUE		 bit (1) int static options (constant) init ("1"b);

	dcl     ctl		 (9, 2) char (20) var int static options (constant) init (
				 "-summary", "-sm", /* control args that take an operand.		*/
				 "-approve", "-apv",
				 "-install", "-in",
				 "-validate", "-vdt",
				 "-critical_fix", "-cfix",
				 "-fill", "-fi",
				 "-no_fill", "-nfi",
				 "-original", "-orig",
				 "-field_names", "-fn");

/*  E X T E R N A L   S T A T I C  */
	dcl     (error_table_$active_function,
	        error_table_$bad_arg,
	        error_table_$badopt,
	        error_table_$bigarg,
	        error_table_$improper_data_format,
	        error_table_$inconsistent,
	        error_table_$noarg)	 fixed bin (35) ext static;

/*  B U I L T I N  */
	dcl     (addr, after, before, clock, codeptr, convert, hbound, index, lbound,
	        length, maxlength, null, rtrim, string, substr, verify)
				 builtin;

/*  C O N D I T I O N S  */
	dcl     (cleanup,
	        linkage_error)	 condition;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Initialize error routine and argument structure.				*/
/* 2) Find out how we were invoked (command/af).					*/
/* 3) Determine what operation is being performed.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	Pd = addr (auto_hcom_data);
	call check_error$init ();
	call init$args;
	call get_invocation_type (d.Saf);

	do while (get_arg () & d.ag.op.name = NOTSET);	/* get operation value     */
	     if index (arg, "-") = 1 then do;		/* control args that take  */
		     control = NOTSET;		/*   an operand	       */
		     do j = lbound (ctl, 2) to hbound (ctl, 2) while (control = NOTSET);
			do i = lbound (ctl, 1) to hbound (ctl, 1) while (control = NOTSET);
			     if arg = ctl (i, j) then control = i;
			     if i = hbound (ctl, 1) then /* -fn takes multiple ops  */
				if check_arg$field_name () then ;
				else /* other control args take */
				     if get_arg () then ; /*  exactly one operand.   */
			end;
		     end;				/* diagnose bad control    */
		end;				/*  args later.	       */
	     else do;
		     do j = lbound (oper, 2) to hbound (oper, 2) while (d.ag.op.name = NOTSET);
			do i = lbound (oper, 1) to hbound (oper, 1) while (d.ag.op.name = NOTSET);
			     if arg = oper (i, j) then d.ag.op.name = i;
			end;
		     end;
		     if d.ag.op.name = NOTSET then
			call check_error$fatal (error_table_$bad_arg, CALLER, "^3x^a is not a valid operation.^/^3xSyntax: ^[[^]hcom operation path {-control_args}^[]^]
^3xOperation: ^a^6(, ^a^),^/^3x^a^(, ^a^)", arg, d.Saf, d.Saf, oper (*, 1));
		end;
	end;
	if d.ag.op.name = NOTSET then
	     call check_error$fatal (error_table_$noarg, CALLER, "^3xAn operation must be given.^/^3xSyntax:    ^[[^]hcom operation path {-control_args}^[]^]
^3xOperation: ^a^6(, ^a^),^/^3x^a^(, ^a^)", d.Saf, d.Saf, oper (*, 1));

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Set argument defaults based upon the operation.				*/
/* 2) Check active function (af) invocations to be sure the specified operation is	*/
/*    allowed as an active function.  Set default af return value.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if d.ag.op.name = ADD then
	     d.ag.input.select.sm, d.ag.input.select.apv = INPUTxxx;

	if d.ag.op.name = CHECK then /* set defaults				*/
	     d.ag.ctl.errors = ^d.Saf;
	else if d.ag.op.name = INSTALL then do;
		d.ag.input.select.in = INPUTxxx;
		d.ag.ctl.errors = ^d.Saf;
	     end;

	if d.Saf then do;				/* active function				*/
		if d.ag.op.name = CHECK | d.ag.op.name = EXISTS |
		     d.ag.op.name = INSTALL | d.ag.op.name = COMPARE then
						/* set default return value			*/
		     call set_return_arg ("true");
		else if d.ag.op.name = GET then ;
		else call check_error$fatal (error_table_$active_function, CALLER, "^/^3x^a is not a valid active function operation.",
			oper (d.ag.op.name, 1));	/* diagnose operations which don't work as AF	*/
	     end;
	else do;					/* Some commands hold their true/false result	*/
		if d.ag.op.name = EXISTS then /* in an hcom-provided pseudo-return value.	*/
		     call set_return_arg ("true");	/* This result is then printed when all segs 	*/
	     end;					/* are processed.				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Scan arguments, and store control arg and operand values in the d.ag substructure.	*/
/*    a) since each control arg is accepted for several operations, control argument	*/
/*       matching and operand processing is done in a series of check_arg functions.	*/
/*       These functions return TRUE if the control arg was accepted, and FALSE		*/
/*       otherwise.  If TRUE and the control arg requires operands, then the check_arg	*/
/*       function has already processed the operands.				*/
/*    b) Noncontrol arguments are positional in order of appearance in the argument	*/
/*       list.  First comes the operation name, then the source pathname.  All remaining	*/
/*       noncontrol args are part of the comment specifier string.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	call reprocess_args (1);			/* Rescan the entire argument list.		*/
	operation = NOTSET;				/* Even though we know what the operation is, we	*/
						/*   must skip over the operation name in the	*/
						/*   arg list.  The operation variable determines */
						/*   whether or not we have already seen this name*/

	do while (get_arg ());
	     if index (arg, "-") = 1 then do;		/* process control args			*/
		     go to OP_CTL_ARGS (d.ag.op.name);

OP_CTL_ARGS (1):					/* ADD					*/
		     if check_arg$summary () then ;
		     else if check_arg$apv () then ;
		     else if check_arg$cfix () then ;
		     else if check_arg$install () then ;
		     else if check_arg$vdt () then ;
		     else if check_arg$fill () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (2):					/* ADD_FIELD				*/
		     if check_arg$apv () then ;
		     else if check_arg$cfix () then ;
		     else if check_arg$audit () then ;
		     else if check_arg$install () then ;
		     else if check_arg$vdt () then ;
		     else if check_arg$orig () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (3):					/* CHECK					*/
		     if check_arg$orig () then ;
		     else if check_arg$error () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (4):					/* COMPARE				*/
		     if check_arg$orig () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (5):					/* DISPLAY				*/
		     if check_arg$orig () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (6):					/* EXISTS					*/
		     if check_arg$orig () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (7):					/* FORMAT					*/
		     if check_arg$orig () then ;
		     else if check_arg$rnb () then ;
		     else if check_arg$vdt () then ;
		     else if check_arg$fill () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (8):					/* GET					*/
		     if check_arg$orig () then ;
		     else if check_arg$field_name () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (9):					/* INSTALL				*/
		     if check_arg$orig () then ;
		     else if check_arg$error () then ;
		     else if check_arg$apv () then ;
		     else if check_arg$cfix () then ;
		     else if check_arg$install_required () then ;
		     else if check_arg$vdt () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

OP_CTL_ARGS (10):					/* REPLACE_FIELD				*/
		     if check_arg$orig () then ;
		     else if check_arg$no_summary () then ;
		     else if check_arg$apv () then ;
		     else if check_arg$cfix () then ;
		     else if check_arg$audit () then ;
		     else if check_arg$install () then ;
		     else if check_arg$vdt () then ;
		     else if check_arg$fill () then ;
		     else call check_arg$ERROR;
		     goto END_OP_CTL_ARGS;

END_OP_CTL_ARGS:
		end;

	     else if operation = NOTSET then /* First positional arg is operation keyword.	*/
		operation = d.ag.op.name;

	     else if operation ^= NOTSET & d.ag.source.path = "" then
		d.ag.source.path = arg;		/* Second positional arg is the path name.        */

	     else if operation ^= NOTSET & d.ag.source.path ^= "" then do;
		     if d.ag.op.name = ADD | d.ag.op.name = CHECK | /* Third positional arg is a comment spec	*/
			d.ag.op.name = INSTALL then do;
			     if Sactive_function_err then
				;
			     else do;
				     call set_return_arg ("false");
				     call check_error (error_table_$bad_arg, CALLER, "^3x^a^/^3xA comment specifier is not valid for the ^a operation.",
					arg, oper (d.ag.op.name, 1));
				end;
			end;
		     else
			call get_com_spec ();
		end;
	end;					/* get_arg				*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Diagnose command when no source pathname is given.				*/
/* 2) Diagnose use of old/new/diff com_spec when -original not given.			*/
/* 3) Set operation type (modify source vs no-modify) based upon operation name.	*/
/* 4) Based upon type of operation, set default control argument values for unset	*/
/*    control arguments, for cases where defaults depend upon what related control args	*/
/*    WERE given by the user.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if d.ag.source.path = "" then /* missing pathname				*/
	     call check_error (error_table_$noarg, CALLER, "^/^3xPathname of a source program must be given.");

	if d.orig.path = "" then
	     if d.com_spec.selected.old | d.com_spec.selected.new | d.ag.op.name = COMPARE then
		call check_error (error_table_$inconsistent, CALLER, "^3x-original must be given with the old or new comment specifier, or the compare operation.");

	if d.ag.op.name = ADD | d.ag.op.name = ADD_FIELD | /* set MODIFY operations			*/
	     d.ag.op.name = FORMAT | d.ag.op.name = INSTALL |
	     d.ag.op.name = REPLACE_FIELD then
	     d.ag.op.type = MODIFY;
	else
	     d.ag.op.type = NO_MODIFY;

	if d.ag.op.name = ADD then do;		/* set default input control args		*/
		if d.ag.input.select.sm = NOxxx then
		     d.ag.input.select.sm = INPUTxxx;	/*   summary field is required for ADD op.	*/
	     end;
	else if d.ag.op.name = ADD_FIELD then do;
		if d.ag.input.select.sm = NOxxx & d.ag.input.select.apv = NOxxx &
		     d.ag.input.select.aud = NOxxx & d.ag.input.select.in = NOxxx then
		     d.ag.input.select.apv = INPUTxxx;
	     end;
	else if d.ag.op.name = GET then
	     if string (d.ag.output) = FALSE then do i = 1 to hbound (d.field_array, 1);
						/* if GET op and no flds specified return all flds*/
		     substr (string (d.ag.output), i, 1) = TRUE;
		     d.field_array (i) = i;
		end;
	     else if d.ag.op.name = REPLACE_FIELD then do;
		     if d.ag.input.select.sm = NOxxx & d.ag.input.select.apv = NOxxx &
			d.ag.input.select.aud = NOxxx & d.ag.input.select.in = NOxxx then
			call check_error (error_table_$noarg, CALLER, "^/^3xField input control arguments are required for the replace_field operation.");
		     if Sfill_arg then
			if d.ag.input.select.sm = INPUTxxx |
			     d.ag.input.select.sm = OPERANDxxx then ;
			else
			     call check_error (error_table_$bad_arg, CALLER, "^/^3xThe -fill/-no_fill arg can only be used if -sm or -ism is also specified.");
		end;

	if string (d.com_spec.selected) = FALSE & /* set default com_spec			*/
	     d.com_spec.Nrange = 0 then do;		/* values.				*/
		if d.ag.op.name = ADD_FIELD then do;
			d.com_spec.selected.unaud = (d.ag.input.select.aud >= OPERANDxxx);
			d.com_spec.selected.unapv = (d.ag.input.select.apv >= OPERANDxxx);
			d.com_spec.selected.unin = (d.ag.input.select.in >= OPERANDxxx);
			d.com_spec.selected.aud = (d.ag.input.select.aud = CLEARxxx);
			d.com_spec.selected.apv = (d.ag.input.select.apv = CLEARxxx);
			d.com_spec.selected.in = (d.ag.input.select.in = CLEARxxx);
		     end;
		else if d.ag.op.name = CHECK then do;
			if d.ag.orig.path ^= "" then
			     d.com_spec.selected.new = TRUE;
			else
			     d.com_spec.selected.icpt = TRUE;
		     end;
		else if d.ag.op.name = DISPLAY then do;
			if d.ag.orig.path ^= "" then
			     d.com_spec.selected.new = TRUE;
			else
			     d.com_spec.selected.all = TRUE;
		     end;
		else if d.ag.op.name = EXISTS | d.ag.op.name = FORMAT |
		     d.ag.op.name = INSTALL then
		     d.com_spec.selected.all = TRUE;
		else if d.ag.op.name = GET | d.ag.op.name = REPLACE_FIELD then
		     call check_error (error_table_$noarg, CALLER, "^/^3xComment specifiers are required for the ^a operation.",
			oper (d.ag.op.name, 1));
	     end;

	if d.ag.input.value.approve_value ^= "" then do;	/* validate the approve value if given		*/
		valid = FALSE;
		if d.Scfix then do;
						/* critical fix				*/
			call hcom_cfix_validate_ ((CALLER), APPROVAL_FIELD_NAME, d.ag.input.value.approve_value, valid,
			     d.ag.input.value.approve_value, "", error_msg);
			if ^valid then
			     call check_error (-1, CALLER, "^3xInvalid approve value:  ^a^/^3x^a", d.ag.input.value.approve_value, error_msg);
		     end;
		else do;
			call d.ag.vdt ((CALLER), APPROVAL_FIELD_NAME, d.ag.input.value.approve_value, valid,
			     d.ag.input.value.approve_value, "", error_msg);
			if ^valid & error_msg = "" then do; /* user answered no to mcr question		*/
				Serror_has_occurred = TRUE;
				goto FATAL_ERROR;
			     end;
			else if ^valid then
			     call check_error (-1, CALLER, "^3xInvalid approve value:  ^a^/^3x^a", d.ag.input.value.approve_value, error_msg);
		     end;
	     end;
	if d.ag.input.value.install_id ^= "" then do;	/* validate the install id if given		*/
		valid = FALSE;
		if d.Scfix then
		     call hcom_cfix_validate_ ((CALLER), INSTALL_FIELD_NAME, d.ag.input.value.install_id, valid,
			d.ag.input.value.install_id, "", error_msg);
		else
		     call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME, d.ag.input.value.install_id, valid, d.ag.input.value.install_id, "", error_msg);
		if ^valid then
		     call check_error (-1, CALLER, "^3xInvalid install id:  ^a^/^3x^a", d.ag.input.value.install_id, error_msg);
	     end;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* 1) Stop execution if any errors were reported earlier.				*/
/* 2) Establish cleanup handler for temporary segments.				*/
/* 3) Get all temp segments needed for any hcom operation.				*/
/* 4) Call hcom_process_path_ to process all the arguments.				*/
/* 5) Release all temp segments and return.					*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	if check_error$error_has_occurred () then do;
	     if d.Saf then
	        call set_return_arg ("false");
	     go to FATAL_ERROR;
	     end;

	on cleanup call hcom_janitor ();

	call get_temp_segments_ (CALLER, temp_seg_array, code);
	call check_error$fatal (code, CALLER, "^/^3xError obtaining temporary segments.");

	call hcom_process_path_ (addr (d));

	if d.ag.op.name = EXISTS & ^d.Saf then
	     call ioa_ ("^a", ret);

FATAL_ERROR:
	call hcom_janitor ();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* The check_arg function entrypoints return TRUE if the current control argument is one	*/
/* accepted by a given entrypoint; and FALSE otherwise.  If TRUE is returned and the	*/
/* control argument accepts operands, then check_arg processes the operands.  Values in	*/
/* the d.ag structure are adjusted appropriately based upon the given control argument	*/
/* and its operands.							*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

check_arg:
     proc;

check_arg$apv:
     entry returns (bit (1));

	if arg = "-approve" | arg = "-apv" then do;
		if get_op ("An approval value is required.  For example, MCR6734.", arg) then do;
			if op = "" then do;
				d.ag.input.value.approve_value = "";
				d.ag.input.value.approve_dt = "";
				d.ag.input.apv = CLEARxxx;
			     end;
			else do;
				if length (op) > maxlength (d.ag.input.approve_value) then
				     call check_error (error_table_$bigarg, CALLER, "^3x-approve ^a^/An approve value must^/^3xbe <= ^d characters long.", d.ag.input.approve_value, maxlength (d.ag.input.value.approve_value));

				d.ag.input.value.approve_value = op;
				d.ag.input.value.approve_dt = current_date;
				d.ag.input.apv = OPERANDxxx;
			     end;
		     end;
		return (TRUE);
	     end;
	else if arg = "-input_approve" | arg = "-iapv" then do;
		d.ag.input.value.approve_value = "";
		d.ag.input.value.approve_dt = "";
		d.ag.input.apv = INPUTxxx;
		return (TRUE);
	     end;
	else if arg = "-no_approve" | arg = "-napv" then do;
		d.ag.input.value.approve_value = "";
		d.ag.input.value.approve_dt = "";
		d.ag.input.apv = NOxxx;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$audit:
     entry returns (bit (1));

	if arg = "-audit" | arg = "-aud" then do;
		d.ag.input.value.audit_person = rtrim (user_name);
		d.ag.input.value.audit_dt = current_date;
		d.ag.input.aud = OPERANDxxx;
		return (TRUE);
	     end;
	else if arg = "-no_audit" | arg = "-naud" then do;
		d.ag.input.value.audit_person = "";
		d.ag.input.value.audit_dt = "";
		d.ag.input.aud = NOxxx;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
check_arg$cfix:
     entry returns (bit (1));

	if arg = "-cfix" then do;
		d.Scfix = TRUE;
		if d.ag.input.apv = OPERANDxxx & index (d.ag.input.value.approve_value, "fix_") = 0 then
		     call check_error (error_table_$bad_arg, CALLER, "^3x-approve ^a^/The cfix arg has been specified a critical fix number is required.",
			d.ag.input.approve_value);
		d.ag.vdt = hcom_cfix_validate_;
		return (TRUE);
	     end;
	return (FALSE);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$error:
     entry returns (bit (1));

	if arg = "-errors" | arg = "-er" then do;
		d.ag.ctl.errors = TRUE;
		return (TRUE);
	     end;
	else if arg = "-no_errors" | arg = "-ner" then do;
		d.ag.ctl.errors = FALSE;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$field_name:
     entry returns (bit (1));

	dcl     (field, i, j, k)	 fixed bin,
	        match		 fixed bin (1),
	        (OPTIONAL		 init (0),
	        REQUIRED		 init (1)) fixed bin (1) int static options (constant);

	dcl     field_name		 (9, 2) char (20) var int static options (constant) init (
				 "change_date", "cdt", /* 1*/
				 "change_person_id", "cpi", /* 2*/
				 "approve_date", "apvdt", /* 3*/
				 "approve_id", "apvi", /* 4*/
				 "audit_date", "auddt", /* 5*/
				 "audit_person_id", "audpi", /* 6*/
				 "install_date", "indt", /* 7*/
				 "install_id", "ini", /* 8*/
				 "summary", "sm");	/* 9*/

	d.field_array (*), k = 0;

	if arg = "-field_name" | arg = "-fn" then do;	/* multiple -fn controls   */
						/*   add to existing names */
		if get_op ("One or more field names are required.", arg) then ;
		do match = REQUIRED, OPTIONAL by 1 while (get_op ("", arg));
		     field = 0;
		     do j = lbound (field_name, 2) to hbound (field_name, 2) while (field = 0);
			do i = lbound (field_name, 1) to hbound (field_name, 1) while (field = 0);
			     if op = field_name (i, j) then
				field = i;
			end;
		     end;

		     if field > 0 then do;
			     substr (string (d.ag.output), field, 1) = TRUE;
			     k = k + 1;		/* store fld no so display can be positional	*/
			     d.field_array (k) = field;
			end;
		     else if match = REQUIRED then do;
			     call check_error (-1, CALLER, "^3xUnknown history comment field name: ^a ^a", arg, op);
			     return (TRUE);
			end;
		     else do;
			     call put_op ();
			     return (TRUE);
			end;
		end;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
check_arg$fill:
     entry returns (bit (1));

	if arg = "-no_fill" | arg = "-nfi" then do;
		d.ag.ctl.fill = FALSE;
		Sfill_arg = TRUE;
		return (TRUE);
	     end;
	else if arg = "-fill" | arg = "-fi" then do;
		d.ag.ctl.fill = TRUE;
		Sfill_arg = TRUE;
		return (TRUE);
	     end;

	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$install_required:
     entry returns (bit (1));
     
          if arg = "-no_install" | arg = "-nin" then
             return (FALSE);

check_arg$install:
     entry returns (bit (1));

	if arg = "-install" | arg = "-in" then do;
		if get_op ("An install id is required.  For example, MR12.0-00234.", arg) then do;
			if op = "" then do;
				d.ag.input.value.install_id = "";
				d.ag.input.value.install_dt = "";
				d.ag.input.in = CLEARxxx;
			     end;
			else do;
				if Lop > maxlength (d.ag.input.install_id) then
				     call check_error (error_table_$bigarg, CALLER, "^3x-install ^a^/An install value must be <= ^d",
					op, maxlength (d.ag.input.value.install_id));

				d.ag.input.value.install_id = op;
				d.ag.input.value.install_dt = current_date;
				d.ag.input.in = OPERANDxxx;
			     end;
		     end;
		return (TRUE);
	     end;

	else if arg = "-input_install" | arg = "-iin" then do;
		d.ag.input.value.install_id = "";
		d.ag.input.value.install_dt = "";
		d.ag.input.in = INPUTxxx;
		return (TRUE);
	     end;

	else if arg = "-no_install" | arg = "-nin" then do;
		d.ag.input.value.install_id = "";
		d.ag.input.value.install_dt = "";
		d.ag.input.in = NOxxx;
		return (TRUE);
	     end;

	return (FALSE);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$orig:
     entry returns (bit (1));

	if arg = "-original" | arg = "-orig" then do;
		if get_op ("   Pathname of original version of the segment is required.", arg) then
		     d.ag.orig.path = op;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$rnb:
     entry returns (bit (1));

	if arg = "-renumber" | arg = "-rnb" then do;
		d.ag.ctl.renumber = TRUE;
		return (TRUE);
	     end;
	else if arg = "-no_renumber" | arg = "-nrnb" then do;
		d.ag.ctl.renumber = FALSE;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$no_summary:
     entry returns (bit (1));

	if arg = "-no_summary" | arg = "-nsm" then do;
		d.ag.input.value.summary = "";
		d.ag.input.sm = NOxxx;
		return (TRUE);
	     end;

check_arg$summary:
     entry returns (bit (1));

	if arg = "-summary" | arg = "-sm" then do;
		if get_op ("A change summary is required.", arg) then do;
			if op = "" then do;
				call check_error (error_table_$bad_arg, CALLER, "^3x^a """" Clearing the summary field is not allowed.", arg);
			     end;
			else do;
				if length (op) > maxlength (d.ag.input.summary) then
				     call check_error (error_table_$bigarg, CALLER, "^3xOperand of -summary must be <= ^d characters 
               long.", op, maxlength (d.ag.input.value.summary));

				d.ag.input.value.summary = op || NL;
				d.ag.input.sm = OPERANDxxx;
			     end;
		     end;
		return (TRUE);
	     end;
	else if arg = "-input_summary" | arg = "-ism" then do;
		d.ag.input.value.summary = "";
		d.ag.input.sm = INPUTxxx;
		return (TRUE);
	     end;
	return (FALSE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$vdt:
     entry returns (bit (1));

	if arg = "-validate" | arg = "-vdt" then do;
		if get_op ("A validation routine acceptable to cv_entry_ is required.", arg) then do;
			d.ag.vdt = cv_entry_ (op, codeptr (FATAL_ERROR), code);

			call check_error (code, CALLER, "^3x^a ^a^/^3xInvalid validation entry name",
			     arg, op);
		     end;
		return (TRUE);
	     end;
	return (FALSE);
						/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

check_arg$ERROR:
     entry;

	call check_error (error_table_$badopt, CALLER, "^3x^a^/^3xfor the ^a operation.", arg, oper (d.ag.op.name, 1));
	if d.Saf then do;
		call set_return_arg ("false");
		Sactive_function_err = TRUE;
	     end;

	return;

     end check_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	dcl     Serror_has_occurred	 bit (1);		/* On if check_error has detected an error.	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Syntax:  dcl check_error entry options(variable);				*/
/* 	  call check_error (code, procedure_name, ioa_ctl_str, args);		*/
/*     or:  dcl check_error$fatal entry options(variable);				*/
/*	  call check_error$fatal (code, procedure_name, ioa_ctl_str, args);		*/
/*									*/
/* Function: calls com_err_ or active_fnc_error_ as appropriate, to report an error on	*/
/* behalf of vtm.  check_error continues processing after the error is reported (but	*/
/* only if the user types "start" after active_fnc_err_ is called), whereas		*/
/* check_error$fatal stops all processing after the error message is printed.		*/
/*									*/
/* Args:									*/
/* code (fixed bin(35))							*/
/*    a status code.							*/
/* procedure_name (char(*))							*/
/*    name of the procedure reporting the error.					*/
/* ioa_ctl_str								*/
/*    error message								*/
/* args									*/
/*    args ioa_ will substitute into the error message.				*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


check_error:
     proc options (variable);

	dcl     Pcode		 ptr,
	        Serrors_are_fatal	 bit (1),		/* On if errors are fatal.			*/
	        code		 fixed bin (35) based (Pcode);

	dcl     com_err_		 entry () options (variable),
	        cu_$arg_list_ptr	 entry returns (ptr),
	        cu_$arg_ptr		 entry (fixed bin, ptr, fixed bin (21), fixed bin (35));


	Serrors_are_fatal = FALSE;
	go to COMMON;

check_error$fatal:
     entry options (variable);

	Serrors_are_fatal = TRUE;
	go to COMMON;

COMMON:	call cu_$arg_ptr (1, Pcode, 0, 0);		/* Access error table code argument.		*/
	if code = 0 then return;			/* If non-zero, this ISN'T an error.		*/
	Serror_has_occurred = TRUE;
	if code = -1 then code = 0;			/* No error table code fits the desired err msg.	*/
	call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
	if Serrors_are_fatal then do;
	     if d.Saf then
	        call set_return_arg ("false");
	     go to FATAL_ERROR;
	     end;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Syntax:  call check_error$init();						*/
/*									*/
/* Function:  Initializes switch indicating that no errors occurred so far.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

check_error$init:
     entry;

	Serror_has_occurred = FALSE;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Syntax:  error_has_occurred = check_error$error_has_occurred();			*/
/*									*/
/* Function:  tell callers if any errors have occurred so far.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


check_error$error_has_occurred:
     entry returns (bit (1));

	return (Serror_has_occurred);

     end check_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	dcl     Iarg		 fixed bin,	/* Current argument being processed.		*/
	        Larg		 fixed bin (21),	/* Length of current argument.		*/
	        Lop		 fixed bin (21),	/* Length of current ctl arg operand.		*/
	        Lret		 fixed bin (21),	/* Max length of AF return value.		*/
	        Nargs		 fixed bin,	/* Number of arguments.			*/
	        Parg		 ptr,		/* Ptr to current argument.			*/
	        Pop		 ptr,		/* Ptr to current operand.			*/
	        Pret		 ptr,		/* Ptr to AF return value.			*/
	        arg		 char (Larg) based (Parg),
	        op		 char (Lop) based (Pop),
	        ret		 char (Lret) varying based (Pret),
	        true_false_value	 char (5) varying,
	        (arg_ptr		 variable,
	        cu_$af_arg_ptr,
	        cu_$arg_ptr)	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	        cu_$af_return_arg	 entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
	        (err		 variable,
	        active_fnc_err_,
	        com_err_)		 entry () options (variable);

get_invocation_type:				/* Were we invoked as command or af?  Arg count?	*/
     proc (Saf);

	dcl     Saf		 bit (1) aligned;

	call cu_$af_return_arg (Nargs, Pret, Lret, code);
	if code = 0 then do;
		Saf = TRUE;
		arg_ptr = cu_$af_arg_ptr;
		err = active_fnc_err_;
		ret = "";
	     end;
	else do;
		Saf = FALSE;
		arg_ptr = cu_$arg_ptr;
		err = com_err_;
		Pret = addr (true_false_value);
		Lret = maxlength (true_false_value);
		ret = "";
	     end;
	Iarg = 0;					/* No args processed so far.			*/

     end get_invocation_type;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

get_arg:
     proc returns (bit (1));				/* Returns TRUE if another argument exists.	*/
						/*   Its value is accessible via arg variable.	*/

	if Iarg + 1 > Nargs then
	     return (FALSE);
	Iarg = Iarg + 1;
	call arg_ptr (Iarg, Parg, Larg, code);
	return (TRUE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

get_op:
     entry (str, arg1) returns (bit (1));		/* Returns TRUE if another argument exists.	*/
						/*   Its value is accessible via op variable.	*/

	dcl     str		 char (*),
	        arg1		 char (*);

	if Iarg + 1 > Nargs then do;
		if str ^= "" then
		     call check_error (error_table_$noarg, CALLER, "^3xOperand of ^a^/^a", arg1, str);
		return (FALSE);
	     end;
	Iarg = Iarg + 1;
	call arg_ptr (Iarg, Pop, Lop, code);
	return (TRUE);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

put_arg:						/* Return argument or      */
put_op:						/* operand to list of      */
     entry;					/* unprocessed d.ag.       */

	Iarg = Iarg - 1;
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


reprocess_args:					/* Reprocess argument list again, starting with	*/
     entry (Ith_arg);				/*   the Ith argument.			*/

	dcl     Ith_arg		 fixed bin;

	Iarg = Ith_arg - 1;				/* get_arg adds 1 before reading an arg.	*/
	return;

     end get_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

set_return_arg:					/* Set AF return value.			*/
     proc (str);

	dcl     str		 char (*);

	ret = str;
	return;

add_to_return_arg:
     entry (str);

	if ret = "" then
	     ret = requote_string_ (str);
	else do;
		ret = ret || " ";
		ret = ret || requote_string_ (str);
	     end;
	return;


add_to_return_arg_var:
     entry (str_var);

	dcl     str_var		 char (*) varying;

	if ret = "" then
	     ret = requote_string_ ((str_var));
	else do;
		ret = ret || " ";
		ret = ret || requote_string_ ((str_var));
	     end;
	return;

     end set_return_arg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

get_com_spec:
     proc;

	dcl     from_arg		 char (80) var,
	        (spec, i, j)	 fixed bin,
	        to_arg		 char (80) var;

	dcl     specs		 (11, 2) char (12) var int static options (constant) init (
				 "all", "a",	/*  1 */
				 "old", "~",	/*  2 */
				 "new", "~",	/*  3 */
				 "complete", "cpt", /*  4 */
				 "incomplete", "icpt", /*  5 */
				 "approved", "apv", /*  6 */
				 "unapproved", "unapv", /*  7 */
				 "audited", "aud",	/*  8 */
				 "unaudited", "unaud", /*  9 */
				 "installed", "in", /* 10 */
				 "uninstalled", "unin"); /* 11 */

	spec = 0;
	do j = lbound (specs, 2) to hbound (specs, 2) while (spec = 0);
	     do i = lbound (specs, 1) to hbound (specs, 1) while (spec = 0);
		if arg = specs (i, j) then
		     spec = i;
	     end;
	end;
	if spec > 0 then
	     substr (string (d.com_spec.selected), spec, 1) = TRUE;

	else do;
		d.com_spec.Nrange = d.com_spec.Nrange + 1;
		d.com_spec.range (d.Nrange) = 0;
		from_arg = before (arg, ":");
		to_arg = after (arg, ":");
		d.com_spec.from (d.Nrange) = get_range (from_arg);

		if to_arg ^= "" then /* one part				*/
		     d.com_spec.to (d.Nrange) = get_range (to_arg);
	     end;					/*range*/
	return;

get_range:
     proc (arg_in) returns (1 like d.com_spec.range.from);

	dcl     arg_in		 char (80) var;
	dcl     1 arg_out		 like d.com_spec.range.from;

	dcl     operand		 char (80) var,
	        addend		 char (80) var;

	operand, addend = "";
	arg_out = 0;
	arg_out.set = SET;

	if index (arg_in, "+") > 0 then do;
		operand = before (arg_in, "+");
		addend = after (arg_in, "+");
		arg_out.op = PLUS;
	     end;
	else if index (arg_in, "-") > 0 then do;
		operand = before (arg_in, "-");
		addend = after (arg_in, "-");
		arg_out.op = MINUS;
	     end;
	else do;
		operand = arg_in;
		addend = "";
		arg_out.op = UNSET;
	     end;

	if verify (operand, "0123456789") = 0 then
	     arg_out.no = convert (arg_out.no, operand);
	else do;
		if operand = "first" | operand = "f" then
		     arg_out.no = 1;
		else if operand = "last" | operand = "l" then
		     arg_out.set = LAST;
		else call check_error$fatal (error_table_$badopt, CALLER, "^3x^a.", arg_in);
	     end;

	if addend ^= "" then do;
		if verify (addend, "0123456789") = 0 then
		     arg_out.addend = convert (arg_out.addend, addend);
		else
		     call check_error (error_table_$improper_data_format, CALLER, "^/^3xThe addend must be numeric:  ^a", addend);
	     end;

	return (arg_out);

     end get_range;

     end get_com_spec;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


hcom_janitor:
     proc;

	dcl     code		 fixed bin (35);

	if temp_seg_array (1) ^= null then
	     call release_temp_segments_ (CALLER, temp_seg_array, code);

     end hcom_janitor;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init$args:
     proc;

	current_date = date_time_$format ("^yc-^my-^dm", clock (), "", "");
	call user_info_ (user_name, "", "");

	d.ag.op.name = NOTSET;
	d.ag.op.type = NO_MODIFY;

	Sactive_function_err = FALSE;
	Sfill_arg = FALSE;

	on linkage_error
	     begin;
		d.Ssite = FALSE;
		d.ag.vdt = hcom_default_validate_;
		goto CONTINUE;
	     end;

	d.ag.vdt = hcom_site_validate_;
	d.Ssite = TRUE;

CONTINUE:
	d.ag.ctl.renumber = FALSE;
	d.ag.ctl.errors = TRUE;
	d.ag.ctl.fill = TRUE;
	d.ag.source.path, d.ag.source.dir, d.ag.source.ent, d.ag.source.comp = "";
	d.ag.source.ent_type = 0;
	d.ag.orig = d.ag.source;
	d.ag.input.select = NOxxx;
	d.ag.input.value.change_dt = current_date;
	d.ag.input.value.seqno = 0;
	d.ag.input.value.selected = FALSE;
	d.ag.input.value.Ieq = 0;
	d.ag.input.value.comment_no = 0;
	d.ag.input.value.change_person = rtrim (user_name);
	d.ag.input.value.approve_dt = "";
	d.ag.input.value.approve_value = "";
	d.ag.input.value.audit_dt = "";
	d.ag.input.value.audit_person = "";
	d.ag.input.value.install_dt = "";
	d.ag.input.value.install_id = "";
	d.ag.input.value.summary = "";
	d.ag.output = FALSE;

	d.com_spec.selected = FALSE;
	d.com_spec.matched = FALSE;
	d.com_spec.Nrange, d.com_spec.range = 0;

	d.check_error$fatal = check_error$fatal;
	d.set_return_arg = set_return_arg;
	d.add_to_return_arg = add_to_return_arg;
	d.add_to_return_arg_var = add_to_return_arg_var;
	d.Saf = FALSE;
	d.Scfix = FALSE;
	d.Scfix_found = FALSE;

	d.seg_arch.dir, d.seg_arch.ent, d.seg_arch.comp = "";
	d.seg_arch.comp_type = NOCOMP;
	d.seg_arch.Pseg = null;
	d.seg_arch.Lseg, d.seg_arch.Lsegbc = 0;

	d.seg = d.seg_arch, by name;
	d.seg.Lseg_in, d.seg.Lseg_out = 0;
	d.seg.ec_version, d.seg.type, d.seg.text_pos = 0;
	d.seg.cmt_bgn, d.seg.cmt_end = "";
	d.seg.Pbox = null;
	d.seg.Loldbox = 0;
	d.seg.Lnewbox = 0;

	d.orig_seg = d.seg;

	d.temp_seg = null;

     end init$args;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include hcom_data;

	dcl     1 auto_hcom_data	 like d automatic;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include hcom_field_names;
     end history_comment;




		    hcom_cfix_validate_.pl1         06/05/86  1135.6rew 06/05/86  1121.0       76617



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(85-09-23,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     Created September 1985.
  2) change(86-04-30,LJAdams), approve(86-05-19,MCR7386),
     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
     Added parameter for error message.
                                                   END HISTORY COMMENTS */

hcom_cfix_validate_:
     proc (P_caller, P_field_name, P_input_value, P_result, P_canonical_value, P_field_type, P_err_msg);

/* *	HCOM_CFIX_VALIDATE_
   *
   *	This is the procedure used to validate values placed in fields
   *	of a history comment or installation description.
   *
   *	The validation procedure takes an input value to validate, and 
   *	returns a bit indicating the validity.  The name of the field is
   *	supplied to determine what sort of validation will be applied,
   *	and the name of the calling procedure is supplied for use in 
   *	error messages and questions.  An error message is always printed
   *	when the field value is invalid, so the caller of the validation
   *	routine need never print one.
   *
   *	In addition to the valid/invalid result, this procedure also
   *	returns the canonical form of the field value (making appropriate
   *	case translations, etc.), the field type (a character string 
   *	whose value depends on the field itself).
   *
   *	The critical fix validation procedure makes the following checks:
   *
   *	"author" field
   *         Validated for "correct" syntax and length restriction
   *	"approval" field
   *	   Must be a critical fix number in the format:
   *	     fix_nn or fix_nn.ds
   *	"audit" field
   *         Validated for "correct" syntax and length restriction
   *	"install" field
   *	   Person id of the installer of the critical fix
   *	Other fields
   *	   Always rejected.
   */

declare   P_caller char (*) varying parameter;		/* INPUT: Name of validation procedure's caller */
declare   P_field_name char (*) varying parameter;	/* INPUT: Name of field to be validated */
declare   P_input_value char (*) varying parameter;	/* INPUT: Value to be checked for validity */
declare   P_result bit (1) aligned parameter;		/* OUTPUT: Whether input was valid or not */

declare   P_canonical_value char (*) varying parameter;	/* OUTPUT: Canonical text form of above */
declare   P_field_type char (*) varying parameter;	/* OUTPUT: Character prefix of approval value */
declare   P_err_msg char (100) varying parameter;           /* OUTPUT: error message			*/

declare   NAMECASE char (53) internal static options (constant) init
         ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'");
declare   VALID_CHARACTERS char (17) internal static options (constant) init ("fix_.ds0123456789");
declare   DIGITS char (10) internal static options (constant) init ("0123456789");
declare   DELIMITER char (1) internal static options (constant) init ("_");


declare  (length, ltrim, null, rtirm, substr, verify) builtin;

/*  */


          P_result = "0"b;                                  /* Initialize output values			*/
          P_canonical_value = P_input_value;                /* Just return the input in case of error	*/
          P_field_type = "";                                /* Type-dependent values are returned null	*/
	P_err_msg = "";
	

/* Call the appropriate (internal) validation procedure, depending on the
   field name.  These procedures are responsible for setting all output
   parameters, issuing all error messages, and asking questions.  When 
   they return, all the results should be set appropriately, since the
   external procedure just returns at that point.  In particular, they must
   all set P_result, since that has been initialized to "0"b already, above.
   */

	if (P_field_name = AUTHOR_FIELD_NAME) then
               call validate_personid (AUTHOR_FIELD_NAME);
	else if (P_field_name = APPROVAL_FIELD_NAME) then
	     call validate_cfixno ();
	else if (P_field_name = AUDIT_FIELD_NAME) then
               call validate_personid (AUDIT_FIELD_NAME);
	else if (P_field_name = INSTALL_FIELD_NAME) then
	     call validate_personid(INSTALL_FIELD_NAME);
	else 
	     P_err_msg = "Invalid field name";
	

CHECK_RETURNS:
	return;					/* All done */

/*  */
validate_personid:
     procedure (P_type);

declare   P_type char (*) varying parameter;                /* "author" or "audit" -- not used in this implementation */

/* Ideally, perhaps, this would check the person ID against a little database of valid
   values, giving the updater the opportunity to accept or reject one that wasn't
   found.  It could even translate initials or nicknames to the real name. For now,
   though, all it does is make a trivial syntactic check that isn't even correct
   in all cases (deJong, for instance).  This represents an opportunity for people
   to modify this routine to be spiffier. */


          if (length (P_input_value) < 2) then              /* Between 2 and 24 characters */
               P_result = "0"b;
          else if (length (P_input_value) > 24) then
               P_result = "0"b;
          else if verify (P_input_value, NAMECASE) ^= 0 then
               P_result = "0"b;                             /* And be all alphabetic */
          else P_result = "1"b;                             /* Otherwise, it's OK */

          return;
          end validate_personid;

/*  */

validate_cfixno:
     procedure ();

declare   approval char (24) varying;
declare   part_1 char (24) varying;
declare   part_2 char (24) varying;
declare	part_3 char (24) varying;
declare   first_digit fixed bin;
declare	last_digit fixed bin;


	approval = P_input_value;
	approval = rtrim (approval);
	approval = ltrim (approval);

	if (length (approval) = 0) then
	     call invalid_cfixno ("Approval must not be null");

	if (verify (approval, VALID_CHARACTERS) ^= 0) then
	     call invalid_cfixno ("Only critical fix numbers are currently acceptable (e.g. fix_nnnn.ds)");

	first_digit = verify (approval, "fix_");
	if (first_digit = 0) then			/* All alpha characters */
	   call invalid_cfixno ("No fix number supplied.");

	else if (first_digit = 1) then		/* Syntax error to omit the identifying word */
	     call invalid_cfixno ("Must not begin with a digit.");

	else do;					/* Contains an identifying number */
	     part_1 = substr (approval, 1, (first_digit - 1));
	     part_2 = substr (approval, first_digit);
	     part_2 = ltrim (part_2, DELIMITER);	/* Trim off delimiter appearing twix 1st/2nd part */
	     last_digit = verify(part_2,"0123456789");
	     if last_digit > 0 then do;
	        part_3 = substr(part_2,last_digit);
	        part_2 = substr(part_2,1,last_digit-1);
	        end;
	     else
	        part_3 = "";
	     if (length (part_2) = 0) then		/* Error if nothing but delimiters */
		call invalid_cfixno ("Must include a decimal number");
	     if (verify (part_2, DIGITS) ^= 0) then
		call invalid_cfixno ("Approval number field must be all decimal");
	     if (length (part_2) > 4) then
		call invalid_cfixno ("Approval number field must be 4 digits or less");
	     if length(part_3) > 0 & part_3 ^= ".ds" then
	        call invalid_cfixno("Fix number ends improperly.");

	     end;

/* Note that we assign the output values here, and then ask the question;
   this gives the caller a chance to use the canonical value when asking
   for a replacement. */

	P_result = "1"b;				/* It's valid */
	if part_3 ^= "" then
	   P_canonical_value = part_1 || part_2 || part_3;
	else
	   P_canonical_value = part_1 || part_2;
	P_field_type = part_1;			/* Make it easier for our caller to re-use */

	return;
end validate_cfixno;

/*  */

invalid_cfixno:
     procedure (P_message);

declare   P_message char (*) parameter;

/* This procedure prints an error message and returns a false result,
   for use when the value is invalid */


          P_err_msg = P_message;
	P_result = "0"b;				/* Invalid */
	goto CHECK_RETURNS;

	end invalid_cfixno;

/*  */


%page; %include hcom_field_names;
%page; %include query_info;
%page; %include format_document_options;

	end hcom_cfix_validate_;
       




		    hcom_command_query_.pl1         10/24/88  1643.5r w 10/24/88  1401.2      263475



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */
/****^  HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     Version of command_query_ that allows inputting
     of multiple lines of text for the history comment summary field.
                                                   END HISTORY COMMENTS */
hcom_command_query_:
     procedure (qip, varying_answer);

/* BEGIN DESCRIPTION */

/* function: */

/* The standard procedure to ask a question and read the user's answer: the question is formatted and the condition
   "command_question" is signalled allowing for programs like "answer" to supply answers automatically; the
   "repeat_query" command is also contained herein to reask the last question */

/* history: */

/* Created:  September 1971 by Jerry Stern */
/* Modified: 15 September 1971 by Jerry Stern */
/* Modified: 20 November 1975 by Steve Herbst to add the repeat_query command */
/* Modified: 26 October 1976 by Paul Green to switch to iox_ (get it?) */
/* Modified: 13 June 1978 by Steve Herbst to add the temporary entry point user_io */
/* Modified: July 1978 by J. C. Whitmore to remove user_io entry in favor of extended info structures */
/* Modified: 11 August 1978 by W. O. Sibert to add cu_$cp escape feature and set_allow_cp_escape entrypoint */
/* Modified: 23 January 1979 by William M. York to fix overlength substr assignment bug (see MCR 3661), lengthen the
             internal buffers, and call iox_$put_chars directly, avoiding the 256 char ioa_ restriction */
/* Modified: 7 September 1979 by Steve Herbst to signal command_query_error for bad answers in absentee */
/* Modified: 8 May 1981 by Steve Herbst to add command_query_$yes_no, the explanantion feature, and to accept y/n */
/* Modified: June 1981 by Benson Margulies to set the quiet_restart bit in condition structure */
/* Modified: 6 August 1981 by Richard Lamson to fix out-of-range version numbers in query_info structure */
/* Modified: 11 March 1982 by G. Palter to issue reset_more control order before asking questions */
/* Modified: 12/15/82 by S. Herbst to add literal_sw, prompt_after_explanation, and cp_escape_control value "01"b */
/* Modified: 02/08/84 by S. Herbst to check whether called with varying or nonvarying answer arg */
/* Modified: 02/08/84 by S. Herbst to change length fields in command_question_info.incl.pl1 from fixed to fixed (21) */
/* Modified: 03/27/84 by S. Herbst to say "Answer yes, no, or ? for an explanation" */
/* Modified: 06/14/84 by S. Herbst to call sub_err_ if error from iox_ writing question/reading answer */
/* Modified: 01/08/85 by J. Backs to accept case insensitive yes or no answer by translating answer before testing,
             plus minor changes to include some coding standards for readablity */


/* format: style4,delnl,insnl,ifthenstmt,ifthen */

%page;
/* PARAMETERS */

dcl  varying_answer character (*) varying parameter;
dcl  qip pointer parameter;
dcl  yes_sw bit (1) parameter;
dcl  A_query_code fixed binary (35) parameter;


/* CONSTANTS */
dcl  False bit(1) init("0"b) int static options(constant),
     True bit(1)  init("1"b) int static options(constant);
dcl  GRIPE1 character (27) static options (constant) initial
	("Please answer yes or no.   ");
dcl  GRIPE2 character (50) static options (constant) initial
	("Please answer yes, no, or ? for an explanation.   ");
dcl  LOWERCASE_YN character (5) static options (constant) initial ("yesno");
dcl  NL character (1) static options (constant) initial ("
");
dcl  SPACE_SPACE character (2) static options (constant) init ("  ");
dcl  UPPERCASE_YN character (5) static options (constant) initial ("YESNO");
dcl  WHITE character (5) static options (constant) initial (/* SP HT VT FF NL */ " 	
");

/* BASED */

dcl  alloc_str character (alloc_len) based (alloc_ptr);
dcl  big_str character (big_len) based (big_ptr);
dcl  callername character (question_info.name_lth) based (question_info.name_ptr);
dcl  explanation character (query_info.explanation_len) based (query_info.explanation_ptr);
dcl  fixed_answer char (fixed_answer_len) based (fixed_answer_ptr);
dcl  question character (question_info.question_lth) based (question_info.question_ptr);
dcl  nchars fixed binary (21) based;
dcl  area area based (area_ptr);

dcl  1 input_info aligned based (qip) like query_info;

/* AUTOMATIC */

dcl  (abs_queue, arg_count, bi, callername_index, control_string_index, ndims, scale, type) fixed binary;
dcl  (alloc_len, big_len, fixed_answer_len, fixed21, len) fixed binary (21);
dcl  (alloc_ptr, area_ptr, alp, big_ptr, fixed_answer_ptr) pointer;
dcl  (alloc_sw, allow_cp_escape, fixed_answer_sw, interpret_cp_escape) bit (1) aligned;
dcl  buffer character (1000) aligned;
dcl  code fixed binary (35);
dcl  (ending_delim_found, multi_line_sw) bit(1);
dcl  error_string character (100) aligned;
dcl  Lanswer fixed bin(21);
dcl  output_buffer character (1004) aligned;
dcl  (packed, saved_rflag, timer_set, yn_entry_sw) bit (1) aligned;
dcl  1 question_info aligned like command_question_info;
dcl  retstring character (1000);
dcl  saved_rlabel label variable;
dcl  yn_answer character (500) aligned varying;

/* BUILTINS */

dcl  (addr, addrel, bin, bit, index, length, ltrim, max, maxlength, min, null,
      rtrim, size, substr, translate, unspec) builtin;

/* CONDITIONS */

dcl  cleanup condition;

/* EXTERNAL STATIC */

dcl  iox_$user_input pointer external;
dcl  iox_$user_io pointer external;
dcl  iox_$user_output pointer external;

dcl  error_table_$long_record fixed binary (35) external;

/* INTERNAL STATIC */

dcl  repeat_label label variable static;
dcl  repeat_flag bit (1) aligned initial ("0"b) static;

dcl  first_call bit (1) static initial ("1"b);
dcl  static_allow_cp_escape bit (1) aligned static initial ("0"b);

/* ENTRIES */

dcl  com_err_ entry () options (variable);
dcl  convert_status_code_ entry (fixed binary (35), character (8) aligned, character (100) aligned);
dcl  cu_$arg_count entry (fixed binary);
dcl  cu_$arg_list_ptr entry (pointer);
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  decode_descriptor_
	entry (pointer, fixed binary, fixed binary, bit (1) aligned, fixed binary, fixed binary, fixed binary);
dcl  get_group_id_ entry () returns (character (32));
dcl  get_system_free_area_ entry () returns (pointer);
dcl  ioa_			entry() options(variable);
dcl  ioa_$general_rs
	entry (pointer, fixed binary, fixed binary, character (*), fixed binary (21), bit (1) aligned, bit (1) aligned);
dcl  ioa_$ioa_switch entry () options (variable);
dcl  ioa_$ioa_switch_nnl entry () options (variable);
dcl  iox_$control entry (pointer, character (*), pointer, fixed binary (35));
dcl  iox_$get_line entry (pointer, pointer, fixed binary (21), fixed binary (21), fixed binary (35));
dcl  iox_$put_chars entry (pointer, pointer, fixed binary (21), fixed binary (35));
dcl  signal_ entry (character (*), pointer, pointer, pointer);
dcl  sub_err_ entry () options (variable);
dcl  timer_manager_$alarm_call entry (fixed binary (71), bit (2) aligned, entry);
dcl  timer_manager_$reset_alarm_call entry (entry);
dcl  user_info_$absentee_queue entry (fixed binary);
%page;
/* BEGIN */

/* hcom_command_query_: entry (qip, varying_answer); */

	query_info.version = input_info.version;
	if query_info.version < 1 | query_info.version > 7 then do;
						/* Old programs are grandfathered */
	     query_info.version = 2;			/* Harmless version number */
	end;

	yn_entry_sw = "0"b;
	callername_index = 3;
	control_string_index = 4;
	query_info.yes_or_no_sw = input_info.yes_or_no_sw;/* copy the input data */
	query_info.suppress_name_sw = input_info.suppress_name_sw;
	query_info.status_code = input_info.status_code;
	query_info.query_code = input_info.query_code;
	multi_line_sw = False;

	if query_info.version >= 3 then do;		/* if more is defined, use it */
	     if query_info.version >= 4 then do;	/* use new bits */
		query_info.cp_escape_control = input_info.cp_escape_control;
		query_info.suppress_spacing = input_info.suppress_spacing;
		if query_info.version >= 5 then do;
		     query_info.explanation_len = input_info.explanation_len;
		     if query_info.explanation_len ^= 0 then query_info.explanation_ptr = input_info.explanation_ptr;
		     if query_info.version >= 6 then do;
			query_info.literal_sw = input_info.literal_sw;
			query_info.prompt_after_explanation = input_info.prompt_after_explanation;
			if query_info.version >= 7 then do;
			     if input_info.ending_delim ^= "" then do;
				multi_line_sw = True;
				query_info.ending_delim = input_info.ending_delim;
				query_info.ending_delim_description = input_info.ending_delim_description;
				ending_delim_found = False;
			     end;
			end;
		     end;
		end;
	     end;
	     query_info.question_iocbp = input_info.question_iocbp;
	     query_info.answer_iocbp = input_info.answer_iocbp;
	     query_info.repeat_time = input_info.repeat_time;
	end;

	if query_info.literal_sw | query_info.cp_escape_control = "01"b then do;
	     allow_cp_escape = "1"b;
	     interpret_cp_escape = "0"b;
	end;
	else if query_info.cp_escape_control = "11"b then allow_cp_escape, interpret_cp_escape = "1"b;
	else if query_info.cp_escape_control = "10"b then allow_cp_escape, interpret_cp_escape = "0"b;
	else allow_cp_escape, interpret_cp_escape = static_allow_cp_escape;

	go to COMMON;


/* format: off */
/* An easy-to-use entry which requires a yes/no answer:
	call hcom_command_query_$yes_no (yes_sw, status_code, callername, explanation, control_string, args...) */
/* format: on */

yes_no:
     entry (yes_sw, A_query_code);

	yn_entry_sw = "1"b;
	callername_index = 3;
	control_string_index = 5;
	unspec (query_info) = "0"b;
	query_info.yes_or_no_sw = "1"b;
	query_info.query_code = A_query_code;
	query_info.question_iocbp, query_info.answer_iocbp = null;
	allow_cp_escape, interpret_cp_escape = static_allow_cp_escape;


COMMON:
	if first_call then do;			/* be sure the labels are correctly defined */
	     repeat_label = ASK;			/* basis for saved label */
	     repeat_flag = "0"b;
	     first_call = "0"b;			/* done for this process */
	end;
	saved_rflag = repeat_flag;			/* save the state of any previous invocation */
	saved_rlabel = repeat_label;
	repeat_label = ASK;				/* redefine question repeat label to this block */
	repeat_flag = "0"b;				/* but a repeat is not defined yet */
	timer_set = "0"b;				/* no repeat timer set for this block */

	call cu_$arg_count (arg_count);
	call cu_$arg_list_ptr (alp);			/* get arglist ptr */

	if ^yn_entry_sw then do;			/* find out if answer arg is varying or non */
	     call decode_descriptor_ (alp, 2, type, packed, ndims, 0, scale);
	     fixed_answer_sw = (type = char_dtype);
	     if fixed_answer_sw then do;
	        call cu_$arg_ptr (2, fixed_answer_ptr, fixed_answer_len, 0);
	        Lanswer = 0;
	     end;
	     else
                  varying_answer = "";
	end;

	call cu_$arg_ptr (callername_index, question_info.name_ptr, fixed21, 0);
	question_info.name_lth = fixed21;
	call decode_descriptor_ (alp, callername_index, type, packed, ndims, question_info.name_lth, scale);
						/* get data type & length of callername */
	if type = varying_char_dtype then		/* varying string, must get current length */
	     question_info.name_lth = addrel (question_info.name_ptr, -1) -> nchars;
						/* the kludge shows its face */

/* get callername */

	bi = 1;
	buffer = "";
	if ^query_info.suppress_name_sw then
	     if question_info.name_lth ^= 0 then do;	/* put caller name in buffer */
		buffer = rtrim (callername);
		if buffer ^= "" then do;
		     bi = length (rtrim (buffer)) + 3;
		     substr (buffer, bi - 2, 2) = ": ";
		end;
	     end;

/* Get query_code message and verbose explanation of question for $yes_no */

	if yn_entry_sw then do;
	     if A_query_code ^= 0 then do;
		call convert_status_code_ (A_query_code, "", error_string);
		substr(buffer, bi, length(error_string)) = error_string;
		bi = length(rtrim(buffer)) + 3;
	     end;
	     call cu_$arg_ptr (callername_index + 1, query_info.explanation_ptr, query_info.explanation_len, code);
	     if code ^= 0 | query_info.explanation_len = 0 then query_info.explanation_ptr = null;
	end;

/* get user message */

	if arg_count >= control_string_index then do;
	     call ioa_$general_rs (alp, control_string_index, control_string_index + 1, retstring, len, "0"b, "0"b);
	     len = min (len, length (buffer) - bi + 1);
	     substr (buffer, bi, len) = substr (retstring, 1, len);
	     bi = bi + len;
	     if multi_line_sw then do;
		bi = length(rtrim(buffer)) + length(NL);
		substr (buffer,bi,length(NL)) = NL;
		bi = bi + 1;
	     end;
	end;

/* fill in question_info...which will be passed to the handler of the command_question condition. */

get_ready_to_signal:
	question_info.length = size (question_info);
	question_info.version = cq_info_version_7;
	question_info.action_flags.cant_restart = "0"b;
	question_info.action_flags.default_restart = "1"b;
	question_info.action_flags.quiet_restart = "1"b;
	question_info.status_code = query_info.status_code;
	question_info.query_code = query_info.query_code;
	question_info.question_sw = "1"b;		/* by default, print the question */
	question_info.yes_or_no_sw = query_info.yes_or_no_sw;
	question_info.preset_sw = "0"b;		/* don't expect a preset answer */
	question_info.answer_sw = "1"b;		/* but if one comes, print it by default */
	question_info.allow_cp_escape = allow_cp_escape;	/* computed earlier */
	question_info.suppress_spacing = query_info.suppress_spacing;
	question_info.interpret_cp_escape = interpret_cp_escape;
	question_info.literal_sw = query_info.literal_sw;
	question_info.prompt_after_explanation = query_info.prompt_after_explanation;
	question_info.max_question_lth = size (buffer);
	question_info.question_ptr = addr (buffer);
	question_info.question_lth = bi - 1;
	question_info.info_string = substr (buffer, 1, question_info.question_lth);
	if yn_entry_sw then do;
	     question_info.answer_ptr, big_ptr = addrel (addr (yn_answer), 1);
	     question_info.max_answer_lth = maxlength (yn_answer);
	end;
	else do;
	     if fixed_answer_sw then do;
		question_info.answer_ptr, big_ptr = fixed_answer_ptr;
		question_info.max_answer_lth = fixed_answer_len;
	     end;
	     else do;				/* varying answer, skip the length word */
		question_info.answer_ptr, big_ptr = addrel (addr (varying_answer), 1);
		question_info.max_answer_lth = maxlength (varying_answer);
	     end;
	end;
	question_info.question_iocbp = query_info.question_iocbp;
						/* give handler caller's output switch */
	question_info.answer_iocbp = query_info.answer_iocbp;
						/* and input switch */
	question_info.repeat_time = query_info.repeat_time;
						/* and also caller's repeat time */
	question_info.explanation_ptr = query_info.explanation_ptr;
	question_info.explanation_len = query_info.explanation_len;

	alloc_ptr = null;

/* signal command_question */

SIGNAL:
	call signal_ ("command_question", null, addr (question_info), null);

	on cleanup call clean_up;

	if question_info.question_sw & ^question_info.preset_sw then
	     repeat_flag = "1"b;			/* if asking a question */
	else repeat_flag = "0"b;

	if question_info.question_iocbp = null then	/* if no output switch defined by caller or handler */
	     if question_info.preset_sw then
		question_info.question_iocbp = iox_$user_output;
						/* put question in file?? */
	     else question_info.question_iocbp = iox_$user_io;
						/* if really asking, go to the terminal */

	if question_info.answer_iocbp = null then	/* if no input switch defined by caller or handler */
	     question_info.answer_iocbp = iox_$user_input;/* set the default input switch */

ASK:
	if question_info.question_sw then do;		/* do we print the question? */
	     if ^question_info.preset_sw then		/* and if we need a reply ... */
		call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
						/* ... make sure the user sees the question */
	     call print_question;
	end;

/* process the answer */

	alloc_sw = "0"b;

	if question_info.preset_sw then		/* kludge in the current length */
	     addrel (question_info.answer_ptr, -1) -> nchars, big_len = question_info.answer_lth;
	else do;					/* read the answer from the user's terminal */
READ_ANSWER:
	     if repeat_flag & question_info.repeat_time >= 30 then do;
						/* put 30 second lower limit on repeats */
		call timer_manager_$alarm_call (question_info.repeat_time, "11"b, repeat_query);
		timer_set = "1"b;			/* indicate that a timer is pending */
	     end;

GET_LINE:
	     call iox_$get_line (question_info.answer_iocbp, addr (retstring), length (retstring), len, code);

	     if code = error_table_$long_record then do;
		if ^alloc_sw | big_len + len > alloc_len then do;
						/* need more room */
		     if ^alloc_sw then do;
			alloc_len = length (retstring) * 4;
			area_ptr = get_system_free_area_ ();
		     end;
		     else alloc_len = max (2 * alloc_len, big_len + len);
		     alloc_ptr = null;

		     allocate alloc_str in (area) set (alloc_ptr);

		     if alloc_sw then do;
			substr (alloc_ptr -> big_str, 1, big_len) = substr (big_ptr -> big_str, 1, big_len);
			free big_ptr -> big_str in (area);
		     end;
		     else big_len = 0;

		     big_ptr = alloc_ptr;
		     alloc_sw = "1"b;
		end;

		substr (big_ptr -> big_str, big_len + 1, length (retstring)) = retstring;
		big_len = big_len + length (retstring);
		code = 0;
		go to GET_LINE;
	     end;

	     else if code ^= 0 then do;
ANSWER_ERROR:
		call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Reading answer.");
		go to GET_LINE;
	     end;

	     if alloc_sw then do;
		if big_len + len > alloc_len then do;
		     alloc_len = big_len + len;

		     allocate alloc_str in (area) set (alloc_ptr);

		     substr (alloc_ptr -> big_str, 1, big_len) = substr (big_ptr -> big_str, 1, big_len);
		     free big_ptr -> big_str in (area);
		     big_ptr = alloc_ptr;
		end;
		substr (big_ptr -> big_str, big_len + 1, len) = substr (retstring, 1, len);
		big_len = big_len + len;
	     end;
	     else do;
		big_ptr = addr (retstring);
		big_len = len;
	     end;

	     if timer_set then call timer_manager_$reset_alarm_call (repeat_query);
	end;

	if ^query_info.literal_sw & ^multi_line_sw & index (WHITE, substr (big_str, 1, 1)) ^= 0 then
	     big_str = ltrim (big_str, WHITE);		/* strip leading white space from answer */

	if substr (big_str, 1, 2) = ".." then do;	/* command processor escape */
	     if ^allow_cp_escape then do;
		call com_err_ (0, callername, "No command processor escape allowed for this question.");
		if question_info.preset_sw then
		     go to SIGNAL;
		else go to ASK;
	     end;

	     if interpret_cp_escape then do;

		call cu_$cp (addr (substr (big_str, 3, 1)), max (0, big_len - 2), code);

		if alloc_sw then do;
		     alloc_sw = "0"b;
		     free alloc_str in (area);
		     alloc_ptr = null;
		end;

		if question_info.preset_sw then
		     go to SIGNAL;
		else do;
		     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
		     call ioa_$ioa_switch_nnl (question_info.question_iocbp, "Answer: ");
		     go to READ_ANSWER;		     	/* brief prompt */
		end;
	     end;
	end;

	if ^query_info.literal_sw then big_len = length (rtrim (big_str, WHITE));

	if question_info.preset_sw & question_info.answer_sw then
						/* if preset answer exists & should be printed */
	     if question_info.question_sw | ^(big_str = "")
						/* and if the question was already printed */
	     then call ioa_$ioa_switch (question_info.question_iocbp, "^a", big_str);
						/* print answer and NL */

	if big_str = "?" & query_info.explanation_ptr ^= null & query_info.explanation_len > 0 then do;
						/* asking for an explanation and there is one */
	     call expand_explanation ();

	     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
						/* let the user see the explanation */
PRINT_EXPLANATION:
	     if query_info.suppress_spacing then
		call iox_$put_chars (question_info.question_iocbp, addr (retstring), len, code);
	     else call ioa_$ioa_switch_nnl (question_info.question_iocbp,
		"^/^a^[
End input with a line containing just ^a (^a).^;^2s^]^[^/^s^;^[^/^;^2x^]",
		substr(retstring,1,len),
		multi_line_sw & query_info.prompt_after_explanation,
		     query_info.ending_delim_description,
		     query_info.ending_delim,
		query_info.prompt_after_explanation,
		     multi_line_sw);
	     if query_info.prompt_after_explanation then call print_question;
	     go to READ_ANSWER;
	end;

	if query_info.yes_or_no_sw then do;		/* answer must be "yes" or "no" */

	                                                  /* Translate any uppercase letters to lowercase before testing */
	     big_str = translate (big_str, LOWERCASE_YN, UPPERCASE_YN);

	     if big_str ^= "yes" & big_str ^= "y" & big_str ^= "no" & big_str ^= "n" then
		if question_info.preset_sw then do;	/* the handler returned a bum answer */
		     call signal_ ("command_query_error", null, null, null);
		     go to get_ready_to_signal;	/* control may return here if a "start" command is issued */
		end;
		else do;				/* the user has given a bum answer */
		     if get_group_id_ () = "Initializer.SysDaemon.z" then
			abs_queue = -1;
		     else call user_info_$absentee_queue (abs_queue);
		     if abs_queue ^= -1 then do;	/* running in absentee */
			call com_err_ (0, "hcom_command_query_", "Invalid answer to question above.");
			call signal_ ("command_query_error", null, null, null);
			return;
		     end;
		     call iox_$control (question_info.question_iocbp, "reset_more", null (), (0));
PRINT_GRIPE:
		     if query_info.explanation_ptr ^= null & query_info.explanation_len > 0 then
			call iox_$put_chars (question_info.question_iocbp,
			     addr (GRIPE2), length (GRIPE2), code);
		     else call iox_$put_chars (question_info.question_iocbp,
			addr (GRIPE1), length (GRIPE1), code);

		     if code ^=0 then do;
			call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Writing question.");
			go to PRINT_GRIPE;
		     end;
						/* complain */
		     call iox_$control (question_info.answer_iocbp, "resetread", null, code);
						/* flush any read-ahead */
		     if alloc_sw then do;
			alloc_sw = "0"b;
			free alloc_str in (area);
			alloc_ptr = null;
		     end;

		     go to READ_ANSWER;
		end;

	     if yn_entry_sw then yes_sw = (big_str = "yes" | big_str = "y");
	     else if big_str = "y" then call set_answer ("yes");
	     else if big_str = "n" then call set_answer ("no");
	     else call set_answer (big_str);
	end;

	else call set_answer (big_str);

	repeat_flag = saved_rflag;
	repeat_label = saved_rlabel;

	if alloc_sw then free alloc_str in (area);

          if multi_line_sw & ^ending_delim_found then
            goto GET_LINE;

	return;

%page;
/* INTERNAL PROCEDURES */

set_answer: proc (P_str);

dcl P_str                      char (*);

          if multi_line_sw then do;
	   if P_str = query_info.ending_delim then do;
	      ending_delim_found = True;
	      goto end_answer;
	   end;
	   goto add_to_answer;
	end;

	if fixed_answer_sw then 
            fixed_answer = P_str;
	else
            varying_answer = P_str;

          goto end_answer;

add_to_answer:
  
          if fixed_answer_sw then do;
	   if Lanswer + 1 > length(fixed_answer) then do;
	      call iox_$control (question_info.answer_iocbp, "reset_more", null(), (0));
	      call ioa_ ("Overflow condition - some data may have been lost.");
	      ending_delim_found = True;
	   end;
             else if Lanswer + length(P_str) + length(NL) > length(fixed_answer) then do;
	      substr(fixed_answer,Lanswer+1) = NL || P_str;
	      call iox_$control (question_info.answer_iocbp, "reset_more", null(), (0));
	      call ioa_ ("Overflow condition - some data may have been lost.");
	      ending_delim_found = True;
             end;
	   else if Lanswer = 0 then do;
	      substr(fixed_answer,1) = P_str;
	      Lanswer = length(P_str);
             end;
	   else do;
                substr(fixed_answer,Lanswer+1) = NL || P_str;
                Lanswer = Lanswer + length(P_str) + length(NL);
            end;
          end;
	else do;
	   if length(varying_answer) + length(P_str) + length(NL) > maxlength(varying_answer) then do;
	      varying_answer = varying_answer || NL || P_str;
	      call iox_$control (question_info.answer_iocbp, "reset_more", null(), (0));
	      call ioa_ ("Overflow condition - some data may have been lost.");
	      ending_delim_found = True;
             end;
             else
               if varying_answer = "" then
                 varying_answer = P_str;
	     else
                 varying_answer = varying_answer || NL || P_str;
          end;
	
end_answer:
end set_answer;
%page;
clean_up:
     procedure ();

	if timer_set then call timer_manager_$reset_alarm_call (repeat_query);
	repeat_flag = saved_rflag;
	repeat_label = saved_rlabel;

	if alloc_ptr ^= null then free alloc_ptr -> alloc_str in (area);

     end clean_up;

%page;
/* Substitutes arugments into explanation control string and builds retstring */

expand_explanation:
     procedure ();

dcl  1 arg_list aligned based (alp),
       2 arg_count fixed bin (17) unaligned unsigned,
       2 code bit (19) unaligned,
       2 desc_count fixed bin (17) unaligned unsigned,
       2 mbz bit (19) unaligned,
       2 arg_ptrs (arg_count) ptr,
       2 display_ptr (bin ((arg_list.code & bit (10, 19)) ^= ""b), 1) ptr,
       2 desc_ptrs (arg_count) ptr;

/* For $yes_no, explanation is an argument */

	if yn_entry_sw then
	     call ioa_$general_rs (alp, control_string_index - 1, control_string_index + 1, retstring, len, "0"b, "0"b);

/* Otherwise, have to build an argument list containing it */

	else begin;

dcl  1 new_arg_list aligned,
       2 arg_count fixed bin (17) unaligned unsigned,
       2 code bit (19) unaligned,
       2 desc_count fixed bin (17) unaligned unsigned,
       2 mbz bit (19) unaligned,
       2 arg_ptrs (arg_list.arg_count) ptr,
       2 display_ptr (bin ((arg_list.code & bit (10, 19)) ^= ""b), 1) ptr,
       2 desc_ptrs (arg_list.arg_count) ptr;

%include descriptor;

dcl  desc_size fixed bin (24) unaligned unsigned based (addr (desc_.scale_));

	     new_arg_list = arg_list;			/* replace question arg with explanation arg */
	     desc_.version2_ = "1"b;
	     desc_.type_ = char_dtype;
	     desc_.pack_ = "1"b;
	     desc_.dimension_ = "0"b;

	     desc_size = length (explanation);

	     new_arg_list.desc_ptrs (control_string_index) = addr (desc_);
	     new_arg_list.arg_ptrs (control_string_index) = addr (explanation);

	     call ioa_$general_rs (addr (new_arg_list), control_string_index, control_string_index + 1, retstring, len,
		"0"b, "0"b);

	end;

     end expand_explanation;

%page;
print_question: proc;

PRINT_QUESTION:
	     if query_info.suppress_spacing then do;
		call iox_$put_chars (question_info.question_iocbp, question_info.question_ptr,
		     (question_info.question_lth), code);
		if code ^= 0 then do;
QUESTION_ERROR:
		     call sub_err_ (code, callername, ACTION_CAN_RESTART, null, 0, "Writing question.");
		     go to PRINT_QUESTION;
		end;
	     end;
	     else do;
		substr (output_buffer, 1, 1) = NL;
		substr (output_buffer, 2, (bi - 1) + length(SPACE_SPACE)) =
		     question;
		if multi_line_sw then
		     call iox_$put_chars (question_info.question_iocbp, addr (output_buffer),
			(bi - 1) + length(NL), code);
		else
		     call iox_$put_chars (question_info.question_iocbp, addr (output_buffer),
			(bi - 1) + length(NL) + length(SPACE_SPACE),
			code);
		if code ^= 0 then go to QUESTION_ERROR;
	     end;

end print_question;
%page;

/* Repeat the last question and ask for the answer again */

repeat_query:
rq:
     entry () options (variable);

	if first_call then do;			/* be sure the labels are correctly defined */
	     repeat_label = ASK;			/* basis for saved label */
	     repeat_flag = "0"b;
	     first_call = "0"b;			/* done for this process */
	end;

	if repeat_flag then
	     go to repeat_label;
	else call com_err_ (0, "repeat_query", "No pending query.");

	return;

%page;
/* ENTRYPOINT */

/* Enable/disable use of the command processor escape */

set_cp_escape_enable:
     entry (new_allow_cp_escape, old_allow_cp_escape);

dcl  new_allow_cp_escape bit (1) aligned parameter;	/* whether it is enabled now */
dcl  old_allow_cp_escape bit (1) aligned parameter;	/* was it enabled before? */

	old_allow_cp_escape = static_allow_cp_escape;
	static_allow_cp_escape = new_allow_cp_escape;

	return;

%page;
/* INCLUDE FILES */

%include hcom_query_info;
%page;
%include command_question_info;
%page;
%include condition_info_header;
%page;
%include std_descriptor_types;
%page;
%include sub_err_flags;

end hcom_command_query_;




		    hcom_default_validate_.pl1      06/05/86  1135.6rew 06/05/86  1121.2       82422



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     The default validation program.
  2) change(86-05-01,LJAdams), approve(86-05-19,MCR7386),
     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
     Added error message parameter.
                                                   END HISTORY COMMENTS */

hcom_default_validate_:
     proc (P_caller, P_field_name, P_input_value, P_result, P_canonical_value, P_field_type, P_err_msg);

/* *	HCOM_DEFAULT_VALIDATE_
   *
   *	This is the default procedure used to validate values placed in
   *      fields of a history comment or installation description.  
   *
   *	The validation procedure takes an input value to validate, and 
   *	returns a bit indicating the validity.  The name of the field is
   *	supplied to determine what sort of validation will be applied,
   *	and the name of the calling procedure is supplied for use in 
   *	error messages and questions.  An error message is always printed
   *	when the field value is invalid, so the caller of the validation
   *	routine need never print one.
   *
   *	In addition to the valid/invalid result, this procedure also
   *	returns the canonical form of the field value (making appropriate
   *	case translations, etc.), the field type (a character string 
   *	whose value depends on the field itself).
   *
   *	The DEFAULT validation procedure makes the following checks:
   *
   *	"author" field
   *         Validated for "correct" syntax and length restriction
   *	"approval" field
   *	   Validated for "correct" syntax and length restriction
   *	"audit" field
   *         Validated for "correct" syntax and length restriction
   *	"install" field
   *	   At present, validated for syntax only: MRnn.n-####
   *	Other fields
   *	   Always rejected.
   */

/* 85-06-04, Sibert: Initial coding */
/* 85-06-21, Sibert: Name change, creation of $check and $check_long,
   syntactic validation of person IDs */
/* 85-07-01, Adams:  Creation of default version for individual sites */

declare   P_caller char (*) varying parameter;		/* INPUT: Name of validation procedure's caller */
declare   P_field_name char (*) varying parameter;	/* INPUT: Name of field to be validated */
declare   P_input_value char (*) varying parameter;	/* INPUT: Value to be checked for validity */
declare   P_result bit (1) aligned parameter;		/* OUTPUT: Whether input was valid or not */

declare   P_canonical_value char (*) varying parameter;	/* OUTPUT: Canonical text form of above */
declare   P_err_msg char (100) varying parameter;           /* OUTPUT: Error message			*/
declare   P_field_type char (*) varying parameter;	/* OUTPUT: Character prefix of approval value */

declare   UPPERCASE char (26) internal static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
declare   LOWERCASE char (26) internal static options (constant) init ("abcdefghijklmnopqrstuvwxyz");
declare   NAMECASE char (53) internal static options (constant) init
         ("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'");
declare   DIGITS char (10) internal static options (constant) init ("0123456789");
declare   HYPHEN char (1) internal static options (constant) init ("-");

declare  (after, before, index, length, reverse, substr, translate, verify) builtin;

/*  */


CHECK_COMMON:
          P_result = "0"b;                                  /* Initialize output values */
          P_canonical_value = P_input_value;                /* Just return the input in case of error */
          P_field_type = "";                                /* Type-dependent values are returned null */
	P_err_msg = "";

/* Call the appropriate (internal) validation procedure, depending on the
   field name.  These procedures are responsible for setting all output
   parameters, issuing all error messages, and asking questions.  When 
   they return, all the results should be set appropriately, since the
   external procedure just returns at that point.  In particular, they must
   all set P_result, since that has been initialized to "0"b already, above.
   */

	if (P_field_name = AUTHOR_FIELD_NAME) then
               call validate_personid (AUTHOR_FIELD_NAME);
	else if (P_field_name = APPROVAL_FIELD_NAME) then
	     call validate_approval ();
	else if (P_field_name = AUDIT_FIELD_NAME) then
               call validate_personid (AUDIT_FIELD_NAME);
	else if (P_field_name = INSTALL_FIELD_NAME) then
	     call validate_install ();
	else 
	     P_err_msg = "Invalid field name";
	

CHECK_RETURNS:
	return;                             	/* All done */


validate_personid:
     procedure (P_type);

declare   P_type char (*) varying parameter;                /* "author" or "audit" -- not used in this implementation */

/* Ideally, perhaps, this would check the person ID against a little database of valid
   values, giving the updater the opportunity to accept or reject one that wasn't
   found.  It could even translate initials or nicknames to the real name. For now,
   though, all it does is make a trivial syntactic check that isn't even correct
   in all cases (deJong, for instance).  This represents an opportunity for people
   to modify this routine to be spiffier. */


          if (length (P_input_value) < 2) then              /* Between 2 and 24 characters */
               P_result = "0"b;
          else if (length (P_input_value) > 24) then
               P_result = "0"b;
          else if verify (P_input_value, NAMECASE) ^= 0 then
               P_result = "0"b;                             /* And be all alphabetic or contain ' */
          else P_result = "1"b;                             /* Otherwise, it's OK */

          return;
          end validate_personid;

/*  */

validate_approval:
     procedure ();


          if (length (P_input_value) = 0) then
            call invalid_approval ("Approval must not be null");
          else
            if (length (P_input_value) > 24) then
              call invalid_approval ("Approval must not be longer than 24");

          P_result = "1"b;                                  /* It's valid */

	return;
          end validate_approval;
       

/*  */

invalid_approval:
     procedure (P_message);

declare   P_message char (*) parameter;

/* This procedure prints an error message and returns a false result,
   for use when the value is invalid */


          P_err_msg = P_message;
	P_result = "0"b;				/* Invalid */
	goto CHECK_RETURNS;

	end invalid_approval;


/*  */

validate_install:
     procedure ();

declare   install_id char (24) varying;
declare   part_1 char (24) varying;
declare   part_2 char (24) varying;
declare   release_suffix char (1) varying;

/* Validate syntax of installation ID:
   - Must begin with "MR"
   - Must be followed by a number, optional decimal point and decimal,
     and optional suffix letter.
   - Must then be followed by a hyphen and following decimal number. 
   */


	install_id = translate (P_input_value, UPPERCASE, LOWERCASE);
	if (index (install_id, HYPHEN) = 0) then	/* Be sure it's hyphenated somewhere */
	     goto INVALID_INSTALL_ID;

	part_1 = before (install_id, HYPHEN);		/* And that it has something before and after the hyphen */
	part_2 = after (install_id, HYPHEN);

	if (length (part_1) < 3) then			/* Must have enough room for MRn, at least */
	     goto INVALID_INSTALL_ID;

	if (substr (part_1, 1, 2) ^= "MR") then		/* Must start with MR release identifier */
	     goto INVALID_INSTALL_ID;

/* Here, we check to see whether there is a suffix letter (as in MR7.0a), 
   and if so, we strip it out, translate to lowercase, and continue. */

	if (index (UPPERCASE, substr (reverse (part_1), 1, 1)) ^= 0) then do;
	     release_suffix = substr (reverse (part_1), 1, 1);
	     release_suffix = translate (release_suffix, LOWERCASE, UPPERCASE);
	     part_1 = substr (part_1, 1, (length (part_1) - 1));
	     if (length (part_1) < 3) then		/* Must still be something besides "MR" left */
		goto INVALID_INSTALL_ID;
	     end;
	else release_suffix = "";			/* None, otherwise */

	if (verify (substr (part_1, 3), "0123456789.") ^= 0) then
	     goto INVALID_INSTALL_ID;			/* Only digits and decimal point "MR" */

	if (part_2 = "") then			/* Must be something there */
	     goto INVALID_INSTALL_ID;

	if (verify (part_2, DIGITS) ^= 0) then
	     goto INVALID_INSTALL_ID;

	P_canonical_value = part_1 || release_suffix || HYPHEN || part_2; 
	P_result = "1"b;				/* It's valid; there is no other info to return */
	return;



INVALID_INSTALL_ID:
          P_err_msg = "Installation id must be of the form MRxx.y-nnnn.";
	P_result = "0"b;				/* Invalid, sorry */
	return;
	end validate_install;

%page; %include hcom_field_names;

end hcom_default_validate_;




		    hcom_parse_.rd                  04/26/87  1557.5rew 04/26/87  1557.5      184365



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1985 *
   *                                                         *
   *********************************************************** */

/* HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     Parses and validates the history comments.
  2) change(86-04-17,LJAdams), approve(86-05-19,MCR7386),
     audit(86-05-19,Gilcrease), install(86-06-05,MR12.0-1071):
     Added error message parameter for validate programs.  Changed so
     that only 1 error message is put out for all programs called.
  3) change(86-08-28,LJAdams), approve(86-08-28,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     error_msg was not getting initialized  which resulted in garbage being
     displayed.  Set d.Scfix to True when first critical fix number is
     encountered; thereby preventing addition of non-critical fix numbers.
  4) change(87-03-26,LJAdams), approve(87-03-26,MCR7653),
     audit(87-04-22,Gilcrease), install(87-04-26,MR12.1-1026):
     If comment is greater than max length allowed put char value of
     comment length in src_array_comment.err_msg.
  5) change(87-03-30,LJAdams), approve(87-03-30,MCR7653),
     audit(87-04-22,Gilcrease), install(87-04-26,MR12.1-1026):
     Put in check for pre-b2 cmts must have null approve, null audit, and null
     install fields present.
                                                   END HISTORY COMMENTS */

hcom_parse_:
  proc (ERROR_RETURN_LABEL, seg, cmt, path, Sprt_path, Pd, src_array_comment, code);

dcl ERROR_RETURN_LABEL         label parameter,
    seg	                     char(*),
    cmt			 char(*),
    code			 fixed bin(35),
    path			 char(*),
    Sprt_path		 bit(1);

/*++
INCLUDE                        ERROR\

BEGIN 

           / <decimal-integer> ) change ( <date> , <change_pers> ) /
                               [src_array_comment.comment_no = token.Nvalue]
			 LEX(4)
			 [src_array_comment.change_dt = date_out] 
			 LEX(2)
			 [src_array_comment.change_person = person]
			 LEX(2)
                               / punct \

           / <decimal-integer> ) change ( <date> , <change_pers> <any-token> /
                               LEX(7)
			 MY_ERROR(19) / RETURN \
           / <decimal-integer> ) change ( <date> , <any-token> /
                               LEX(6)
			 MY_ERROR(3) / RETURN \
           / <decimal-integer> ) change ( <any-token> /
	                     LEX(4)
	                     MY_ERROR(2) / RETURN \
           / <any-token> )     / MY_ERROR(1) / RETURN \
	 / <any-token>	 / MY_ERROR(4) / RETURN \
	 / <no-token>	 / MY_ERROR(5) / RETURN \

punct 	 / :		 / LEX
			 set_text 
			 / RETURN \
           / ,		 / LEX
			 / opt \
           / <any-token>       / MY_ERROR(6) /RETURN \
           / <no-token>        / MY_ERROR(7) /RETURN \

opt        / approve (         / 
			 / opt_arg \
	 / audit (           /
                               / opt_arg \
	 / install (         /
                               / opt_arg \
           / <any-token> (     / MY_ERROR(16) /RETURN\
           / <any-token>       / MY_ERROR(17) /RETURN \
           / <no-token>        / MY_ERROR(18) /RETURN \

opt_arg	 / approve ()        /
                               [src_array_comment.approve_dt = "^"]
			 [src_array_comment.approve_value = ""]
                               [null_approve = True]
			 LEX(3)
			 / punct \
	 \" The reduction above allows comments created prior to existence of
	 \" hcom command to appear to have a nonempty approve field, even
	 \" those no date or approval value is known/specified.  The ^ date
	 \" value makes comments with such a field match the approve comment
	 \" specifier.
	 / approve ( <date> , <apv_id> ) /
			 LEX(2)
			 [src_array_comment.approve_dt = date_out]
			 LEX(2)
			 [src_array_comment.approve_value = ident] 
                               LEX(2)
                               / punct \  
           / audit ()          /
                               [src_array_comment.audit_dt = "^"]
			 [src_array_comment.audit_person = ""]
			 [null_audit = True]
			 LEX(3)
			 / punct \
	 \" Allow pre-hcom comments with unknown audit fields to appear
	 \" to be audited.
           / audit ( <date> , <audit_pers> ) /
			 LEX(2)
			 [src_array_comment.audit_dt = date_out]
			 LEX(2)
			 [src_array_comment.audit_person = person] 
			 LEX(2)
                               / punct \  
           / install ()        /
                               [src_array_comment.install_dt = "^"]
			 [src_array_comment.install_id = ""]
			 [null_install = True]
			 LEX(3)
			 / punct \
	 \" Allow pre-hcom comments with unknown install fields to appear
	 \" to be installed.
           / install ( <date> , <install_id> ) /
			 LEX(2)
			 [src_array_comment.install_dt = date_out]
			 LEX(2)
			 [src_array_comment.install_id = ident] 
			 LEX(2)
                               / punct \  
           / approve ( <date> , <apv_id> <any-token> /
                               LEX(5)
			 MY_ERROR(19) / RETURN \
           / approve ( <date> , <any-token> /
                               LEX(4)
			 MY_ERROR(11) / RETURN \
           / approve ( <any-token> /
                               LEX(2)
                               MY_ERROR(10) / RETURN \
           / approve <any-token> /
                               LEX
                               MY_ERROR(6) / RETURN \
           / audit ( <date> , <audit_pers> <any-token> /
                               LEX(5)
			 MY_ERROR(19) / RETURN \
           / audit ( <date> , <any-token> /
                               LEX(4)
			 MY_ERROR(13) / RETURN \
           / audit ( <any-token> /
                               LEX(2)
			 MY_ERROR(12) / RETURN \
           / audit <any-token> /
                               LEX
                               MY_ERROR(6) / RETURN \
           / install ( <date> , <install_id> <any-token> /
                               LEX(5)
                               MY_ERROR(19) / RETURN \			 
           / install ( <date> , <any-token> /
                               LEX(4)
                               MY_ERROR(15) / RETURN \			 
           / install ( <any-token> /
                               LEX(2)
			 MY_ERROR(14) / RETURN \
           / install <any-token> /
                               LEX
                               MY_ERROR(6) / RETURN \
           / <any-token>	 / MY_ERROR(8) / RETURN \
  	 / <no-token>	 / MY_ERROR(9) / RETURN \
++*/

/* close set of reductions   */

%include hcom_data;

dcl 1 src_array_comment   aligned like src_array.comments;

dcl 1 error_control_table (19) internal static options (constant),
      2 severity               fixed bin (17) unal init ((19) 3),
      2 Soutput_stmt	 bit(1) unal init ((19) (1) "1"b),
      2 message		 char(80) varying init (
      /* ERROR 1*/             "The history comment number (^a) is not a decimal number.",
      /* ERROR 2*/             "The history comment contains an invalid date (^a).",
      /* ERROR 3*/             "The history comment contains an invalid person id (^a).",
      /* ERROR 4*/             "The history comment contains an incorrect line.",
      /* ERROR 5*/             "The history comment is empty.",
      /* ERROR 6*/             "The history comment contains invalid punctuation (^a).",
      /* ERROR 7*/		 "The history comment contains no punctuation",
      /* ERROR 8*/		 "The history comment contains an invalid option (^a).",
      /* ERROR 9*/		 "The history comment ends improperly before the summary.",
      /* ERROR10*/             "The approve date (^a) is invalid.",
      /* ERROR11*/		 "The approve value (^a) is invalid.",
      /* ERROR12*/		 "The audit date (^a) is invalid.",
      /* ERROR13*/		 "The audit person (^a) is invalid.",
      /* ERROR14*/		 "The install date (^a) is invalid.",
      /* ERROR15*/		 "The install id (^a) is invalid.",
      /* ERROR16*/             "The history comment has an invalid option name (^a).",
      /* ERROR17*/             "The history comment is missing left parenthesis.",
      /* ERROR18*/             "The history comment ends with invalid punctuation (^a).",
      /* ERROR19*/             "The history comment is missing right parenthesis"),
      2 brief_message	 char(4) varying init((19) (1) " ");
  
dcl 1 cond_info                aligned like condition_info;

dcl com_err_	           entry() options(variable);

dcl error_table_$bigarg	 fixed bin(35) ext static;
dcl error_table_$improper_data_format
			 fixed bin(35) ext static;

dcl find_condition_info_	 entry (ptr, ptr, fixed bin(35));

dcl hcom_cfix_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1),
                                             char(*) var, char(*) var, char(100) var);

dcl hcom_site_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1) aligned,
				     char(*) var, char(*) var, char(100) var);

dcl hcom_default_validate_	 entry (char(*) var, char(*) var, char(*) var, bit(1) aligned,
				     char(*) var, char(*) var, char(100) var);

dcl lex_string_$init_lex_delims
                               entry (char(*), char(*), char(*), char(*), char(*), bit(*),
				     char(*) var, char(*) var, char(*) var, char(*) var);

dcl lex_string_$lex		 entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*), char(*),
                                             char(*), char(*), char(*), char(*), char(*) var, char(*) var,
			               char(*) var, char(*) var, ptr, ptr, fixed bin(35));

dcl LEXDLM                     char(128) varying internal static,
    LEXCTL		 char(128) varying internal static;

dcl convert_date_to_binary_	 entry (char(*), fixed bin(71), fixed bin(35)),
    date_time_$format	 entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
    ioa_			 entry() options(variable),
    pathname_$component	 entry (char(*), char(*), char(*)) returns(char(194)),
    translator_temp_$get_segment 
                               entry (char(*), ptr, fixed bin(35)),

    translator_temp_$release_all_segments 
                               entry (ptr, fixed bin(35));

dcl error_table_$translation_failed 
			fixed bin(35) ext static;
dcl (addr,
     addcharno,
     charno,
     char,
     dimension,
     index,
     length,
     maxlength,
     null,
     reverse,
     substr,
     verify)          	 builtin;

dcl  proc_ptr		 ptr,
     Ccode		 fixed bin(35);

dcl  BREAKS                    char(9) varying int static options(constant) init ("	 (),:
");
     /* break characters consist of HT,VT,SP,RP,LP,CM,CLN,NL,NP  */  
dcl IGBREAKS                   char(5) varying int static options(constant) init("	 
");
     /* ignore break characters consist of HT,VT,NP,SP,NL    */

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


dcl APstmt                     ptr,
    APtoken		 ptr;

dcl Lignore		 fixed bin(21);

dcl (cleanup, command_question)  condition;

dcl True			 bit(1) internal static options (constant) init("1"b),
    False			 bit(1) internal static options (constant) init("0"b);

dcl (null_approve,
     null_audit,
     null_install)               bit (1);

dcl valid			 bit(1),
    Serrors		 bit(1);

dcl error_msg                  char(100) varying;

Serrors = False;
error_msg = "";

null_approve, null_audit, null_install = False;

if ^d.ag.ctl.errors then
   MIN_PRINT_SEVERITY = 4;

proc_ptr = null;
on cleanup
  call JANITOR();
  
Lignore = charno(addr(cmt)) - charno(addr(seg));

call translator_temp_$get_segment (CALLER, proc_ptr, code);
if code ^= 0 then 
  call JANITOR;

	/* BREAKS consist of HT VT SP RP LP CM NL NP                */
	/* IGBREAKS to ignore consist of HT VT NP SP NL             */

call lex_string_$init_lex_delims ("","","","","","11"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);

call lex_string_$lex (addr(seg), length(cmt)+Lignore, Lignore, proc_ptr, "0000"b,"","","","","",BREAKS,
  IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);

Pthis_token = APtoken;

call SEMANTIC_ANALYSIS ();

if Serrors then 
  if d.ag.ctl.errors then
     call ioa_("^/^a",cmt);

if MERROR_SEVERITY > 0 then
  if code = 0 then
    code = error_table_$translation_failed;
call JANITOR;
return;

JANITOR:
  proc;
  if proc_ptr ^= null then
    call translator_temp_$release_all_segments (proc_ptr, Ccode);
  proc_ptr = null;
  
  if Serrors then
     goto ERROR_RETURN_LABEL;

end JANITOR;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


/* RELATIVE SYNTAX FUNCTIONS  */

dcl clock_time			fixed bin(71),
      date_out			char(8) aligned;

date:
  proc () returns(bit(1) aligned);

  dcl code			fixed bin(35);

  call convert_date_to_binary_(token_value,clock_time,code);
  if code ^= 0 then
     return(False);

  date_out = date_time_$format("^yc-^my-^dm",clock_time,"","");
  return(code=0);
  
end date;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

  dcl person			char(24) var,
      ident			char(24) var;


audit_pers:
  proc() returns(bit(1) aligned);
  
  on command_question
     begin;
        call set_command_question;
        end;

  if d.ag.op.name = REPLACE_FIELD then			/* dont validate fields being replaced		*/
     if d.ag.input.select.aud = OPERANDxxx |
        d.ag.input.select.aud = INPUTxxx then do;
        person = token_value;
        return("1"b);
        end;

  call d.ag.vdt ((CALLER), AUDIT_FIELD_NAME, (token_value), valid, person, "",error_msg);

  return(valid);
  
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

change_pers:
  entry() returns(bit(1) aligned);
  
  on command_question
     begin;
        call set_command_question;
        end;
  call d.ag.vdt ((CALLER), AUTHOR_FIELD_NAME, (token_value), valid, person, "", error_msg);

  return(valid);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

apv_id:
  entry() returns(bit(1) aligned);

  if d.ag.op.name = REPLACE_FIELD then		/* dont validate fields being replaced		*/
        if d.ag.input.select.apv = OPERANDxxx |
           d.ag.input.select.apv = INPUTxxx then do;
           ident = token_value;
           return("1"b);
	 end;

  if index(token_value,"fix_") > 0 then do;
     Scfix_found = True;
     d.Scfix_found = True;
     end;

  on command_question
     begin;
     call set_command_question;
     end;
  
  if Scfix_found then
     d.ag.vdt = hcom_cfix_validate_;
  else if d.Ssite then
     d.ag.vdt = hcom_site_validate_;
  else
     d.ag.vdt = hcom_default_validate_;

  call d.ag.vdt ((CALLER), APPROVAL_FIELD_NAME, (token_value), valid, ident, "", error_msg);

  return(valid);
    

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

install_id:
  entry() returns(bit(1) aligned);
  
  if d.ag.op.name = REPLACE_FIELD then			/* dont validate fields being replaced		*/
     if d.ag.input.select.in = OPERANDxxx |
        d.ag.input.select.in = INPUTxxx then do;
        ident = token_value;
        return ("1"b);
        end;

  if Scfix_found then do;
     call hcom_cfix_validate_((CALLER), INSTALL_FIELD_NAME, (token_value), valid, ident, "", error_msg);
     return(valid);
     end;

  on command_question
     begin;
     call set_command_question;
     end;

  call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME, (token_value), valid, ident, "", error_msg);
  
  return(valid);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
set_command_question:
  proc;

dcl answer		 char(command_question_info.answer_lth)
			 based(command_question_info.answer_ptr);

  revert command_question;
  cond_info.version = condition_info_version_1;
  call find_condition_info_ (null, addr(cond_info), code);
  cq_info_ptr = cond_info.info_ptr;
  if command_question_info.yes_or_no_sw & 
     command_question_info.max_answer_lth >= length("yes") then do;
     command_question_info.preset_sw = True;
     command_question_info.question_sw = False;
     command_question_info.answer_sw = False;
     command_question_info.answer_lth = length("yes");
     answer = "yes";
     end;
end set_command_question;

RETURN_FALSE:
  
  return(False);

end audit_pers;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


/* ACTION ROUTINES */

MY_ERROR:
  proc(err_no);

  dcl err_no			fixed bin;

  Serrors = True;

  if ^Sprt_path then do;
     if d.ag.ctl.errors then
        call ioa_("^a",path);
     Sprt_path = True;
     end;
  
  if d.Saf then
     call d.set_return_arg ("false");

  if code = error_table_$bigarg then
     call com_err_ (code, CALLER,
     "^a^/^3xComment ^d is longer than ^d characters.",
     pathname_$component(seg.dir,seg.ent,seg.comp),src_array_comment.comment_no,maxlength(d.ag.input.summary));

  call ERROR(err_no);
  if error_msg ^= "" then
     call ioa_("^3x^a",error_msg);

  return;
  
end MY_ERROR;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


set_text:
  proc;
  dcl text                     char(Ltext) based(Ptext),
      Ptext		 ptr,
      Ltext		 fixed bin(21),
      text_arr (Ltext)         char(1) based(Ptext),
      Ptext_line		 ptr,
      Ltext_line		 fixed bin(21),
      text_line		 char(Ltext_line) based(Ptext_line),
      i			 fixed bin(21),
      Iline		 fixed bin(21),
      HT_SP_NL_VT              char(4) int static options(constant) init("	 
"),
      HT_SP_VT                 char(3) int static options(constant) init("	 "),
      SPACES                   char(5) int static options(constant) init("     "),
      NL			 char(1) int static options(constant) init("
");
  
  
  if null_approve & null_audit & ^null_install then do;	/* check to be sure old cmts are properly	*/
						/* formatted.				*/
     src_array_comment.err_msg(1) =  char(error_table_$improper_data_format);
     return;
     end;
            
  Ptext = (addr(cmt));				/* determine if there is any leading wt space	*/
  Ltext = charno(addr(token_value)) - charno(addr(cmt));
  i = verify(reverse(text),HT_SP_VT);
  Ltext = Ltext - i;

  Ptext = addcharno (addr(text_arr(Ltext)), length(NL)+1);	/* charno is offset 0			*/
  
  Ltext = length(cmt) - (charno(Ptext) - charno(addr(cmt)));
  
  if Ltext > maxlength(d.ag.input.summary) then do;
     src_array_comment.err_msg(1) = char(error_table_$bigarg);
     src_array_comment.err_msg(2) =  char(Ltext);
     Ltext = maxlength(d.ag.input.summary);
     end;

  do while(Ltext > 0 & verify(text,HT_SP_NL_VT) ^= 0);
     Iline = index(text,NL);
     if Iline = 0 then do;
        Ptext_line = Ptext;
        Ltext_line = length(text);
        Ltext = 0;
        end;
     else do;
        Ptext_line = Ptext;
        Ltext_line = Iline;
        if Ltext > Iline then
	 Ptext = addr(text_arr(Iline+1));
        Ltext = Ltext - Iline;
        end;

     if verify(text_line,HT_SP_NL_VT) = 0 then		/* nothing but white space			*/
        src_array_comment.summary = src_array_comment.summary || text_line;
     else if substr(text_line,1,5) = SPACES then
						/* hcom_process_seg_ indents every line but the	*/
						/* first five spaces.			*/
        src_array_comment.summary = src_array_comment.summary || substr(text_line,6);
     else	do;					/* if not using hcom to format spacing may differ */
        i = verify(text_line," ");
        src_array_comment.summary = src_array_comment.summary || substr(text_line,i);
        end;
     end;

end set_text;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
%include condition_info_header;

%include condition_info;

%include command_question_info;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include hcom_field_names;





		    hcom_process_path_.pl1          04/26/87  1557.5rew 04/26/87  1553.4      195579



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     Program to process the pathnames(archive or
     non-archive) passed from the history comment program.
  2) change(85-11-13,LJAdams), approve(85-11-13,MCR7278),
     audit(86-02-19,Gilcrease), install(86-02-19,MR12.0-1021):
     In "process_star_name" added check to not process directories only
     segments.
  3) change(86-08-27,LJAdams), approve(86-08-27,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     In process_archive_comp routine changed arch_janitor so that d.seg.Pseg is
     always reset to Pseg so that if an error occurred archive_$next_component
     will have the proper component ptr as input.
  4) change(87-03-17,LJAdams), approve(87-04-22,MCR7653),
     audit(87-04-02,Gilcrease), install(87-04-26,MR12.1-1026):
     Fixed problem with no error message being displayed if a nonexistant
     component was asked for in an archive.  (phx20689)
                                                   END HISTORY COMMENTS */

hcom_process_path_:
     proc (Pd);

/*  B U I L T I N  */
	dcl     (addr, before, divide, null, reverse, sum)
				 builtin;


/*  C O N D I T I O N S  */
	dcl     cleanup		 condition;


/*  E X T E R N A L   E N T R I E S  */
	dcl     access_$reset	 entry (ptr, fixed bin (35)),
	        access_$set_temporarily entry (char (*), char (*), fixed bin (2), bit (*), ptr, fixed bin (35)),
	        archive		 entry options (variable),
	        archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35)),
	        check_star_name_$entry entry (char (*), fixed bin (35)),
	        expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)),
	        get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (32), char (32),
				 fixed bin (35)),
	        get_pdir_		 entry () returns (char (168)),
	        get_system_free_area_	 entry () returns (ptr),
	        hcom_process_seg_	 entry (ptr, label),
	        hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr,
				 fixed bin (35)),
	        hcs_$status_mins	 entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)),
	        initiate_file_	 entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)),
	        initiate_file_$component entry (char (*), char (*), char (*), bit (*), ptr, fixed bin (24),
				 fixed bin (35)),
	        initiate_file_$create	 entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24),
				 fixed bin (35)),
	        match_star_name_	 entry (char (*), char (*), fixed bin (35)),
	        pathname_		 entry (char (*), char (*)) returns (char (168)),
	        pathname_$component	 entry (char (*), char (*), char (*)) returns (char (194)),
	        terminate_file_	 entry (ptr, fixed bin (24), bit (*), fixed bin (35));


/*  N A M E D    C O N S T A N T S */
	dcl     BITS_PER_CHAR	 fixed bin int static options (constant) init (9);
          dcl     FALSE                  bit (1) int static options (constant) init ("0"b);
          dcl     TRUE		 bit (1) int static options (constant) init ("1"b);
     

/*  E X T E R N A L   S T A T I C  */
	dcl     (error_table_$bad_arg,
	        error_table_$badstar,
	        error_table_$no_component,
	        error_table_$no_w_permission,
	        error_table_$zero_length_seg)
				 fixed bin (35) ext static;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* Name: hcom_process_path_							*/
/*									*/
/* Overall module structure:							*/
/*									*/
/*                           hcom_process_path_					*/
/*		                 |						*/
/*          	       call process_star_name();				*/
/*		                 |						*/
/*		       call process_seg_by_case();				*/
/*			       |						*/
/* 		SELECTED SEG ENTRYNAME AND COMPONENT NAME			*/
/* 	     NONARCHIVE	ONE ARCHIVE COMP	 STAR ARCHIVE COMP			*/
/*	     =====================================================			*/
/*	           |                |                  |				*/
/*	           |	  call process_archive_comp();			*/
/*	           |	        |						*/
/*	         call process_one_seg();					*/
/*									*/
/* The modules are shown in the code below in the order shown above.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* hcom_process_path_:							*/
/*									*/
/* This is the starting point in processing pathnames (both source and -original paths).	*/
/* This initial section of code is responsible for expanding the source and original	*/
/* paths into absolute, archive pathnames.  The code then calls process_star_name, for	*/
/* both star and nonstar entrynames.						*/
/*									*/
/* The input paths are in d.source and d.orig structures, and the expanded dir/ent/comp	*/
/* are placed in those structures as well.					*/
/* If errors have occurred the label ERROR_RETURN_LABEL is being used to activate the	*/
/*    cleanup handlers invoked by those programs that are being wiped off the stack by the*/
/*    unwinder as it does a non-local "goto" to the label specified by the calling program*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


	dcl     code		 fixed bin (35);

	call expand_pathname_$component (d.source.path, d.source.dir, d.source.ent, d.source.comp, code);
	call d.check_error$fatal (code, CALLER, "^/^a", d.source.path);

	if d.orig.path ^= "" then do;
		call expand_pathname_$component (d.orig.path, d.orig.dir, d.orig.ent, d.orig.comp, code);
		call d.check_error$fatal (code, CALLER, "^/-orig ^a", d.orig.path);
	     end;

	call process_star_name ();
	return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* process_star_name:							*/
/*									*/
/* This procedure examines the source entryname to determine if it is a starname.  For a	*/
/* nonstar entryname, it moves source d.source.dir/ent/comp into d.seg_arch.dir/ent/comp	*/
/* and calls process_seg_by_case.						*/
/*									*/
/* For a star entryname, this procedure expands the entryname into one or more matching	*/
/* segments in the given source dir.  The segments may be either archives or nonarchive	*/
/* segments.  For each matching segment, d.seg_arch.dir/ent/comp is filled in to	*/
/* identify the matching segment, and process_seg_by_case is called to process that	*/
/* segment.  The procedure is responsible for cleaning up allocations made by hcs_$star_	*/
/* in processing the starname.						*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

process_star_name:
     proc;

	dcl     Ientry		 fixed bin,
	        Parea		 ptr,
	        code		 fixed bin (35);

	dcl     area		 area based (Parea);

	call check_star_name_$entry (d.source.ent, d.source.ent_type);
	if d.source.ent_type = error_table_$badstar then
	     call d.check_error$fatal (d.source.ent_type, CALLER, "^/^a",
		d.source.path);

	if d.source.ent_type = NONSTAR then do;
		d.seg_arch = d.source, by name;
		call process_seg_by_case (NON_STAR_RETURN);
NON_STAR_RETURN:
		return;
	     end;

	Parea = get_system_free_area_ ();
	star_entry_ptr, star_names_ptr = null;
	on cleanup call star_janitor ();

	call hcs_$star_ (d.source.dir, d.source.ent, star_BRANCHES_ONLY, addr (area),
	     star_entry_count, star_entry_ptr, star_names_ptr, code);
	call d.check_error$fatal (code, CALLER,
	     "^/(^a)^/^3xListing entries matching source path.",
	     pathname_ (d.source.dir, d.source.ent));

	d.seg_arch.dir = d.source.dir;
	d.seg_arch.comp = d.source.comp;
	do Ientry = 1 to star_entry_count;
	     if star_entries (Ientry).type = star_SEGMENT then do;
		     d.seg_arch.ent = star_names (star_entries (Ientry).nindex);
		     call process_seg_by_case (STAR_RETURN);
		end;
STAR_RETURN:
	end;
	call star_janitor ();
	return;

star_janitor:
     proc;
	if star_entry_ptr ^= null then do;
		free star_names in (area),
		     star_entries in (area);
		star_entry_ptr, star_names_ptr = null;
	     end;
     end star_janitor;

     end process_star_name;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* process_seg_by_case:							*/
/*									*/
/* This procedure receives the name of a single source segment (in			*/
/* d.seg_arch.dir/ent/comp) as its input.  The procedure determines whether the segment	*/
/* is an archive or a nonarchive segment.  For archive segments, it determines whether a	*/
/* star, nonstar or null string archive component name is given.  A null string		*/
/* component name can be given if the entry name explicitly ends with .archive and no	*/
/* archive pathname is given.  In this situation, a component name of "**" is assumed,	*/
/* meaning that all archive components are processed.				*/
/*									*/
/* For nonarchive segments, processing consists of initiating the source file, checking	*/
/* for proper access to perform the specified operation (MODIFY or NO_MODIFY), setting	*/
/* d.seg.dir/ent/Pseg/Lseg_in to identify the segment, and calling process_one_seg.	*/
/*									*/
/* For archive components, processing consists of initiating the archive, checking for	*/
/* proper access to perform the specified operation (MODIFY or NO_MODIFY), applying the	*/
/* star convention on the archive component name, and processing the components which	*/
/* match by setting d.seg.dir/ent/comp/Pseg/Lseg_in and calling process_archive_comp.	*/
/*									*/
/* Cleanup handlers are established to terminate the archive or nonarchive segment, and	*/
/* to restore access if it was forced in order to perform a MODIFY operation.		*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


process_seg_by_case:
     proc (ERROR_RETURN_LABEL);

	dcl     ERROR_RETURN_LABEL	 label variable;

	dcl     Paccess		 ptr,
	        bc		 fixed bin (24),
	        mode		 bit (36),
	        terminate_mode	 bit (5);

	if d.seg_arch.comp = "" then do;		/* no archive component name given.		*/
		if reverse (before (reverse (d.seg_arch.ent), ".")) = "archive" then do;
			d.seg_arch.comp = "**";	/*   an archive, with no component path given, 	*/
			d.seg_arch.comp_type = STARSTAR; /*     means process all components.		*/
		     end;
		else /*   not an archive.			*/
		     d.seg_arch.comp_type = NOCOMP;
	     end;
	else do;					/* archive component name given.		*/
		call check_star_name_$entry (d.seg_arch.comp, d.seg_arch.comp_type);
		if d.seg_arch.comp_type = error_table_$badstar then
		     call d.check_error$fatal (d.seg_arch.comp_type, CALLER, "^/^a",
			d.source.path);		/* Report path in error msg exactly as user typed */
	     end;

	if d.op.type = MODIFY then do;
		mode = RW_ACCESS;
		terminate_mode = TERM_FILE_TRUNC_BC_TERM;
	     end;
	else do;
		mode = R_ACCESS;
		terminate_mode = TERM_FILE_TERM;
	     end;

	Paccess = null;
	d.seg_arch.Pseg = null;
	on cleanup call seg_janitor (TERM_FILE_TERM);

	call initiate_file_ (d.seg_arch.dir, d.seg_arch.ent, mode,
	     d.seg_arch.Pseg, d.seg_arch.Lsegbc, code);
	if d.op.type = MODIFY & code = error_table_$no_w_permission then do;
		call access_$set_temporarily (d.seg_arch.dir, d.seg_arch.ent,
		     (star_SEGMENT), mode, Paccess, code);
		if code = 0 then
		     call initiate_file_ (d.seg_arch.dir, d.seg_arch.ent, mode,
			d.seg_arch.Pseg, d.seg_arch.Lsegbc, code);
		else
		     code = error_table_$no_w_permission;
	     end;
	call d.check_error$fatal (code, CALLER, "^/^a",
	     pathname_ (d.seg_arch.dir, d.seg_arch.ent));
	d.seg_arch.Lseg = divide (d.seg_arch.Lsegbc, BITS_PER_CHAR, 21, 0);
	if d.seg_arch.Lseg = 0 then
	     call d.check_error$fatal (error_table_$zero_length_seg, CALLER, "^/^a",
		pathname_ (d.seg_arch.dir, d.seg_arch.ent));

	goto PROC (d.seg_arch.comp_type);

PROC (-1):					/* nonarchive seg				*/
	d.seg = d.seg_arch, by name;
	d.seg.Lseg_in = d.seg_arch.Lseg;
	call process_one_seg (ERROR_RETURN_LABEL, d.seg.Pseg);
	call seg_janitor (terminate_mode);
SEG_ERROR_EXIT:
	return;

PROC (0):						/* NONSTAR COMPONENT			*/
PROC (1):						/* STAR COMPONENT				*/
PROC (2):						/* STARSTAR COMPONENT			*/

dcl Smatch_found			bit (1);

	d.seg.dir = d.seg_arch.dir;
	d.seg.ent = d.seg_arch.ent;
	d.seg.Pseg = null;

	Smatch_found = FALSE;

	call archive_$next_component (d.seg_arch.Pseg, d.seg_arch.Lsegbc,
	     d.seg.Pseg, bc, d.seg.comp, code);
	call d.check_error$fatal (code, CALLER, "^/Processing:  ^a",
	     pathname_$component (d.seg_arch.dir, d.seg_arch.ent, d.seg_arch.comp));
	do while (d.seg.Pseg ^= null);
	     d.seg.Lseg_in = divide (bc, BITS_PER_CHAR, 21, 0);
	     goto MATCH (d.seg_arch.comp_type);

MATCH (0):
	     if d.seg.comp = d.seg_arch.comp then
		go to MATCH (2);
	     else
		go to NOMATCH;

MATCH (1):
	     call match_star_name_ (d.seg.comp, d.seg_arch.comp, code);
	     if code ^= 0 then
		goto NOMATCH;

MATCH (2):
	     Smatch_found = TRUE;
	     call process_archive_comp (NOMATCH);

NOMATCH:
	     call archive_$next_component (d.seg_arch.Pseg, d.seg_arch.Lsegbc,
		d.seg.Pseg, bc, d.seg.comp, code);
	     call d.check_error$fatal (code, CALLER, "^/Processing:  ^a",
		pathname_$component (d.seg_arch.dir, d.seg_arch.ent, d.seg_arch.comp));
	end;

          if ^Smatch_found then do;
	     code = error_table_$no_component;
	     call d.check_error$fatal (code, CALLER, "^/Processing:  ^a",
		pathname_$component (d.seg_arch.dir, d.seg_arch.ent, d.seg_arch.comp));
	     end;

	call seg_janitor (TERM_FILE_TERM);
	return;

seg_janitor:
     proc (terminate_mode);

	dcl     code		 fixed bin (35),
	        terminate_mode	 bit (*);

	if d.seg_arch.Pseg ^= null then do;
		call terminate_file_ (d.seg_arch.Pseg, d.seg.Lseg_out * BITS_PER_CHAR, terminate_mode, code);
		d.seg_arch.Pseg = null;
	     end;
	if Paccess ^= null then do;
		call access_$reset (Paccess, code);
		Paccess = null;
	     end;
     end seg_janitor;

     end process_seg_by_case;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* process_archive_comp:							*/
/*									*/
/* This routine is responsible for making a copy of an archive component when a MODIFY	*/
/* operation (eg, hcom add, add_field, format, install or replace_field) operation is	*/
/* being performed.  Since archive components cannot be updated in place, a temporary	*/
/* copy of the archive component is made in the process directory, this temp copy is	*/
/* modified (by calling process_one_seg), and then the temp copy is updated back into	*/
/* the archive.  After the archive command is called, the revised bit count of the	*/
/* archive is obtained for use in obtaining the next matching archive component.	*/
/*									*/
/* Note that, to function properly, this strategy depends upon the archive command	*/
/* always updating the component by putting it in the exact same place as its earlier	*/
/* version.  Thus, the pointer to the beginning of the unmodified and modified		*/
/* components is the same; only the component bit count differs following the		*/
/* modification, and that bit count is no longer of interest to us.  What is interesting	*/
/* is that the overall archive bit count has changed.  That is why we obtain the new	*/
/* archive bit count following each archive update operation.			*/
/*									*/
/* This procedure is responsible for cleaning up the temporary copy of the component,	*/
/* and for manipulating d.seg.Pseg to point to the temporary copy while the modify	*/
/* operation is in progress, and to the archived component after the modify is complete.	*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


process_archive_comp:
     proc (ERROR_RETURN_LABEL);

	dcl     ERROR_RETURN_LABEL	 label variable;

	dcl     code		 fixed bin (35),
	        pdir		 char (168),
	        seg		 char (d.seg.Lseg_in) based (d.seg.Pseg),
	        Pseg		 ptr;

	if d.op.type = NO_MODIFY then do;		/* read-type operations can be done on archive	*/
		call process_one_seg (ERROR_RETURN_LABEL, d.seg.Pseg);
						/*   components in place.			*/
		return;
	     end;

	Pseg = d.seg.Pseg;
	d.seg.Pseg = null;
	on cleanup call arch_janitor ();

	pdir = get_pdir_ ();
	call initiate_file_$create (pdir, d.seg.comp, RW_ACCESS, d.seg.Pseg,
	     "0"b, 0, code);
	if d.seg.Pseg = null then
	     call d.check_error$fatal (code, CALLER,
		"Creating temporary segment in process directory.");
	seg = Pseg -> seg;

	call process_one_seg (ERROR_RETURN_LABEL, Pseg);

	if d.seg.Lseg_in = d.seg.Lseg_out then /* If component was not changed during processing */
	     if Pseg -> seg = seg then do;		/*   then don't update the archive.		*/
		     call arch_janitor ();
		     revert cleanup;
		     d.seg.Pseg = Pseg;
		     return;
		end;

	call terminate_file_ (d.seg.Pseg, d.seg.Lseg_out * BITS_PER_CHAR,
	     TERM_FILE_TRUNC_BC, code);
	call d.check_error$fatal (code, CALLER,
	     "Terminating a temporary segment in the process directory.");

	call archive ("ud", pathname_ (d.seg_arch.dir, d.seg_arch.ent),
	     pathname_ (pdir, d.seg.comp));
	d.seg.Pseg = null;
	revert cleanup;
	d.seg.Pseg = Pseg;

	call hcs_$status_mins (d.seg_arch.Pseg, (0), d.seg_arch.Lsegbc, code);
	call d.check_error$fatal (code, CALLER, "^/^a^/^3xGetting bit count for updated archive.",
	     pathname_ (d.seg_arch.dir, d.seg_arch.ent));
	return;


arch_janitor:
     proc;

	dcl     code		 fixed bin (35);

	if d.seg.Pseg ^= null then
	     call terminate_file_ (d.seg.Pseg, d.seg.Lseg_out * BITS_PER_CHAR, TERM_FILE_DELETE, code);

	d.seg.Pseg = Pseg;

     end arch_janitor;

     end process_archive_comp;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* process_one_seg:								*/
/*									*/
/* This procedure applies the equal convention to the -original pathname, initiates the	*/
/* original segment/component, and calls hcom_process_seg_ to perform the actual	*/
/* operation on the source segment/component.  It is responsible for terminating the	*/
/* original segment/component upon completion of the operation.			*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


process_one_seg:
     proc (ERROR_RETURN_LABEL, APseg);

	dcl     ERROR_RETURN_LABEL	 label variable,
	        APseg		 ptr;

	dcl     bc		 fixed bin (24),
	        code		 fixed bin (35);

	if d.orig.path = "" then do;
		call hcom_process_seg_ (addr (d), ERROR_RETURN_LABEL);
		return;
	     end;

	d.orig_seg.dir = d.orig.dir;
	call get_equal_name_$component (d.seg.ent, d.seg.comp,
	     d.orig.ent, d.orig.comp, d.orig_seg.ent, d.orig_seg.comp, code);
	call d.check_error$fatal (code, CALLER,
	     "-orig ^a^/when applied to source path^/(^a).", d.orig.path,
	     pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp));

	d.orig_seg.Pseg = null;
	on cleanup call one_seg_janitor ();

	call initiate_file_$component (d.orig_seg.dir, d.orig_seg.ent,
	     d.orig_seg.comp, R_ACCESS, d.orig_seg.Pseg, bc, code);
	if d.orig_seg.Pseg = APseg then
	     call d.check_error$fatal (error_table_$bad_arg, CALLER, "^/-orig ^a^/is the same as the source^/(^a).",
		pathname_$component (d.orig_seg.dir, d.orig_seg.comp, d.orig_seg.ent),
		pathname_$component (d.seg.dir, d.seg.comp, d.seg.ent));
	call d.check_error$fatal (code, CALLER, "^/-orig ^a",
	     pathname_$component (d.orig_seg.dir, d.orig_seg.ent, d.orig_seg.comp));
	d.orig_seg.Lseg_in = divide (bc, BITS_PER_CHAR, 21, 0);

	call hcom_process_seg_ (addr (d), ERROR_RETURN_LABEL);
	call one_seg_janitor ();
	return;

one_seg_janitor:
     proc;
	dcl     code		 fixed bin (35);

	if d.orig_seg.Pseg ^= null then do;
		call terminate_file_ (d.orig_seg.Pseg, 0, TERM_FILE_TERM, code);
		d.orig_seg.Pseg = null;
	     end;
     end one_seg_janitor;

     end process_one_seg;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include access_mode_values;

%include hcom_data;

%include star_structures;

%include terminate_file;

     end hcom_process_path_;




		    hcom_process_seg_.pl1           08/21/90  1407.1rew 08/21/90  1405.2      899487



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) BULL HN Information Systems Inc., 1990   *
        *                                                         *
        * Copyright, (C) Honeywell Bull Inc., 1987                *
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1985 *
        *                                                         *
        *********************************************************** */

/****^  HISTORY COMMENTS:
  1) change(85-09-03,LJAdams), approve(85-11-06,MCR7278),
     audit(86-02-19,Gilcrease), install(86-03-06,MR12.0-1021):
     Program to process each individual segment to
     determine if there are or are not history comments present and update
     accordingly.
  2) change(86-03-05,LJAdams), approve(86-03-05,MCR7278),
     audit(86-03-05,Gilcrease), install(86-03-06,MR12.0-1029):
     Reformat summary when the format command is issued.
  3) change(86-04-17,LJAdams), approve(86-04-17,MCR7386),
     audit(86-05-27,Gilcrease), install(86-06-05,MR12.0-1071):
     Add an argument to indicated fill mode on (-fill, -fi) or fill mode off
     (-no_fill, -nfi) for the summary fields for the add operation.  The
     default will be fill mode.  Change the format operation to allow comment
     specification for reformatting.
  4) change(86-05-05,LJAdams), approve(86-05-08,MCR7414),
     audit(86-05-27,Gilcrease), install(86-06-05,MR12.0-1071):
     Moved the validation error reporting out of here and into hcom_parse_.rd.
  5) change(86-05-21,LJAdams), approve(86-05-27,MCR7429),
     audit(86-05-27,Gilcrease), install(86-06-05,MR12.0-1071):
     While doing the check option if no comments were found that met the check
     criteria all comments were being displayed as in error; rather than
     displaying all the comments an error message will be put out stating: No
     comments were found with all fields present except the install field.
     
     When doing the compare operation the NL was being included as part of the
     summary for the src_array but not the orig_array.
  6) change(86-07-07,LJAdams), approve(86-07-07,MCR7429),
     audit(86-07-07,Hartogs), install(86-07-07,MR12.0-1087):
     PBF for ID 1021.  ck operation was erroneously passing comments missing
     the audit field; depending on their sequence in the history comment block.
     Dates greater than the current date were being accepted.
  7) change(86-07-08,LJAdams), approve(86-07-08,MCR7429),
     audit(86-07-08,Brunelle), install(86-07-08,MR12.0-1088):
     PBF for ID 1021.  Change error message wording for ck failure.
  8) change(86-08-08,LJAdams), approve(86-08-19,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Change the method of determining the size of the copy of the comment to
     use the relative character offset and not the actual offset to determine
     the size of the length of the copy.
     
     Fixed problem with include files - if there was a format error the status
     was still being returned as true instead of false.
     
     Added check so that if hcom_parse_ found a critical fix number present
     only critical fix values can be added.  If critical fix number present
     the INSTALL operation is invalid unless -cfix specified.
     
     Fixed null pointer problem - field in orig array was being checked when
     the pointer to orig_array had not been set.
     
     Changed design so that comments in the original and the source need not
     be in comment number order as long as all the comments in the original
     are found in the source.
     
     phx20629:  Changed error_table_$badstar to error_table_$bad_file_name.
  9) change(87-03-16,LJAdams), approve(87-04-22,MCR7653),
     audit(87-04-02,Gilcrease), install(87-04-26,MR12.1-1026):
     Added support for C header (.h) files.  They are treated as type 1
     include files.  (phx20795)
 10) change(87-03-26,LJAdams), approve(87-03-26,MCR7653),
     audit(87-04-02,Gilcrease), install(87-04-26,MR12.1-1026):
     If the comment length is greater than max length allowed display error
     message; for a display operation continue; for modify operation halt so as
     not to damage given segment."
 11) change(87-03-30,LJAdams), approve(87-03-30,MCR7653),
     audit(87-04-02,Gilcrease), install(87-04-26,MR12.1-1026):
     Display error msg for old history comments that have a null approve, null
     audit, and/or are missing or have a non-null value for the install field.
 12) change(87-04-28,LJAdams), approve(87-04-28,PBF7653),
     audit(87-04-28,Farley), install(87-05-08,MR12.1-1031):
     Change checking for .h include files to exclude .header files.
 13) change(87-11-09,LJAdams), approve(87-11-10,MCR7802),
     audit(87-12-04,RBarstad), install(88-01-12,MR12.2-1012):
     If a history comment exceeded the maximum length the error message was
     printing the error code instead of the length of the comment in error.
 14) change(90-07-23,Itani), approve(90-07-23,MCR8186), audit(90-07-30,Vu),
     install(90-08-21,MR12.4-1027):
     Change history_comment so that when it is invoked as an active function,
     it returns all the values requested for the get operation when a star name
     is specified for the pathname.
                                                   END HISTORY COMMENTS */

/* format: off */

hcom_process_seg_:	
   proc(Pd, ERROR_RETURN_LABEL);

dcl	
/*	Pd			ptr,		/* ptr to d structure, dcl in hcom_data.incl.pl1	*/
	ERROR_RETURN_LABEL		label parameter;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This command is used to insert history_comments into source_programs.        	*/
	/* The command uses the pnotice_language_info_ database (created by CDS) to obtain        */
	/* information on the source language segment.			          	*/
	/*									*/
	/* Status:								*/
	/* 0) Created	   June 1985 by LJ Adams					*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */



	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* INTERNAL PROCEDURES IN THIS PROGRAM. THESE ARE LISTED IN THE ORDER THAT THEY EXIST	*/
	/* INLINE, AS WELL AS THE MOST FREQUENT PATH OF EXECUTION.				*/
	/*									*/
	/* Name		       Brief description					*/
	/* get_language_info       obtains per-language parameters like comment delimiters, etc.	*/
	/* comment_parse	       finds the extents of a notice box, if any.			*/
	/* process_tokens	       drives the parsing procedures to locate notices.		*/
	/* sort_comments	       sorts >1 comment into proper order.			*/
	/* insert_notice	       puts new star box into proper place in a segment.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	



/*  A U T O M A T I C  */
dcl	Sany_found		bit(1),
	Sblank_after		bit(1),
	Sblank_before		bit(1),
          Sfirst_cmt		bit(1),
	Sformat			bit(1),
	code			fixed bin(35),
	current_date		char(8),
          error_msg			char (100) varying,
         (i, j, k)			fixed bin (24),
	valid			bit(1);

/*  E X T E R N A L   E N T R I E S  */
dcl	cu_$generate_call		entry (entry, ptr),
	date_time_$format		entry (char(*),fixed bin(71),char(*),char(*)) returns (char(250) var),
	format_document_$string	entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35)),
	get_ec_version_		entry (char(*), char(*), fixed bin, fixed bin (21), fixed bin (35)),
	get_line_length_$switch	entry (ptr, fixed bin(35)) returns(fixed bin),
	hcom_command_query_		entry options(variable),
	hcom_cfix_validate_		entry (char(*) var, char(*) var, char(*) var, bit(1), char(*) var, 
                                              char(*) var, char(100) var),
	hcom_parse_		entry (label, char(*), char(*), char(*), bit,  ptr, 1 aligned, 
                                             2 char(8), 2 pic "9999", 2 bit(1), 2 bit(1), 2 fixed bin, 
                                             2 fixed bin, 2 char(24) var, 2 char(8), 2 char(24) var,
				     2 char(8), 2 char(24) var, 2 char(8),
				     2 char(24) var, 2 char(2000) var, 
                                             2 (5) char(80) var, fixed bin(35)),
         (ioa_, ioa_$nnl)		     entry() options(variable),
	pathname_$component		entry (char(*), char(*), char(*)) returns(char(194)),
	pnotice_mlr_		entry (ptr, fixed bin(21), ptr, fixed bin(21)),
	pnotice_mrl_		entry (ptr, fixed bin(21), ptr, fixed bin(21));


/*  I N T E R N A L   S T A T I C  */
dcl	CHARS_PER_WORD		fixed bin int static options(constant) init(4),
	FALSE			bit(1) int static options (constant) init ("0"b),
          HT_SP                         char(2) int static options(constant) init("	 "),
	HT_SP_NL_VT_NP		char(5) int static options(constant) init ("	 
"),
	NL			char(1) aligned int static options(constant) init ("
"),
	SP			char(1) int static options(constant) init (" "),
	TRUE			bit(1) int static options (constant) init ("1"b);

/*  E X T E R N A L   S T A T I C  */
dcl      (error_table_$bad_arg,
	error_table_$bad_file_name,
          error_table_$bigarg,
	error_table_$improper_data_format,
	error_table_$recoverable_error)
				fixed bin(35) ext static,
	sys_info$max_seg_size    	fixed bin(35) ext static;

/*  B U I L T I N  */
dcl      (addr, addcharno, after, before, char, charno, clock, convert, dim,
          hbound, index, lbound, length, ltrim, maxlength, null, reverse,
          rtrim, search, string, substr, unspec, verify)
				builtin;

/*  S T R U C T U R E S  */

dcl	Psegment			ptr,
	Lsegment			fixed bin(21),
	segment			char(Lsegment) based (Psegment);

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

   call init_structures$src_array;
   Porig_array = null;
   current_date = date_time_$format("^yc-^my-^dm",clock(),"","");
   Sformat = FALSE;
   

   call get_language_info (d.seg);			/* parse comments in the source segment		*/
   call comment_parse(addr(src_array), d.seg, pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));

   if d.orig_seg.Pseg ^= null & d.orig_seg.Lseg_in ^= 0 then do;
      call init_structures$orig_array;			/* parse comments in the original segment	*/
      call get_language_info(d.orig_seg);
      call comment_parse(addr(orig_array), d.orig_seg, pathname_$component(d.orig_seg.dir, d.orig_seg.ent, d.orig_seg.comp));
      end;

   if d.ag.op.name ^= ADD & d.ag.op.name ^= COMPARE then
      Sany_found = select_comments(Sany_found);		/* use com specs to get requested src cmts	*/
   else
      Sany_found = FALSE;				/* So far, no comments have been selected.	*/
   goto OPER(d.ag.op.name);

OPER(1):	                                                  /* ADD					*/
   if d.ag.input.sm = INPUTxxx | d.ag.input.apv = INPUTxxx | 
      d.ag.input.in = INPUTxxx then
      call prompt_req;
   call ADD_comment (Sany_found);
   goto END_OPER;

OPER(2):	                                                  /* ADD_FIELD				*/
   if ^Sany_found then				/* error means no slection criteria was met	*/
      call check_error (-1, "", "^a^/^3xNo^[^; matching^] history comments.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
         string(d.com_spec.selected) = ALL & d.com_spec.Nrange = 0);
   if d.ag.input.apv = INPUTxxx | d.ag.input.in = INPUTxxx then
      call prompt_req;
   call ADD_FIELDs (Sany_found);
   if ^Sany_found then				/* error means no slection criteria was met	*/
      call check_error (-1, "", "^a^/^3xNone of the selected history comments needed the given fields.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
         string(d.com_spec.selected) = ALL & d.com_spec.Nrange = 0);
   goto END_OPER;
	

OPER(3):                                                    /* CHECK					*/
   if ^Sany_found then do;
      if d.Saf then
         call d.set_return_arg ("false");
      else
         call check_error (-1, "", "^a:^/^3xERROR:  Either an audit or approve field is missing from a comment^/^15x----- or -----^/^11xNo new comments were found.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      goto END_OPER;
      end;
   else do;
      call CHECK_FIELDs(Sany_found);
      goto END_OPER;
      end;
	
OPER(4):						/* COMPARE				*/
   call COMPARE_modules;
   goto END_OPER;

OPER(5):	                                                  /* DISPLAY				*/
   goto END_OPER;
	
OPER(6):	                                                  /* EXISTS					*/
   goto END_OPER;

OPER(7):	                                                  /* FORMAT					*/
   call cmt_renumber;				/* check to be sure comments are in date sequence */
   call FORMAT_CMTS(Sany_found);
   if ^Sany_found then
      call check_error (-1, "", "^a^/^3x No matching history comments were found.",
      pathname_$component(d.seg.dir,d.seg.ent,d.seg.comp));
                               			/* error means no selection criteria was met	*/
   Sformat = TRUE;
   goto END_OPER;
	
OPER(8):	                                                  /* GET					*/
   call GET_fields;
   goto RETURN;
	
OPER(9):	                                                  /* INSTALL				*/
   if ^Sany_found then do;
      if d.Saf then
         call d.set_return_arg("false");
      call check_error (-1, "", "^a:^/^3xcontains no history comments.", pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp));
      end;
   else do;
      if d.ag.input.apv = INPUTxxx | d.ag.input.in = INPUTxxx then
         call prompt_req;
      if d.ag.orig.path ^= "" then
         if orig_array.Ncoms > 0 then
            call COMPARE_modules;
      call INSTALL_ck;
      goto RETURN;
      end;
   

OPER(10):						/* REPLACE_FIELD				*/
   if Sany_found then do;
      if d.ag.input.sm = INPUTxxx | d.ag.input.apv = INPUTxxx |
         d.ag.input.in = INPUTxxx then
         call prompt_req;
      call REPLACE_FIELDs;
      end;
   goto END_OPER;

END_OPER:
   if d.ag.op.type = MODIFY then do;
      if ^Sany_found then				/* error means no slection criteria was met	*/
         call check_error (-1, "", "^a^/^3xNo^[^; matching^] history comments.",
	  pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
	  string(d.com_spec.selected) = ALL & d.com_spec.Nrange = 0);
      call format_comments();
      call insert_notice();				/* put it into the seg */
      end;
   call display_comments(Sany_found);

RETURN:
   return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

ADD_comment:
   proc (Sany_found);

dcl	Sany_found		bit(1);

   if d.ag.input.value.approve_value ^= "" & d.Scfix_found & 
      index(d.ag.input.value.approve_value,"fix_") = 0 then
						/* Only critical fix numbers are allowed once spec*/
      call check_error (error_table_$bad_arg, CALLER, "^a^/^3x^a^/^3xOnly critical fix numbers are currently acceptable.", 
         d.ag.input.value.approve_value, 
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));

   d.ag.input.value.selected = TRUE;
   Sany_found = TRUE;
   if src_array.Ncoms = 0 then do;			/* First comment				*/
      src_array.Ncoms = 1;
      d.ag.input.value.comment_no = src_array.Ncoms;
      d.ag.input.value.seqno = 1;
      src_array.comments(src_array.Ncoms) = d.ag.input.value;
      src_array.comments(src_array.Ncoms).fill = d.ag.ctl.fill;
      end;
   else do;
      src_array.Ncoms = src_array.Ncoms + 1;
      d.ag.input.value.comment_no = src_array.Ncoms;
      d.ag.input.value.seqno = src_array.comments(src_array.Ncoms-1).seqno +1;
      src_array.comments(src_array.Ncoms) = d.ag.input.value;
      src_array.comments(src_array.Ncoms).fill = d.ag.ctl.fill;
      end;

   end ADD_comment;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

ADD_FIELDs:
   proc(Sany_found);

dcl	Sany_found		bit(1),
	Sfound			bit(1);

   Sany_found = FALSE;
   do i = 1 to src_array.Ncoms;
      Sfound = FALSE;
      if src_array.comments(i).selected then do;

         if d.ag.input.apv = OPERANDxxx &
	  src_array.comments(i).approve_dt = "" &
	  src_array.comments(i).approve_value = "" then do;
	  src_array.comments(i).approve_value = d.ag.input.value.approve_value;
            src_array.comments(i).approve_dt = d.ag.input.value.approve_dt;
            Sfound = TRUE;
            end;

         if d.ag.input.aud = OPERANDxxx &
	  src_array.comments(i).audit_dt = "" &
	  src_array.comments(i).audit_person = "" then do;
	  if src_array.comments(i).change_person = d.ag.input.value.audit_person then
	     call check_error (-1, CALLER, "^a^/^3xYou created the matching history comment ^d and cannot also be the auditor.",
	        pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp),
	        src_array.comments(i).comment_no);
            src_array.comments(i).audit_dt = d.ag.input.value.audit_dt;
            src_array.comments(i).audit_person = d.ag.input.value.audit_person;
            Sfound = TRUE;
            end;

         if d.ag.input.in = OPERANDxxx &
	  src_array.comments(i).install_dt = "" &
	  src_array.comments(i).install_id = "" then do;
            src_array.comments(i).install_dt = d.ag.input.value.install_dt;
            src_array.comments(i).install_id = d.ag.input.value.install_id;
	  Sfound = TRUE;
            end;
         src_array.comments(i).selected = Sfound;		/* reset if no fields were added.		*/
         Sany_found = Sany_found | Sfound;
         end;
      end;

   end ADD_FIELDs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Syntax:  dcl check_error entry options(variable);				*/
	/* 	  call check_error (code, procedure_name, ioa_ctl_str, args);		*/
	/*									*/
	/* Function: calls com_err_ to report an error on	behalf of hcom.			*/
          /*									*/
	/* Args:									*/
	/* code (fixed bin(35))							*/
	/*    a status code.							*/
	/* procedure_name (char(*))							*/
	/*    name of the procedure reporting the error.					*/
	/* ioa_ctl_str								*/
	/*    error message								*/
	/* args									*/
	/*    args ioa_ will substitute into the error message.				*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl	Serror_has_occurred		bit(1) init("0"b);

check_error:
   proc options(variable);

    dcl  	Pcode			ptr,
	code			fixed bin(35) based(Pcode),
         	com_err_			entry() options(variable),
       	cu_$arg_list_ptr		entry returns(ptr),
	cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35));

   call cu_$arg_ptr (1, Pcode, 0, 0);			/* Access error table code argument.		*/
   if code = 0 then return;				/* If non-zero, this ISN'T an error.		*/
   Serror_has_occurred  = TRUE;
   if code = -1 then code = 0;			/* No error table code fits the desired err msg.	*/
   call cu_$generate_call (com_err_, cu_$arg_list_ptr());
   goto ERROR_RETURN_LABEL;

end check_error;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

CHECK_FIELDs:
   proc (Sany_found);

dcl       Sany_found		bit (1);

   if d.orig.path ^= "" then
      if orig_array.Ncoms > 0 then 
         call COMPARE_modules;

   Sany_found = TRUE;
   do i = 1 to src_array.Ncoms while (Sany_found);
      if src_array.comments(i).selected then
         if src_array.comments(i).change_dt ^= "" & src_array.comments(i).change_person ^= "" &
            (src_array.comments(i).audit_dt = "^" |
             src_array.comments(i).audit_dt ^= "" & src_array.comments(i).audit_person ^= "") &
            (src_array.comments(i).approve_dt = "^" |
	   src_array.comments(i).approve_dt ^= "" & src_array.comments(i).approve_value ^= "") &
            (src_array.comments(i).install_dt = "^" |
	   src_array.comments(i).install_dt = "" & src_array.comments(i).install_id = "") then do;
	  src_array.comments(i).selected = FALSE;
	  end;
         else
	   Sany_found = FALSE;
      else
         ;
      end;

   end CHECK_FIELDs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

FORMAT_CMTS:
   proc (Sany_found);

   dcl	Sany_found		bit(1);

   Sany_found = FALSE;
   do i = 1 to src_array.Ncoms;
      if src_array.comments(i).selected then do;
         src_array.comments(i).fill = d.ag.ctl.fill;
         Sany_found = TRUE;
         end;
      end;
   
end FORMAT_CMTS;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
    
cmt_renumber:
   proc;

   if d.ag.ctl.renumber then do;   
      call sort_comments (Psrc_array);
      do i = 1 to src_array.Ncoms;
         src_array.comments(i).comment_no = i;
         end;
      end;
   return;

end cmt_renumber;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

comment_parse:
   proc(Pcom_array, seg, com_path);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure determines the extents of what appears to be a valid history comment.	*/
	/* languages. Once this is done, these extents are then used by the process_tokens	*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl	Pcom_array		ptr,
	1 seg			aligned like d.seg,
	com_path			char(*);
   
dcl	1 com_array		aligned based(Pcom_array),
	  2 Ncoms			fixed bin,
	  2 comments (0 refer(com_array.Ncoms))
				aligned like src_array.comments;

dcl	Send_history_cmt		bit(1),
	Sincl			bit(1),
	Spnotice			bit(1),
          Snopnotice		bit(1),
	Sprt_path			bit(1),
          Sstar_line                    bit(1),
	save_length		fixed bin(21),
	save_ptr			ptr;

dcl	rest			char(Lrest) based (Prest),
	Prest			ptr,
	Lrest			fixed bin (21),
	Icmt			fixed bin (21),
	rest_ch (Lrest)		char(1) based (Prest);

dcl	Pcomment			ptr,
	Lcomment			fixed bin(21),
	comment			char(Lcomment) based(Pcomment),
	comment_chr (Lcomment)	char(1) based(Pcomment),
	Pcomment_line		ptr,
	Lcomment_line		fixed bin(21),
	comment_line		char(Lcomment_line) based(Pcomment_line);

dcl	Pcopy			ptr,
	Lcopy			fixed bin(21),
	copy			char(Lcopy) based(Pcopy) aligned,
	Pcopy_cmt			ptr,
	Lcopy_cmt			fixed bin(21);

dcl       err_code			fixed bin(35);

    Sblank_before, Sblank_after = FALSE;         
    Sprt_path = FALSE;
    seg.Pbox = seg.Pseg;
    seg.Loldbox = 0;
  
    Psegment = seg.Pseg;				/* get source segment to pass to hcom_parse_	*/
    Lsegment = seg.Lseg_in;

    Prest = seg.Pseg;
    Lrest = seg.Lseg_in;
    Sincl = FALSE;

    if d.seg.comp ^= "" & index(d.seg.comp,".incl.") > 0 then
						/* determine if working with incl file		*/
       Sincl = TRUE;
    else if d.seg.ent ^= "" & index(d.seg.ent,".incl.") > 0 then
       Sincl = TRUE;
    else if d.seg.comp ^= "" & after(d.seg.comp,".") = "h" then
						/* determine if working with C header file	*/
       Sincl = TRUE;
    else if d.seg.ent ^= "" & after(d.seg.ent,".") = "h" then
       Sincl = TRUE;

    goto TYPE(seg.type);

TYPE(1):
TYPE(4):
    Icmt = verify(rest, HT_SP_NL_VT_NP);		/* disregard white space at front		*/
    if Icmt = 0 then
       goto end_parse1;
    else do;
       Prest = addr(rest_ch(Icmt));
       Lrest = Lrest - (Icmt-1);
       if Sincl then
	call ck_incl_file$pl1;			/* adjust cmt begin/length to skip include block	*/
       end;

    if ck_history_cmt() then do;
       i = index(comment,NL);				/* skip begin block line			*/
       Pcomment = addcharno(addr(comment_chr(i)), 1);	/* skip begin block line			*/
       Lcomment = Lcomment -i;
       i = index(substr(reverse(comment),2),NL);		/* strip off end block line			*/
       Lcomment = Lcomment - i;

       if index(comment,"change") > 0 then do;
	call process_tokens;
	goto end_parse1;
	end;
       else 
	call check_error (error_table_$improper_data_format,CALLER, "^/^a^/^3xMissing change keyword in history comment box.",
	pathname_$component(seg.dir, seg.ent, seg.comp));
       end;
    else do;
       if d.seg.type = 4 & substr(rest,1,2) ^= "/*" |
	d.seg.type ^= 4 & substr(rest,1,length(seg.cmt_bgn)) ^= seg.cmt_bgn then do;
						/* first non-white space not a comment		*/
	Sblank_before, Sblank_after = TRUE;
	goto end_parse1;
	end;
         
       Pcomment = addr(rest);
       Lcomment = Lrest;
       Lcomment = index(comment,seg.cmt_end) -1 + length(seg.cmt_end);
       Spnotice = TRUE;
       
       do while (Spnotice);
	if substr(comment,length(seg.cmt_bgn)+5,10) = "**********" &
	   (index(comment,"Copyright") > 0 |		/* find out if its a pnotice - if its not a 	*/
						/* pnotice history comment comes 1st		*/
	   index(comment,"PROPRIETARY") > 0 |
	   index(comment,"PUBLIC DOMAIN") > 0) then do;
             Prest = addcharno(addr(rest_ch(Lcomment)), 1);
	   Lrest = Lrest - Lcomment;
	   Icmt = verify(rest, HT_SP_NL_VT_NP);		/* skip white space if present		*/
	   if Icmt > 0 then do;
	      Prest = addr(rest_ch(Icmt));
	      Lrest = Lrest - (Icmt-1);
	      end;
	   end;
	else
	   Spnotice = FALSE;
	if Spnotice & substr(rest,length(seg.cmt_bgn)+5,10) = "**********"  then do;
	   Pcomment = Prest;
	   Lcomment = index(rest, seg.cmt_end) -1 + length(seg.cmt_end) + length(NL);
	   end;
	else
	   Spnotice = FALSE;
	end;

       Sblank_before, Sblank_after = TRUE;
       seg.Pbox = Prest;
       end;

   Pcomment = Prest;
   Lcomment = index(rest, seg.cmt_end) -1 + length(seg.cmt_end) + length(NL);
   Pcomment_line = Pcomment;
   Lcomment_line = index(comment,NL);
   if Lcomment_line = 0 then
      Lcomment_line = Lcomment;
   i = index(comment_line,"HISTORY");
   j = index(comment_line,"COMMENTS:");
   if i ^< j | i = 0 | j = 0 then do;			/* not a history comment			*/
      Sblank_before, Sblank_after = TRUE;
      goto end_parse1;
      end;
   
   seg.Loldbox = Lcomment;
   if length(comment) > length(comment_line) then
      Pcomment = addr(comment_chr(Lcomment_line+1));
   Lcomment = Lcomment - Lcomment_line;

   if index(comment,"END") > 0 & index(comment,"HISTORY") > 0 & index(comment,"COMMENTS") > 0 then do;
      i = index(substr(reverse(comment),2),NL);
      Lcomment = Lcomment - i;
      end;
   else
      call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xMissing history comment end block.",
      pathname_$component(seg.dir, seg.ent, seg.comp));

   if index(comment, "change") > 0 then
      call process_tokens;
   else
      call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xMissing change keyword in history comment box.",
      pathname_$component(seg.dir, seg.ent, seg.comp));

end_parse1:
   return;


TYPE(3):						/* adjust things for ec's and absin */
   Prest = addr(rest_ch(seg.text_pos));			/* adjust to avoid any "&version" lines */
   Lrest = Lrest - (seg.text_pos - 1);
          					/* after this, type 3 is just like type 2 */
   seg.Pbox = Prest;
TYPE(2):
TYPE(5):						/* compin and runoff files			*/

   Icmt = verify(rest, HT_SP_NL_VT_NP);			/* disregard white space at front		*/
   if Icmt = 0 then
      goto end_parse2;
   if (Icmt - 1) + length(seg.cmt_bgn) > length(rest) then
      goto end_parse2;				/* no room left for comment			*/
   Prest = addr(rest_ch(Icmt));
   Lrest = Lrest - (Icmt-1);
   if Sincl then					/* adjust cmt begin/length to skip 1st incl line	*/
      call ck_incl_file$alm;

   if ck_history_cmt() then do;
      i = index(comment,NL);				/* strip off begin block line			*/
      Pcomment = addcharno(addr(comment_chr(i)), 1);
      Lcomment = Lcomment - i;
      i = index(substr(reverse(comment),2),NL);		/* strip off end block line			*/
      Lcomment = Lcomment - i;

      if index(comment, "change") > 0 then do;		/* make a copy of seg for hcom_parse_		*/
         Pcopy = Pseg;
         Lcopy = charno(Pcomment) - charno(Pseg);
         call form_string$init();
         call form_string$fixed(copy);
         call form_string$fixed(" ");			/* establish start of copy			*/
         Pcopy_cmt = addcharno(addr(formed_string_array(Lcopy)), 1);
						/* strip off CMTBGN character			*/
         do while(Lcomment > 0);
	  Pcomment_line = Pcomment;
	  Lcomment_line = index(comment,NL);
	  if Lcomment_line = 0 then do;
	     Lcomment_line = Lcomment;
	     Lcomment = 0;
	     end;
	  else do;
	     Pcomment = addcharno(addr(comment_chr(Lcomment_line)),1);
	     Lcomment = Lcomment - Lcomment_line;
	     end;
	  k = index(comment_line,seg.cmt_bgn);
	  if k = 0 then
	     call form_string$var (substr(comment_line,1));
	  else
	     call form_string$var (substr(comment_line,k+length(seg.cmt_bgn)));
	  end;
         Psegment = Pformed_string;
         Lcopy_cmt = charno(addr(formed_string_array(Lformed_string))) - charno(Pcopy_cmt);
         Pcomment = Pcopy_cmt;
         Lcomment = Lcopy_cmt;
         call process_tokens;
         goto end_parse2;
         end;
      else 
         call check_error (error_table_$improper_data_format,CALLER, "^/^a^/^3xMissing change keyword in history comment box.",
         pathname_$component(seg.dir, seg.ent, seg.comp));
      end;
   else if substr(rest,1,length(seg.cmt_bgn)) ^= seg.cmt_bgn then do;
      Sblank_before, Sblank_after = TRUE;
      goto end_parse2;
      end;
   else do;
      Spnotice = TRUE;
      Snopnotice = FALSE;
      do while (Spnotice);
         Pcomment = Prest;
         Lcomment = Lrest;
         save_length = 0;
         Sstar_line = FALSE;

         if substr(comment,length(seg.cmt_bgn)+5,10) = "**********" &
						/* pnotices begin with a star line		*/
	  (index(comment,"PROPRIETARY") > 0 |
	  index(comment,"PUBLIC DOMAIN") > 0 |
	  index(comment,"Copyright") > 0) then do;
	  do while(Lcomment > 0);
						/* ensure that history cmt follows pnotice	*/
	     Pcomment_line = Pcomment;
	     Lcomment_line = index (comment,NL);
	     if Lcomment_line = 0 then
	        Lcomment_line = Lcomment;
	     else
	        Pcomment = addr(comment_chr(Lcomment_line+1));
	     Lcomment = Lcomment - Lcomment_line;
	     save_length = save_length + Lcomment_line;
	     if substr(comment_line,length(seg.cmt_bgn)+5,10) = "**********" then do;
	        if ^Sstar_line then
		 Sstar_line = TRUE;
	        else do;
		 Prest = addcharno(addr(rest_ch(save_length)),1);
		 Lrest = Lrest - save_length;
		 Lcomment = 0;
		 end;
	        end;
	     end;
	  Icmt = verify(rest, HT_SP_NL_VT_NP);
	  Prest = addr(rest_ch(Icmt));
	  Lrest = Lrest - (Icmt-1);
	  if substr(rest,length(seg.cmt_bgn)+5,10) ^= "**********" |
	     Lrest = 0 then
	     Spnotice = FALSE;
	  end;
         else do;					/* no pnotices found - pnotices are the		*/
						/* first comments in a program		*/
	  Spnotice = FALSE;
	  Snopnotice = TRUE;
	  end;
         seg.Pbox = Prest;
         end;
      if d.seg.type ^= 5 then do;			/* dont add blank lines for compin/runoff files	*/
         if Snopnotice then
            Sblank_after = TRUE;
         else
	  Sblank_after, Sblank_before = TRUE;
         end;

      goto end_parse2;
      end;

	
end_parse2:
   return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

ck_incl_file:					/* adjust comment beginning to skip 1st line of	*/
						/* include files.				*/
   proc;

ck_incl_file$pl1:
   entry;
   
   Pcomment, Pcomment_line = Prest;
   Lcomment = Lrest;
   Lcomment_line = index(comment,NL);
   call ck_begin_line;				/* include files must have begin line		*/
   if index(comment_line,"HISTORY") > 0 & index(comment_line,"COMMENTS:") > 0 then
      ;
   else do;					/* skip begin incl file line			*/
      i = index(comment,seg.cmt_end);
      Pcomment = addcharno(addr(comment_chr(i)), length(seg.cmt_end));
      Lcomment = Lcomment - i+length(seg.cmt_end)-1;
      i = verify (comment,HT_SP_NL_VT_NP);
      if i > 0 then do;
         Pcomment = addr(comment_chr(i));
         Lcomment = Lcomment -i-1;
         end;
      end;

   seg.Pbox = Pcomment;
   Prest = Pcomment;
   Lrest = Lcomment;
   return;

ck_incl_file$alm:
   entry;

   Pcomment, Pcomment_line = Prest;
   Lcomment = Lrest;
   Lcomment_line = index(comment,NL);
   call ck_begin_line;				/* include files must have begin line		*/
   if index(comment_line,"HISTORY") > 0 & index(comment_line,"COMMENTS:") > 0 then
      ;
   else 
      if substr(comment_line,1,length(seg.cmt_bgn)) = seg.cmt_bgn then do;
						/* if 1st line is a comment put history comment	*/
						/* after it else put history comment before	*/
         Pcomment = addcharno(addr(comment_chr(Lcomment_line)), 1);
         Lcomment = Lcomment - Lcomment_line;
         end;

   Prest = Pcomment;
   Lrest = Lcomment;
   seg.Pbox = Pcomment;
   return;

ck_begin_line:
   proc;
   
   if d.seg.type = 4 & substr(comment_line,1,length("/*")) ^= "/* " then
      goto LINE_ERROR;
   else if d.seg.type ^= 4 & substr(comment_line,1,length(seg.cmt_bgn)) ^= seg.cmt_bgn then
						/* include files must begin with a cmt		*/
      goto LINE_ERROR;
   else if index(comment_line,rtrim(seg.ent)) ^= 0 |	/* see if file name is anotated		*/
      index(comment_line,rtrim(seg.comp)) ^= 0 then
      goto END_CK;
   else if index(comment_line,"BEGIN") = 0 & index(comment_line,"Begin") = 0 &
      index(comment_line,"begin") = 0 then
      goto LINE_ERROR;
   else if index(comment_line,"INCLUDE") = 0 & index(comment_line,"Include") = 0 &
      index(comment_line,"include") = 0 then
      goto LINE_ERROR;
   else if index(comment_line,"FILE") = 0 & index(comment_line,"File") = 0 &
      index(comment_line,"file") = 0 then
      goto LINE_ERROR;
   else
      goto END_CK;

LINE_ERROR:
   call d.set_return_arg ("false");

   call check_error (error_table_$improper_data_format,CALLER, "^/^a^/^3xINCLUDE file missing ""BEGIN INCLUDE FILE"" line.",
   pathname_$component(seg.dir,seg.ent,seg.comp));

END_CK:
end ck_begin_line;

end ck_incl_file;


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
ck_history_cmt:
   proc returns(bit(1));

   dcl  Shistory_cmt_bgn		bit(1);
   

   Shistory_cmt_bgn = FALSE;
   Pcomment = Prest;
   Lcomment = Lrest;

   do while (Lcomment > 0 & ^Shistory_cmt_bgn);
      Pcomment_line = Pcomment;
      Lcomment_line = index(comment,NL);
      if Lcomment_line = 0 then do;
         Lcomment_line = Lcomment;
         Lcomment = 0;
         end;
      else do;
         if Lcomment - Lcomment_line > 0 then
	  Pcomment = addcharno(addr(comment_chr(Lcomment_line)), 1);
         Lcomment = Lcomment - Lcomment_line;
         end;
      if Lcomment_line >= length(seg.cmt_bgn) then
         if index(substr(comment_line,1,length(seg.cmt_bgn)),seg.cmt_bgn) > 0 &
            index(comment_line,"HISTORY") > 0 &
            index(comment_line,"COMMENTS:") > 0 then
            Shistory_cmt_bgn = TRUE;
      end;
   
   if ^Shistory_cmt_bgn then
      return (FALSE);

   Lrest = Lrest - (charno(Pcomment_line) - charno(Prest));
   Prest = Pcomment_line;
   seg.Pbox = Prest;
   Pcomment = Prest;
   Lcomment = Lrest;

   if seg.type = 1 | seg.type = 4 then do;
      if index(comment,"END") > 0 & index(comment,"HISTORY") > 0 & index(comment,"COMMENTS") > 0 then
         ;
      else
         call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xMissing history comment end block.",
         pathname_$component(seg.dir, seg.ent, seg.comp));
      Lcomment = index(rest,seg.cmt_end) -1 + length(seg.cmt_end) + length(NL);
      seg.Loldbox = Lcomment;
      end;
   else do;
      Lcomment = Lrest;
      save_ptr = Pcomment;
      save_length = 0;
      Send_history_cmt = FALSE;
      do while (^Send_history_cmt & Lrest > 0);
         Pcomment_line = Pcomment;
         Lcomment_line = index(comment,NL);
         if Lcomment_line = 0 then do;
	  Lcomment_line = Lrest;
	  Lrest = 0;
	  end;
         else do;
	  Pcomment = addcharno(addr(comment_chr(Lcomment_line)), 1);
	  Lcomment = Lcomment - Lcomment_line;
	  end;
         if index(comment_line,"END") > 0 &
	  index(comment_line,"HISTORY") > 0 then
	  Send_history_cmt = TRUE;
         save_length = save_length + Lcomment_line;
         end;
      if ^Send_history_cmt then
         call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xMissing "" END HISTORY COMMENTS"".",
         pathname_$component(seg.dir,seg.ent,seg.comp));

      seg.Loldbox = save_length;
      Pcomment = save_ptr;
      Lcomment = save_length;
      end;

   return(TRUE);
      
end ck_history_cmt;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


process_tokens:
   proc;

dcl	Lstring			fixed bin(21),	/* length of an individual comment		*/
	Pstring			ptr,
	string			char(Lstring) based(Pstring);

   Pstring = Pcomment;
   Lstring = 0;
   Sfirst_cmt = TRUE;
   com_array.Ncoms = 0;

   do while (line$cmt());
      if line$new_cmt() then do;
         if Sfirst_cmt then do;
	  com_array.Ncoms = 1;
	  call init_structures$array(com_array.comments(com_array.Ncoms));
	  com_array.comments(com_array.Ncoms).seqno = 1;
	  Lstring = Lstring + Lcomment_line + length(NL);
	  Sfirst_cmt = FALSE;
	  end;
         else do;
	  if Lstring = 0 then 
	     call check_error (error_table_$improper_data_format, CALLER, "^a^/^3xZero length comment.",
	     pathname_$component(d.seg.dir,d.seg.ent,d.seg.comp));

	  call hcom_parse_ (ERROR_RETURN_LABEL, segment, string, com_path, Sprt_path, Pd,
	     com_array.comments(com_array.Ncoms), code);

	  if com_array.comments(com_array.Ncoms).err_msg(1) ^= "" then do;
               err_code = convert (err_code, ltrim(com_array.comments(com_array.Ncoms).err_msg(1)));
               if err_code = error_table_$improper_data_format then do;
	        if d.ag.op.type = NO_MODIFY then
                     call ioa_ ("^/^a^/^3xComment ^d has null approve and audit values a null install value is required.",
		 pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
                     com_array.comments(com_array.Ncoms).comment_no);
	        else call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xComment ^d has null approve and audit values a null install value is required.",
		 pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), 
		 com_array.comments(com_array.Ncoms).comment_no);
	     end;
	  else if err_code = error_table_$bigarg then do;
	        if d.ag.op.type = NO_MODIFY then
		 call ioa_ ("^/^a^/^3xThe length of comment ^d is ^a which exceeds max allowable length of ^d.", 
		 pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp), 
		 com_array.comments(com_array.Ncoms).comment_no,
		 ltrim(com_array.comments(com_array.Ncoms).err_msg(2)),
		 maxlength(d.ag.input.summary));
	        else call check_error (error_table_$bigarg, CALLER, "^/^a^/^3xThe length of comment ^d is ^a which exceeds max allowable length of ^d.",
		 pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), 
		 com_array.comments(com_array.Ncoms).comment_no,
		 ltrim(com_array.comments(com_array.Ncoms).err_msg(2)), 
		 maxlength(d.ag.input.summary));
	        end;
	     end;

	  if ^d.Scfix & d.Scfix_found & d.ag.op.name = INSTALL then
						/* if cfix value present; install op invalid	*/
	     call check_error (error_table_$bad_arg, CALLER, "^/^a^/^3xA module may not be installed with critical fix numbers present.",
	     pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
	  if cfix_required() then
	      call check_error (error_table_$improper_data_format, CALLER, "^a^/^3x^a^/^3xA critical fix number is required.", 
	     d.ag.input.value.approve_value, 
	     pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
	  com_array.Ncoms = com_array.Ncoms + 1;
	  call init_structures$array(com_array.comments(com_array.Ncoms));
	  com_array.comments(com_array.Ncoms).seqno = com_array.Ncoms;
	  Pstring = Pcomment_line;
	  Lstring = Lcomment_line + length(NL);
	  end;
         end;
      else
         Lstring = Lstring + Lcomment_line + length(NL);
      end;


   call hcom_parse_ (ERROR_RETURN_LABEL, segment, string, com_path, Sprt_path, Pd,
      com_array.comments(com_array.Ncoms), code);

   if com_array.comments(com_array.Ncoms).err_msg(1) ^= "" then do;
      err_code = convert (err_code, ltrim(com_array.comments(com_array.Ncoms).err_msg(1)));
      if err_code = error_table_$improper_data_format then do;
         if d.ag.op.type = NO_MODIFY then
	  call ioa_ ("^/^a^/^3xComment ^d has null approve and audit values a null install value is required.",
            pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
            com_array.comments(com_array.Ncoms).comment_no);
         else call check_error (error_table_$improper_data_format, CALLER, "^/^a^/^3xComment ^d has null approve and audit values a null install value is required.",
	  pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), 
	  com_array.comments(com_array.Ncoms).comment_no);
         end;
      else if err_code = error_table_$bigarg then do;
	  if d.ag.op.type = NO_MODIFY then
	     call ioa_ ("^/^a^/^3xThe length of comment ^d is ^a which exceeds max allowable length of ^d.", 
	     pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp), 
	     com_array.comments(com_array.Ncoms).comment_no,
	     ltrim(com_array.comments(com_array.Ncoms).err_msg(2)),
	     maxlength(d.ag.input.summary));
	  else call check_error (error_table_$bigarg, CALLER, "^/^a^/^3xThe length of comment ^d is ^a which exceeds max allowable length of ^d.",
	     pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), 
	     com_array.comments(com_array.Ncoms).comment_no,
	     ltrim(com_array.comments(com_array.Ncoms).err_msg(2)), 
	     maxlength(d.ag.input.summary));
	  end;
         end;

   if ^d.Scfix & d.Scfix_found & d.ag.op.name = INSTALL then/* if cfix value present; install op invalid	*/
      call check_error (error_table_$bad_arg, CALLER, "^/^a^/^3xA module may not be installed with critical fix numbers present.",
      pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
   if cfix_required() then
      call check_error (error_table_$bad_arg, CALLER, "^a^/^3x^a^/^3xA critical fix number is required.", 
      d.ag.input.value.approve_value, 
      pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));

   call field_check();

   return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */

cfix_required:
   proc returns (bit(1));

/* If a critical fix number currently exists in a history comment then:     */
/*      add     critical fix number will always be required		      */
/*      af      critical fix number required if the field being added is    */
/*              the approve field.                                          */
/*      install critical fix numbers are not allowed for installation       */
/*              This is part of the install check and not relevant to       */
/*              needing a critical fix number.                              */
/*      rpf     always ok to replace                                        */
/*      fmt     always ok to format                                         */

   if d.Scfix & d.ag.op.type = MODIFY &
      index(d.ag.input.value.approve_value,"fix_") = 0 then do;
      if d.ag.op.name = ADD then
         return (TRUE);
      else if d.ag.op.name = ADD_FIELD then
         if d.ag.input.apv ^= NOxxx then
         return (TRUE);
      end;
      
   return (FALSE);

end cfix_required;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

field_check:
   proc;

dcl	date_ck			char(8),
	comment_ck		fixed bin;

   date_ck = com_array.comments(1).change_dt;
   comment_ck = com_array.comments(1).comment_no;
   if com_array.comments(1).change_person = com_array.comments(1).audit_person then
      call check_error (-1, "", "^a^/^3xThe same person (^a) is given as both change person and auditor^/^3xin comment ^d.  The ^a operation stops.",
      com_path, com_array.change_person(1),
         com_array.comment_no(1), oper(d.ag.op.name,1));

   do i = 2 to com_array.Ncoms;			/* check to be sure comment nos are in sequence.	*/
      if com_array.comments(i).change_person = com_array.comments(i).audit_person then
         call check_error (-1, "", "^a^/^3xThe same person (^a) is given as both change person and auditor^/^3xin comment ^d.  The ^a operation stops.",
	  com_path, com_array.change_person(i),
	  com_array.comment_no(i), oper(d.ag.op.name,1));
      if com_array.comments(i).change_dt > current_date then
         call check_error(-1, "", "^a^/^3xComment number ^d date (^a) is greater than todays date (^a).^/^3xThe ^a operation stops.",
         com_path, com_array.comments(i).comment_no, com_array.comments(i).change_dt,
         current_date, oper(d.ag.op.name,1));

      if ^ d.ag.ctl.renumber then do;
         if com_array.comments(i).change_dt < date_ck then
	  call check_error (-1, "", "^a^/^3xComment dates are out of sequence.  Date (^a) in comment ^d occurs^/^3xafter date (^a) in comment ^d.  The ^a operation stops.",
	  com_path, com_array.comments(i).change_dt,
	  com_array.comments(i).comment_no, date_ck, comment_ck,
	  oper(d.ag.op.name,1));
         else
	  date_ck = com_array.comments(i).change_dt;
         if com_array.comments(i).comment_no < comment_ck then
	  call check_error(-1, "", "^a^/^3xComment numbers are out of sequence.  Comment ^d occurs^/^3xafter number ^d.  The ^a operation stops.",
            com_path, com_array.comments(i).comment_no, comment_ck,
	  oper(d.ag.op.name,1));
         else if com_array.comments(i).comment_no = comment_ck then
	  call check_error(-1, "", "^a^/^3xComment number ^d is repeated in comments ^d and ^d.^/^3xThe ^a operation stops.",
	  com_path, comment_ck, i-1, i, oper(d.ag.op.name,1));
         else
	  comment_ck = com_array.comments(i).comment_no;
         end;
      else
         comment_ck = com_array.comments(i).comment_no;
      end;

   end field_check;

  end process_tokens;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

line$cmt:
   proc returns(bit(1));

dcl	Iline			fixed bin(24);

   if length(comment) = 0 then
      return(FALSE);
   Iline = index(comment,NL);
   if Iline = 0 | Lcomment - Iline = 0 then do;
      Pcomment_line = Pcomment;
      Lcomment_line = length(comment);
      Lcomment = 0;
      end;
   else do;
      Pcomment_line = Pcomment;
      Lcomment_line = Iline - 1;
      Pcomment = addcharno(addr(comment_chr(Iline)), 1);
      Lcomment = Lcomment - Iline;
      end;

   return (TRUE);

   end line$cmt;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


line$new_cmt:
   proc returns(bit(1));

dcl      Ibreak			fixed bin(21),
         Inonwhite			fixed bin(21),
         Iskip			fixed bin(21),
         Lword_text                     fixed bin(21),
         Pword_text			ptr;
         
 dcl     word_text			char(Lword_text) based(Pword_text),
         word_text_arr (Lword_text)	char(1) based(Pword_text),
         word (2)                       char(80) var,
         Nwords                         fixed bin;

 dcl     WORD_BREAKS		char(4) int static options(constant) init("	 ()");
						/* HT SP ( and )					*/


   if index(comment_line,"change") = 0 |		/* do not parse if not change line		*/
      verify(before(comment_line,"change"),"0123456789 )") ^= 0 then
      return(FALSE);

   Pword_text = Pcomment_line;
   Lword_text = Lcomment_line;
   Nwords = 0;
   word (*) = "";

   Inonwhite = verify (word_text, HT_SP);		/* skip over white space			*/
   if Inonwhite = 0 then
      Lword_text = 0;
   else if Inonwhite > 1 then do;
      Pword_text = addr(word_text_arr(Inonwhite));
      Lword_text = length(word_text) - (Inonwhite-1);
      end;

   do while (Lword_text > 0 & Nwords <= dim(word,1));
      Ibreak = search (word_text, WORD_BREAKS);
      if Ibreak = 0 then
         Ibreak = length(word_text) + 1;
      if Ibreak > 1 then do;
         Nwords = Nwords + 1;
         if Nwords <= dim(word,1) then
	  word(Nwords) = substr(word_text,1,Ibreak-1);
         Pword_text = addr(word_text_arr(Ibreak));
         Lword_text = length(word_text) - (Ibreak-1);
         end;
      Iskip = verify(word_text,WORD_BREAKS);		/* skip over all consecutive breaks chars	*/
      if Iskip >0 then do;
         Pword_text = addr(word_text_arr(Iskip));
         Lword_text = length(word_text) - (Iskip-1);
         end;
      else
         Lword_text = 0;				/* nothing but break characters remain		*/
      end;
      
   if verify(word(1),"0123456789") = 0 & word(2) = "change" then
      return(TRUE);
   else
      return(FALSE);

   end line$new_cmt;


 end comment_parse;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

comments_comparable:

   proc (src, orig) returns (bit(1));

dcl	1 (src, orig)		aligned like src_array.comments;

   return (src.change_dt = orig.change_dt &
	 src.change_person = orig.change_person);

comments_equal:
   entry (src, orig) returns (bit(1));

   return (src.audit_dt = orig.audit_dt &
	 src.audit_person = orig.audit_person &
	 src.install_dt = orig.install_dt &
	 src.install_id = orig.install_id &
	 src.summary = orig.summary);

comments_almost_equal:
   entry (src, orig) returns (bit(1));

    if src.audit_dt = orig.audit_dt &
       src.audit_person = orig.audit_person &
       src.summary = orig.summary then
       return(TRUE);
    else
       return(FALSE);

end comments_comparable;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

COMPARE_modules:
   proc;

dcl	Scomparable		bit(1),
	last_eq_orig_comment	fixed bin;

   if orig_array.Ncoms > 0 then
      orig_array.comments(*).Ieq = 0;
   if src_array.Ncoms > 0 then
      src_array.comments(*).Ieq = 0;
   last_eq_orig_comment = 0;

   do i = 1 to src_array.Ncoms;
      Scomparable = FALSE;
      do j = last_eq_orig_comment+1 to orig_array.Ncoms while(^Scomparable);
         if comments_comparable (src_array.comments(i), orig_array.comments(j)) then do;
	  Scomparable = TRUE;
	  if (d.ag.op.name = INSTALL & comments_almost_equal(src_array.comments(i), orig_array.comments(j))) | 
	     (d.ag.op.name ^= INSTALL & comments_equal (src_array.comments(i), orig_array.comments(j))) then do;
	     orig_array.comments(j).Ieq = i;
	     src_array.comments(i).Ieq, last_eq_orig_comment = j;
	     end;
	  end;
         end;
      end;

   end COMPARE_modules;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

display_comments:
   proc(Sany_found);
  
dcl	Sany_found		bit(1),
	Serrors			bit(1);

dcl	Iorig			fixed bin,
	Isrc			fixed bin,
	Nskip_src			fixed bin,
	Nskip_orig		fixed bin;

   call form_string$init();
   goto DISPLAY(d.ag.op.name);

DISPLAY(1):					/* ADD					*/
DISPLAY(2):					/* ADD_FIELD				*/
DISPLAY(7):					/* FORMAT					*/
DISPLAY(10):					/* REPLACE_FIELD				*/
   call display_selected_comments("");
   return;

DISPLAY(3):					/* CHECK					*/
   Serrors = FALSE;
   if ^Sany_found then do;
      if d.ctl.errors then
         call ioa_("^/^a:^/^3xERROR:  Either an audit or approve field is missing from a comment
^15x----- or -----^/^11xNo new comments were found.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      else if ^d.Saf then
         call ioa_ ("^/^a:^/^3xFailed the history comment check.",
	  pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp));
      if d.Saf then
         call d.set_return_arg("false");
      end;
   else do;
      if d.orig.path ^= "" then do i = 1 to orig_array.Ncoms;
         if orig_array.comments(i).Ieq = 0 then
	  Serrors = TRUE;
	  end;

         if Serrors then do;
	  if ^d.Saf then
	     call ioa_("^/ORIGINAL:^3x^a^/NEW SOURCE:^x^a^/^/The original and source are not equal. For more information use the compare^/operation.",
               pathname_$component (d.orig_seg.dir, d.orig_seg.ent, d.orig_seg.comp),
	     pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp));
	  else
	     call d.set_return_arg("false");
	  end;

      if ^d.Saf & ^Serrors then
         call ioa_ ("^/^a:^/^3xHas correct history comments.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      end;
   return;

DISPLAY(4):					/* COMPARE				*/
   Iorig = 1;
   Nskip_src = 0;
   Nskip_orig = 0;
   do Isrc = 1 to src_array.Ncoms;
      if src_array.comments(Isrc).Ieq  = 0 then		/* Haven't found a source comment matched by orig */
         Nskip_src = Nskip_src + 1;			/* yet.					*/
      else if src_array.comments(Isrc).Ieq ^= 0 then do;
         Nskip_orig = src_array.comments(Isrc).Ieq - Iorig;
         if Nskip_orig = 0 & Nskip_src = 0 then		/* no differences found so far		*/
	  Iorig = Iorig + 1;
         else if Nskip_orig > 0 & Nskip_src = 0 then do;	/* differences in the original		*/
	  call form_string$fixed(NL);
	  do j = Iorig to src_array.comments(Isrc).Ieq-1;
	     call format_comment$body(orig_array.comments(j));
	     end;
	  call form_string$fixed_line(".unl 5");
	  call form_string$fixed_line("Deleted from source prior to:");
	  call format_comment$body(src_array.comments(Isrc));
	  Iorig = src_array.comments(Isrc).Ieq+1;
	  end;
         else if Nskip_src > 0 & Nskip_orig = 0 then do;	/* differences in the source			*/
	  call form_string$fixed(NL);
	  do j = Isrc - Nskip_src to Isrc-1;
	     call format_comment$body(src_array.comments(j));
	     end;
	  call form_string$fixed_line(".unl 5");
	  call form_string$fixed_line("Inserted in source prior to:");
	  call format_comment$body(src_array.comments(Isrc));
	  Iorig = src_array.comments(Isrc).Ieq+1;
	  Nskip_src = 0;
	  end;
         else if Nskip_src > 0 & Nskip_orig > 0 then do;	/* differences in both source & orig		*/
	  call form_string$fixed(NL);
	  do j = Iorig to src_array.comments(Isrc).Ieq-1;
	     call format_comment$body(orig_array.comments(j));
	     end;
	  call form_string$fixed_line(".unl 5");
	  call form_string$fixed_line("Changed in source to:");
	  do j = Isrc - Nskip_src to Isrc-1;
	     call format_comment$body(src_array.comments(j));
	     end;
	  Iorig = src_array.comments(Isrc).Ieq+1;
	  Nskip_src = 0;
	  end;
         end;
      end;
   Nskip_orig = orig_array.Ncoms - Iorig + 1;
   if Nskip_src > 0 & Nskip_orig = 0 then do;		/* comments inserted in source at end.		*/
      call form_string$fixed(NL);
      do j = Isrc - Nskip_src to hbound(src_array.comments,1);
         call format_comment$body(src_array.comments(j));
         end;
      call form_string$fixed_line(".unl 5");
      call form_string$fixed_line("Inserted in source at end.");
      end;
   else if Nskip_orig > 0 & Nskip_src = 0 then do;	/* comments deleted from end of original.	*/
      call form_string$fixed(NL);
      do j = Iorig to hbound(orig_array.comments,1);
         call format_comment$body(orig_array.comments(j));
         end;
      call form_string$fixed_line(".unl 5");
      call form_string$fixed_line("Deleted from end of original.");
      end;
   else if Nskip_orig > 0 & Nskip_src > 0 then do;	/* comments at end replaced by other comments.	*/
      call form_string$fixed(NL);
      do j = Iorig to hbound(orig_array.comments,1);
         call format_comment$body(orig_array.comments(j));
         end;
      call form_string$fixed_line(".unl 5");
      call form_string$fixed_line("Changed in source to:");
      do j = Isrc - Nskip_src to hbound(src_array.comments,1);
         call format_comment$body(src_array.comments(j));
         end;
      end;
   if d.Saf then do;
      if formed_string = "" then;			/* Result is "true" if all origs = all sources.	*/
						/* "true" was set in hcom.pl1 as the initial 	*/
						/*   return value.				*/
      else
         call d.set_return_arg ("false");
      end;
   else do;
      if formed_string = "" then do;
         if src_array.Ncoms = 0 & orig_array.Ncoms = 0 then
	  call form_string$fixed_line (
	     "     No history comments found in source or original.");
         else
	  call form_string$fixed_line(
	     "     History comments are identical.");
         Presult = Pformed_string;
         Lresult = Lformed_string;
         end;
      else
         call format_comment$fdoc(get_line_length_$switch(null,code));
      call ioa_("^/ORIGINAL:^3x^a^/NEW SOURCE:^x^a^/^a",
         pathname_$component (d.orig_seg.dir, d.orig_seg.ent, d.orig_seg.comp),
         pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp),
         result);
      end;
   return;

DISPLAY(5):					/* DISPLAY				*/
   if ^Sany_found then				/* error means no slection criteria was met	*/
      call check_error (-1, "", "^a^/^3xNo^[^; matching^] history comments.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
         string(d.com_spec.selected) = ALL & d.com_spec.Nrange = 0);
   call display_selected_comments("");
   return;

DISPLAY(6):					/* EXISTS					*/
   if ^Sany_found then 
      call d.set_return_arg("false");

   return;

DISPLAY(8):					/* GET					*/
   return;
DISPLAY(9):					/* INSTALL				*/
   return;
      
display_selected_comments:
   proc (extra_msg);

dcl	extra_msg			char(*);

   do i = 1 to src_array.Ncoms;
      if src_array.comments(i).selected then do;
         call format_comment$body(src_array.comments(i));
         end;
      end;
   call format_comment$fdoc(get_line_length_$switch(null,code));
   call ioa_$nnl("^/^a:^[^/^3x^a^;^s^]^/^a",
      pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
      extra_msg ^= "", extra_msg, result);
   end display_selected_comments;

   end display_comments;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/* This internal procdure is used to build a string to submit to format document*/

dcl	Pformed_string		ptr,
	Lformed_string		fixed bin(21),
	formed_string		char(Lformed_string) based(Pformed_string),
	formed_string_array (Lformed_string)
				char(1) based(Pformed_string);

form_string$fixed:
   proc (fixed_str);
  
dcl	fixed_str			char(*) aligned,
	Lorig			fixed bin(21);
  
   Lorig = length(formed_string);
   Lformed_string = length(formed_string) + length(fixed_str);
   substr(formed_string, Lorig+1) = fixed_str;
   return;

form_string$fixed_line:				/* This entrypoint ensures the string is placed	*/
   entry (fixed_str);				/* on a line by itself.			*/

   if length(formed_string) > 0 then
   if substr(formed_string, length(formed_string), length(NL)) ^= NL then do;
      Lformed_string = Lformed_string + length(NL);
      substr(formed_string,length(formed_string),length(NL)) = NL;
      end;
   Lorig = length(formed_string);
   Lformed_string = length(formed_string) + length(fixed_str);
   substr(formed_string, Lorig+1) = fixed_str;
   if substr(formed_string, length(formed_string), length(NL)) ^= NL then do;
      Lformed_string = Lformed_string + length(NL);
      substr(formed_string,length(formed_string),length(NL)) = NL;
      end;
   return;   

form_string$var:
   entry (var_str);
  
dcl	var_str			char(*) var;

   Lorig = length(formed_string);
   Lformed_string = length(formed_string) + length(var_str);
   substr(formed_string, Lorig+1) = var_str;
   return;

form_string$init:
   entry;

   Lformed_string = 0;
   Pformed_string = d.temp_seg.Pformed_string;

   end form_string$fixed;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

dcl	Presult			ptr,
	Lresult			fixed bin(21),
	result			char(Lresult) based(Presult),
	result_array(Lresult)	char(1) based(Presult);

format_comments:
   proc;

dcl	chr_cmtno			char(4) aligned,
	footer			char (74) aligned,
	header			char (79) var,
   	ll			fixed bin,
	save_footer		char (74) var;	/* undented 5 */

   if d.seg.type = 1 | d.seg.type = 4 then do;
      if Sblank_before then
         header = NL || d.seg.cmt_bgn || SP || "HISTORY COMMENTS:" || NL;
      else
         header = d.seg.cmt_bgn || SP || "HISTORY COMMENTS:" || NL;
      save_footer = "END HISTORY COMMENTS" || SP || d.seg.cmt_end;      
      ll = 79;
      end;
   else do;					/* exec com or alm				*/
      if Sblank_before then
         header = NL || SP || "HISTORY COMMENTS:" || NL;
      else
         header = SP || "HISTORY COMMENTS:" || NL;
      save_footer = "END HISTORY COMMENTS";
      ll = 79 - (length(d.seg.cmt_bgn) + length(SP));
      end;
   footer = "";
   substr(footer,length(footer)-length(save_footer)+1) = save_footer;

   call form_string$init();
   call form_string$var(header);
   do i = 1 to src_array.Ncoms;
      call format_comment$body(src_array.comments(i));
      end;
   call form_string$fixed_line(".inl 0");
   call form_string$fixed_line(footer);
   if Sblank_after then
      call form_string$fixed(NL);
   call format_comment$fdoc(ll);

   if d.seg.type ^= 1 & d.seg.type ^= 4 then do;		/* add comment beginning for non-pl1 source	*/
      call form_string$init();
      do while (Lresult > 0);
         i = index(result,NL);
         if i > 0 then do;
	  if d.seg.type = 2 & substr(result,1,i-1) = "" then
						/* dont add cmt_bgn for blank lines for alm progs	*/
	     call form_string$fixed(substr(result,1,i));
	  else
	     call form_string$fixed(d.seg.cmt_bgn || substr(result,1,i));
	  Presult = addcharno(addr(result_array(i)), 1);
	  Lresult = Lresult - i;
	  end;
         else do;
	  call form_string$fixed(d.seg.cmt_bgn || result);
	  Lresult = 0;
	  end;
         end;
      Lresult = Lformed_string;			/* reset result				*/
      Presult = Pformed_string;
      end;
   return;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

format_comment$body:
   entry(cmt);

dcl	1 cmt			aligned like src_array.comments;

   call form_string$fixed_line(".inl 5");
   call form_string$fixed_line(".unl 5");
   chr_cmtno = reverse(ltrim(char(cmt.comment_no)) || ")");
   chr_cmtno = reverse(chr_cmtno);
   call form_string$fixed(chr_cmtno);
   call form_string$fixed(" change");
   call form_string$fixed("(");
   call form_string$fixed(cmt.change_dt);
   call form_string$fixed(",");
   call form_string$var(cmt.change_person);
   call form_string$fixed(")");
   if cmt.approve_dt ^= "" then do;
      call form_string$fixed(",");
      call form_string$fixed(NL);
      call form_string$fixed("approve");
      if cmt.approve_dt = "^" then 
         call form_string$fixed("()");
      else do;
         call form_string$fixed("(");
         call form_string$fixed(cmt.approve_dt);
         call form_string$fixed(",");
         call form_string$var(cmt.approve_value);
         call form_string$fixed(")");
         end;
      end;
   if cmt.audit_dt ^= "" then do;
      call form_string$fixed(",");
      call form_string$fixed(NL);
      call form_string$fixed("audit");
      if cmt.audit_dt = "^" then 
         call form_string$fixed("()");
      else do;
         call form_string$fixed("(");
         call form_string$fixed(cmt.audit_dt);
         call form_string$fixed(",");
         call form_string$var(rtrim(cmt.audit_person));
         call form_string$fixed(")");
         end;
      end;
   if cmt.install_dt ^= "" then do;
      call form_string$fixed(",");
      call form_string$fixed(NL);
      call form_string$fixed("install");
      if cmt.install_dt = "^" then 
         call form_string$fixed("()");
      else do;
         call form_string$fixed("(");
         call form_string$fixed(cmt.install_dt);
         call form_string$fixed(",");
         call form_string$var(cmt.install_id);
         call form_string$fixed(")");
         end;
      end;
   call form_string$fixed(":  ");
   call form_string$fixed_line(".brf");
   if cmt.fill then do;
      call form_string$fixed_line(".fin");
      call form_string$var(cmt.summary);
      call form_string$fixed_line(".fif");
      end;
   else do;
      call form_string$fixed_line(".fif");
      call form_string$var(cmt.summary);
      end;
   call form_string$fixed_line(".fin");
   end format_comments;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


format_comment$fdoc:
   proc (line_length);

dcl	line_length		fixed bin;

   unspec(fdoc) = "0"b;
   fdoc.version_number = format_document_version_2;
   fdoc.line_length = line_length;
   fdoc.switches = "0"b;
   fdoc.pgno_sw = "0"b;
   fdoc.adj_sw = "0"b;
   fdoc.galley_sw = "1"b;
   fdoc.error_sw = "0"b;
   fdoc.literal_sw = "0"b;
   fdoc.dont_compress_sw = "1"b;
   fdoc.break_word_sw = "1"b;
   fdoc.max_line_length_sw = "1"b;
   fdoc.dont_break_indented_lines_sw = "1"b;
   fdoc.sub_err_sw = "1"b;
   fdoc.dont_fill_sw = "0"b;
   fdoc.hyphenation_sw = "0"b;

   Presult = d.temp_seg.Presult;
   Lresult = sys_info$max_seg_size*CHARS_PER_WORD;
   call format_document_$string(formed_string, result, Lresult, addr(fdoc), code);
   if code ^= 0 & code ^= error_table_$recoverable_error then
      call check_error (code, CALLER, "^/^3xError while formatting the string.", formed_string);

end format_comment$fdoc;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

GET_fields:
   proc;

call form_string$init();
call form_string$fixed_line(".inl 3");

do i = 1 to src_array.Ncoms;
   if src_array.comments(i).selected then do;
      do j = 1 to hbound(d.field_array,1) while(d.field_array(j) ^= 0);
         if j = 1 then
	  call form_string$fixed_line(".unl 3");
         goto CASE(d.field_array(j));
CASE(0):						/* ERROR - no fields were selected		*/
      call check_error (error_table_$bad_arg, CALLER, "^a^/^3xNo field values were selected.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
CASE(1):						/* change date				*/
      if d.Saf then
         call d.add_to_return_arg((src_array.comments(i).change_dt));
      else do;
         call form_string$fixed(src_array.comments(i).change_dt);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(2):						/* change person id				*/
      if d.Saf then
         call d.add_to_return_arg_var(src_array.comments(i).change_person);
      else do;
         call form_string$var(src_array.comments(i).change_person);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(3):						/* approve date				*/
      if d.Saf then
         call d.add_to_return_arg((src_array.comments(i).approve_dt));
      else do;
         call form_string$fixed(src_array.comments(i).approve_dt);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(4):						/* approve value				*/
      if d.Saf then
         call d.add_to_return_arg_var(src_array.comments(i).approve_value);
      else do;
         call form_string$var(src_array.comments(i).approve_value);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(5):						/* audit date				*/
      if d.Saf then
         call d.add_to_return_arg((src_array.comments(i).audit_dt));
      else do;
         call form_string$fixed(src_array.comments(i).audit_dt);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(6):						/* auditor				*/
      if d.Saf then
         call d.add_to_return_arg_var(src_array.comments(i).audit_person);
      else do;
         call form_string$var(src_array.comments(i).audit_person);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(7):						/* install date				*/
      if d.Saf then
         call d.add_to_return_arg((src_array.comments(i).install_dt));
      else do;
         call form_string$fixed(src_array.comments(i).install_dt);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(8):						/* install id				*/
      if d.Saf then
         call d.add_to_return_arg_var(src_array.comments(i).install_id);
      else do;
         call form_string$var(src_array.comments(i).install_id);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
CASE(9):						/* summary				*/
      if d.Saf then
         call d.add_to_return_arg_var(src_array.comments(i).summary);
      else do;
         call form_string$var(src_array.comments(i).summary);
         call form_string$fixed(" ");
         end;
      goto END_CASE;
END_CASE:
      end;
   end;
  end;
  if ^d.Saf then do;
     call format_comment$fdoc (get_line_length_$switch(null,code));
     call ioa_("^a",result);
     end;

end GET_fields;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

get_language_info:
   proc(seg);

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure determines the parameters of the language of the source segment. These	*/
	/* parameters are: type, name, and comment begin and end delimiters.			*/
	/* If the source is an exec_com or absin, there are two added parameters needed: the	*/
	/* version (ec_version) and the character position of the first non-version character	*/
	/* (text_pos). These values are obtained from calling get_ec_version_.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl 1 seg		    aligned like d.seg;

dcl comp_or_ent         char(32);

dcl Acode		    fixed bin(35),
    Ilang               fixed bin,
    language            char(8) var;			/* language name */

%include pnotice_language_info_;

   seg.ec_version = 0;
   seg.text_pos = 0;
   if seg.comp = "" then				/* determine if archive component or entry name	*/
      comp_or_ent = seg.ent;
   else
      comp_or_ent = seg.comp;
   if index(comp_or_ent, ".") = 0 then			/* primarily for the archive case, if it is a */
      call check_error (error_table_$bad_file_name, CALLER, "^/^3x^a^/^3xSingle-component entrynames not permitted.",
         pathname_$component (seg.dir, seg.ent, seg.comp)); /*check_error returns a code of 0 & comes back here*/
   language = reverse(before(reverse (comp_or_ent), "."));	/* determine language name			*/

   do Ilang = 1 to hbound(pnotice_language_info.languages.lang_array, 1) while
      (language ^= pnotice_language_info.languages.lang_array(Ilang).lang_name);
      end;					/* look it up in pnotice_language_info_ */
   if Ilang > pnotice_language_info.languages.N then do;
      if language = "archive" then
         call check_error (-1, CALLER, "^a^/^3xArchived archives are not supported.",
	  pathname_$component (seg.dir, seg.ent, seg.comp));
      else
         call check_error (-1, CALLER, "^a^/^3xThe ^a suffix is not supported because it is not defined in^/^3xpnotice_language_info_. Entry not processed.",
         pathname_$component(d.seg.dir,d.seg.ent,d.seg.comp),language);
      end;

   seg.type = pnotice_language_info.languages.lang_array(Ilang).lang_type;
						/* type better be 1, 2, 3, 4, or 5	*/
   if seg.type < 1 | seg.type > 5 then
      call check_error (-1, CALLER, "^a^/^3xLanguage type (^d) found for the ^a suffix in pnotice_language_info_
is not implemented.",
         pathname_$component(seg.dir, seg.ent, seg.comp),seg.type, language);
						/* get comment delimiters               */
   seg.cmt_bgn = pnotice_language_info.languages.lang_array(Ilang).comment_start;
   seg.cmt_end = pnotice_language_info.languages.lang_array(Ilang).comment_end;

   if seg.type = 3 then do;
      if d.seg.comp ^= "" then			/* can't support archived exec_coms		*/
         call check_error (-1, CALLER, "^a^/^3xProcessing of archived exec_coms is not supported.",
	  pathname_$component (seg.dir, seg.ent, seg.comp));

      call get_ec_version_ (d.seg.dir, d.seg.ent, seg.ec_version, seg.text_pos, Acode);
      if Acode ^= 0 then
         call check_error (Acode, CALLER, "^a^/^3xGetting ec version.",
	  pathname_$component(seg.dir, seg.ent, seg.comp));
      if seg.text_pos < 1 then			/* prevent invalid subscripting */
         seg.text_pos = 1;
      if seg.ec_version = 1 then
         seg.cmt_bgn = seg.cmt_bgn || SP;
      else
         seg.cmt_bgn = seg.cmt_bgn || "-";
      end;
   end get_language_info;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/


init_structures:
	proc;

init_structures$array:				/* initialize fields of arrays		*/
  entry(array_in);
  
  dcl 1 array_in               aligned like src_array.comments;
  
  array_in.change_dt = "";
  array_in.seqno = 0;
  array_in.fill = "0"b;
  array_in.selected = "0"b;
  array_in.Ieq = 0;
  array_in.comment_no = 0;
  array_in.change_person = "";
  array_in.approve_dt = "";
  array_in.approve_value = "";
  array_in.audit_dt = "";
  array_in.audit_person = "";
  array_in.install_dt = "";
  array_in.install_id = "";
  array_in.summary = "";
  array_in.err_msg = "";

  return;

init_structures$src_array:
	entry;
        	      
   Psrc_array = d.temp_seg.Psrc_array;
   src_array.Ncoms = 0;
   return;

init_structures$orig_array:
          entry;

   Porig_array = d.temp_seg.Porig_array;
   orig_array.Ncoms = 0;
   return;

end init_structures;



/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

insert_notice:
   proc;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure adds the notice to a segment. In the case of free-standing segments,	*/
	/* the target is the segment itself, but for archives, the target is a copy of the	*/
	/* archive component in the process dir. The archive command then will update the	*/
	/* archive via process_archive_components.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

dcl	Psource			ptr,
	Ptarget			ptr,
	new_box			char(d.seg.Lnewbox) based (d.seg.Pbox);

    d.seg.Lnewbox = Lresult;				/* lgth of pnotice + lgth of comments		*/

    Psource = addcharno (d.seg.Pbox, d.seg.Loldbox);	/* ptr to start of history comment box		*/
                                                            /* + length of old history comments		*/
    Ptarget = addcharno (d.seg.Pbox, d.seg.Lnewbox);	/* ptr to start of history comment box		*/
                                                            /* + length of result (old + new) history comments*/
						/* determine proper size hole for append */
						/* if new box is same size, we go by this. */
    if d.seg.Lnewbox > d.seg.Loldbox then		/* new notice box larger than old */
       call pnotice_mrl_ (Psource, d.seg.Lseg_in - d.seg.Loldbox, Ptarget, d.seg.Lseg_in - d.seg.Loldbox);
						/* append seg */
    else if d.seg.Lnewbox < d.seg.Loldbox then		/* new notice box smaller than old */
						/* this may happen if source had >1 box in it */
      call pnotice_mlr_ (Psource, d.seg.Lseg_in - d.seg.Loldbox, Ptarget, d.seg.Lseg_in - d.seg.Loldbox);

    d.seg.Lseg_out = (d.seg.Lseg_in - d.seg.Loldbox) + d.seg.Lnewbox;

    new_box = result;
						/* copy box back from temp storage */

end insert_notice;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

INSTALL_ck:
   proc;

   dcl   Snew_comment		bit,
         Sequal			bit,
         Serrors			bit,
         Sinstall			bit,
         Sinstall_match		bit,
         Sapprove			bit;
   

/* The following generic errors will be generated:						*/
/*   No missing approve values were found.							*/
/*   No missing install values were found.							*/
/*   (path) contains no new comments.								*/
/*											*/
/* The following individual cmt errors will be put in err_msg as appropriate:				*/
/*   has been backed out.									*/
/*   is missing audit value(s).								*/
/*   is misssing summary.									*/
/*   original installation id MRxxx.x-xxxx is different.						*/

   Snew_comment = FALSE;
   Sany_found = FALSE;
   Serrors = FALSE;
   Sinstall = FALSE;
   Sinstall_match = FALSE;
   Sapprove = FALSE;
   call form_string$init();				/* The select switch is on for those cmts selected*/
						/* Set the switch off for those not in error	*/
						/* as only these will be printed		*/
   
   if d.ag.orig.path = "" then 
      ;
   else if Porig_array ^= null then
           if orig_array.Ncoms > 0 then			/* new module being installed	or no cmts in orig	*/
              goto ORIG_CK;

SRC_CK:
   if src_array.Ncoms = 0 then do;			/* error no comments are present		*/
      Serrors = TRUE;
      if ^d.Saf then
         call check_error (error_table_$improper_data_format, CALLER, "^a contains no comments.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      end;
   else do;
      src_array.comments(*).selected = FALSE;
      goto INSTALL_values;
      end;

ORIG_CK:
   do i = 1 to src_array.Ncoms;			/* find out if there are new comments in source	*/
						/* check install ids			*/
      k = 0;
      Sequal = FALSE;
      do j = 1 to orig_array.Ncoms while(^Sequal);
         if comments_comparable(src_array.comments(i), orig_array.comments(j)) then do;
	  if comments_almost_equal (src_array.comments(i), orig_array.comments(j)) then do;
						/* src, audit, and summary fields are equal	*/
	     if src_array.comments(i).install_id = "" then do;
						/* src install id will be equal to orig 	*/
	        src_array.comments(i).install_id = orig_array.comments(j).install_id;
	        src_array.comments(i).install_dt = orig_array.comments(j).install_dt;
	        src_array.comments(i).selected = TRUE;
	        Sequal = TRUE;			/* if requested install id matches an existing id	*/
						/* set switch so no error will be flaged on AF	*/
	        end;
	     else if src_array.comments(i).install_id ^= orig_array.comments(j).install_id then do;
						/* installation ids must be the same		*/
	        Serrors = TRUE;
	        src_array.comments(i).err_msg(k+1) = ("original installation id "
		 || orig_array.comments(j).install_id || " is different");
	        end;
	     end;
	  if ^Sequal & comments_equal (src_array.comments(i), orig_array.comments(j)) then do;
	     src_array.comments(i).selected = FALSE;
	     orig_array.comments(j).selected = FALSE;
	     Sequal = TRUE;
	     end;
	  end;
         if ^Sequal then				/* new comment found			*/
	  Snew_comment = TRUE;
      end;
   end;

   if ^Snew_comment then do;
      Serrors = TRUE;
      if ^d.Saf then
         call check_error (error_table_$improper_data_format, CALLER, "^a contains no new comments.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      end;
      
   do i = 1 to orig_array.Ncoms;
      if orig_array.comments(i).Ieq = 0 then do;
         Serrors = TRUE;
         orig_array.comments(i).selected = TRUE;
         orig_array.comments(i).err_msg(1) = "has been backed out from source.";
						/* This is the only error msg for the orig array	*/
         end;
      end;
   
INSTALL_values:
   k = 0;
   do i = 1 to src_array.Ncoms;
      if src_array.comments(i).audit_dt = ""  & src_array.comments(i).audit_person = "" then do;
         Serrors = TRUE;
         src_array.comments(i).err_msg(k+1) = "missing audit value(s).";
         src_array.comments(i).selected = TRUE;
         end;
      if src_array.comments(i).summary = "" then do;
         Serrors = TRUE;
         src_array.comments(i).err_msg(k+1) = "missing summary.";
         src_array.comments(i).selected = TRUE;
         end;
      if src_array.comments(i).approve_dt = "" & d.input.select.apv = NOxxx then do;
         Serrors = TRUE;
         src_array.comments(i).err_msg(k+1) = "missing approve field(s).";
         src_array.comments(i).selected = TRUE;
         end;
      if index(src_array.comments(i).approve_value,"fix_") > 0 
         & ^d.Scfix then do;
         Serrors = TRUE;
         src_array.comments(i).err_msg(k+1) = "contains a critical fix number.";
         src_array.comments(i).selected = TRUE;
         end;
      if src_array.comments(i).install_dt = "" then 
         Sinstall = TRUE;
      else if src_array.comments(i).install_id = d.ag.input.value.install_id then do;
						/* If an existing id matches the requested one	*/
						/* do not flag it as an error but continue	*/
	  Sinstall_match = TRUE;
	  src_array.comments(i).selected = TRUE;
	  end;

      if src_array.comments(i).approve_dt = "" then
         Sapprove = TRUE;
      end;

   if ^Sinstall & ^Sinstall_match then do;
      call d.set_return_arg("false");
      call check_error(error_table_$bad_arg, CALLER, "^/^a ^/^3xNo missing installation fields were found.",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
      end;

/* Those comments which are selected and have src_array.err_msg = "" */
/* are valid and will be updated if no other errors are present.     */

      if ^Serrors then do i = 1 to src_array.Ncoms;
         if d.input.select.apv = OPERANDxxx | d.input.select.apv = INPUTxxx then do;
	  if src_array.comments(i).approve_dt = "" & src_array.comments(i).approve_value = "" then do;
	     src_array.comments(i).approve_dt = current_date;
	     src_array.comments(i).approve_value = d.ag.input.value.approve_value;
	     src_array.comments(i).selected = TRUE;
	     Sany_found = TRUE;
	     end;
	  end;
         if src_array.comments(i).install_dt = "" then do;
	  src_array.comments(i).install_dt = current_date;
	  src_array.comments(i).install_id = d.ag.input.value.install_id;
	  src_array.comments(i).selected = TRUE;
	  Sany_found = TRUE;
	  end;
         end;

      if Sinstall_match then				/* install id in src was filled in from the orig	*/
         Sany_found = TRUE;

      if ^Serrors then do;				/* cmts were found without errors		*/
         call format_comments();
         call insert_notice();
         end;

      if ^Sany_found then do;
         if ^d.ctl.errors then do;
	  if d.Saf then
	     call d.set_return_arg("false");
	  else
	     call ioa_ ("^/^a:^/^3xFailed the preinstallation check.",
	     pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp));
	  goto ERROR_RETURN_LABEL;
	  end;
         do i = 1 to src_array.Ncoms;
	  if src_array.comments(i).selected = TRUE then do;	/* cmts were found with errors		*/
	     do j = 1 to hbound(src_array.comments.err_msg,2) while(src_array.comments(i).err_msg(j) ^= "");
	        if j = 1 then
		 call form_string$var("Comment " || ltrim(char(src_array.comments(i).comment_no)) || " ");
	        else
		 call form_string$fixed(", ");
	        call form_string$var(src_array.comments(i).err_msg(j));
	        end;
	     if src_array.comments(i).err_msg(1) ^= "" then do;
	        /* only cmts with errors are being displayed here */
	        call format_comment$body(src_array.comments(i));
	        call form_string$fixed_line(".unl 5");
	        end;
	     end;
	  end;

         if d.ag.orig.path ^= "" then do i = 1 to orig_array.Ncoms;
	  if orig_array.comments(i).selected = TRUE then do; /* only 1 error is possible with orig array	*/
	     call form_string$var("Comment " || ltrim(char(orig_array.comments(i).comment_no)) || " " || 
	        orig_array.comments(i).err_msg(1));
	     call format_comment$body(orig_array.comments(i));
	     call form_string$fixed(NL);
	     end;
	  end;
         
         call format_comment$fdoc(get_line_length_$switch(null,code));
         call ioa_("^a^/^a",pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), result);
         if d.Saf then
	  call d.set_return_arg("false");
         call check_error (-1, "", "");
         end;

      else do;
         call form_string$init();
         do i = 1 to src_array.Ncoms;
	  if src_array.comments(i).selected = TRUE then do;
	     call format_comment$body(src_array.comments(i));
	     call form_string$fixed(NL);
	     end;
	  end;
         call format_comment$fdoc(get_line_length_$switch(null,code));
         call ioa_$nnl("^a^/^a",pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp), result);
         end;

END_INSTALL_CK:
      
end INSTALL_ck;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

prompt_req:
   proc;

dcl	APV_EXP			char(57) int static options(constant) init(
"Identifier authorizing the change.  For example: MCR6734."),
	INSTALL_EXP		char(114) int static options(constant) init(
"Identifier associated with installing the changed module into the
execution libraries.  For example: MR12.0-00234."),
	SUMMARY_EXP		char(47) int static options(constant) init(
"Text summarizing the change made to the module.");

dcl      reply	                    char(maxlength(d.ag.input.summary)+1) var;

   query_info.version = 7;
   query_info.ending_delim = "";
   query_info.suppress_name_sw = TRUE;
   query_info.prompt_after_explanation = TRUE;
   query_info.cp_escape_control = "11"b;		/* Needed since nobody has called 		*/
						/* hcom_command_query_$set_cp_escape_enable.	*/

   if d.ag.input.apv = INPUTxxx then do;
      query_info.explanation_ptr = addr(APV_EXP);
      query_info.explanation_len = length(APV_EXP);
RE_APV:
      call hcom_command_query_ (addr(query_info), reply, CALLER, "Enter approve value:");
      if reply ^= "" then do;
         d.ag.input.value.approve_value = reply;
         valid = TRUE;
         if d.Scfix then
	  call hcom_cfix_validate_ ((CALLER), APPROVAL_FIELD_NAME,
	     d.ag.input.value.approve_value, valid, 
	     d.ag.input.value.approve_value,"", "");
         else
	  call d.ag.vdt ((CALLER), APPROVAL_FIELD_NAME,
	     d.ag.input.value.approve_value, valid,
	     d.ag.input.value.approve_value, "", "");
         if ^valid then
	  goto RE_APV;
         d.ag.input.value.approve_dt = current_date;
         d.ag.input.apv = OPERANDxxx;
         end;
      else
         d.ag.input.apv = NOxxx;
      end;

   if d.ag.input.in = INPUTxxx then do;
      query_info.explanation_ptr = addr(INSTALL_EXP);
      query_info.explanation_len = length(INSTALL_EXP);
RE_INSTALL:
      call hcom_command_query_ (addr(query_info), reply, CALLER, "Enter installation id:");
      if reply ^= "" then do;
         d.ag.input.value.install_id = reply;
         valid = TRUE;
         if d.Scfix then
	  call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME,
	     d.ag.input.value.install_id, valid,
	     d.ag.input.value.install_id, "", error_msg);
         else
	  call d.ag.vdt ((CALLER), INSTALL_FIELD_NAME,
               d.ag.input.value.install_id, valid,
	     d.ag.input.value.install_id, "", error_msg);
         if ^valid then do;
            call ioa_ ("^3x^a", error_msg);
	  goto RE_INSTALL;
	  end;
         d.ag.input.value.install_dt = current_date;
         d.ag.input.in = OPERANDxxx;
         end;
      else do;
         if d.ag.op.name = INSTALL then do;
	  call ioa_ ("^/^a^/The install id is required for the install operation", 
	     pathname_$component(seg.dir,seg.ent,seg.comp));
	  go to RE_INSTALL;
	  end;
         else
            d.ag.input.in = NOxxx;
         end;
      end;

   if d.ag.input.sm = INPUTxxx then do;
      query_info.explanation_ptr = addr(SUMMARY_EXP);
      query_info.explanation_len = length(SUMMARY_EXP);
      query_info.ending_delim = ".";
      query_info.ending_delim_description = "a period";
RE_SUMMARY:
      call hcom_command_query_ (addr(query_info), reply, CALLER, "Enter summary:");
      if length(reply) > maxlength(d.ag.input.summary)-15 then do;
						/* need 15 chars for compose values		*/
         call ioa_ ("^/^a^/Summary length is greater than ^d characters.",
      pathname_$component(seg.dir,seg.ent,seg.comp),maxlength(d.ag.input.summary)-15);
         goto RE_SUMMARY;
         end;
      else
         if reply ^= "" then do;
	  d.ag.input.value.summary = reply || NL;
	  d.ag.input.sm = OPERANDxxx;
	  end;
      else do;
         call ioa_ ("A summary must be provided in every history comment.");
         go to RE_SUMMARY;
         end;
      end;

   end prompt_req;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

REPLACE_FIELDs:
   proc;

   do i = 1 to src_array.Ncoms;
      if src_array.comments(i).selected then do;
         if d.ag.input.sm = OPERANDxxx then do;
	  src_array.comments(i).summary = d.ag.input.value.summary;
	  src_array.comments(i).fill = d.ag.ctl.fill;
	  end;

         if d.ag.input.apv = OPERANDxxx then do;
            src_array.comments(i).approve_value =
	     d.ag.input.value.approve_value;
            src_array.comments(i).approve_dt = d.ag.input.value.approve_dt;
            end;
         else if d.ag.input.apv = CLEARxxx then 
	  src_array.comments(i).approve_value,
	     src_array.comments(i).approve_dt = "";

         if d.ag.input.aud = OPERANDxxx then do;
	  if src_array.comments(i).change_person = d.ag.input.value.audit_person then
	     call check_error (-1, CALLER, "^a^/^3xYou created the matching history comment ^d and cannot also be the auditor.",
	        pathname_$component (d.seg.dir, d.seg.ent, d.seg.comp),
	        src_array.comments(i).comment_no);
            src_array.comments(i).audit_person = d.ag.input.value.audit_person;
            src_array.comments(i).audit_dt = d.ag.input.value.audit_dt;
            end;					/* Currently, there is no way to specify to clear */
         else if d.ag.input.aud = CLEARxxx then		/*  the audit field.  But there may be someday.	*/
	  src_array.comments(i).audit_person,
	     src_array.comments(i).audit_dt = "";

         if d.ag.input.in = OPERANDxxx then do;
            src_array.comments(i).install_id = d.ag.input.value.install_id;
            src_array.comments(i).install_dt = d.ag.input.value.install_dt;
            end;
         else if d.ag.input.in = CLEARxxx then
	  src_array.comments(i).install_id,
	     src_array.comments(i).install_dt = "";
         end;
      end;

   end REPLACE_FIELDs;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

select_comments:
   proc(Sany_selected) returns(bit(1));

dcl	Sequal			bit(1),
	Sany_selected		bit(1);

   Sany_selected = FALSE;

   if src_array.Ncoms > 0 then do;
      if d.com_spec.Nrange = 0 then do;			/* if no range assume all			*/
         src_array.comments(*).selected = TRUE;
         Sany_selected = TRUE;
         end;
      else do;
         src_array.comments(*).selected = FALSE;
         do i = 1 to d.com_spec.Nrange;
	  d.com_spec.range(i).from.result = get_range(d.com_spec.range(i).from);
	  if d.com_spec.range(i).to.set ^= UNSET then
	     d.com_spec.range(i).to.result= get_range(d.com_spec.range(i).to);
	  else
	     d.com_spec.range(i).to.result = d.com_spec.range(i).from.result;
	  
	  do j = d.com_spec.range(i).from.result to d.com_spec.range(i).to.result;
	     src_array.comments(j).selected = TRUE;
	     Sany_selected= TRUE;			/* at least one comment was selected		*/
	     end;
	  end;
         end;
      end;

   if Porig_array ^= null then
      orig_array.comments(*).selected = FALSE;

   if Sany_selected & string(d.com_spec.selected) ^= FALSE then do;
      Sany_selected = FALSE;
      do i = 1 to src_array.Ncoms;			/* if a comment range/number was specified but no */
						/* com_specs were selected, d.com_spec.selected	*/
						/* would be FALSE.				*/
         d.com_spec.matched = FALSE;
         if src_array.comments(i).selected then do;
	  d.com_spec.matched.all = d.com_spec.selected.all;
	  d.com_spec.matched.cpt =
	     d.com_spec.selected.cpt &
	     src_array.comments(i).approve_dt ^= "" &
	     src_array.comments(i).audit_dt ^= "" & 
	     src_array.comments(i).install_dt ^= "";
	  d.com_spec.matched.icpt =
	     d.com_spec.selected.icpt &
	     (src_array.comments(i).approve_dt = "" |
	      src_array.comments(i).audit_dt = "" | 
	      src_array.comments(i).install_dt = "");
	  d.com_spec.matched.apv = d.com_spec.selected.apv &
	     src_array.comments(i).approve_dt ^= "";
	  d.com_spec.matched.unapv = d.com_spec.selected.unapv &
	     src_array.comments(i).approve_dt = "";

	  d.com_spec.matched.aud = d.com_spec.selected.aud &
	     src_array.comments(i).audit_dt ^= "";
	  d.com_spec.matched.unaud = d.com_spec.selected.unaud &
	     src_array.comments(i).audit_dt = "";
	  d.com_spec.matched.in = d.com_spec.selected.in &
	     src_array.comments(i).install_dt ^= "";
	  d.com_spec.matched.unin = d.com_spec.selected.unin &
	     src_array.comments(i).install_dt = "";

	  if (d.com_spec.selected.new | d.com_spec.selected.old) &
	     Porig_array ^= null then do;
	     Sequal = FALSE;
	     do j = 1 to orig_array.Ncoms while (^Sequal);
	        if ^orig_array.comments(j).selected then do;
		 if comments_comparable (src_array.comments(i),
				     orig_array.comments(j)) &
	              comments_equal      (src_array.comments(i),
				     orig_array.comments(j)) then do;
		    orig_array.comments(j).selected = TRUE;
		    Sequal = TRUE;
		    end;
		 end;
	        end;
	     d.com_spec.matched.new =  (d.com_spec.selected.new  & ^Sequal);
	     d.com_spec.matched.old =  (d.com_spec.selected.old  &  Sequal);
	     end;

	  if d.ag.op.name = EXISTS | d.ag.op.name = GET |	/* For these operations, a comment is selected	*/
	     d.ag.op.name = REPLACE_FIELD then		/* ONLY if it matches ALL the comment specs.	*/
	     src_array.comments(i).selected =
	        (string(d.com_spec.selected) = string(d.com_spec.matched));
	  else					/* For other operations, a comment is selected if */
	     src_array.comments(i).selected =		/* it matches ANY of the comment specs.		*/
	        (string(d.com_spec.matched) ^= ""b);
	  Sany_selected = (Sany_selected | src_array.comments(i).selected);
	  end;
         end;
      end;
   return(Sany_selected);

get_range:
   proc (arg_in) returns(fixed bin);

dcl	1 arg_in			aligned like d.com_spec.range.from;
   
   if arg_in.set = LAST then
      arg_in.no = src_array.Ncoms;
   if arg_in.op = PLUS then
      arg_in.result = arg_in.no + arg_in.addend;
   else if arg_in.op = MINUS then
      arg_in.result = arg_in.no - arg_in.addend;
   else arg_in.result = arg_in.no;

   if arg_in.result > src_array.Ncoms then
      call check_error (error_table_$bad_arg, CALLER, "^/^a^/^3xComment selection expression ^[^d^;^slast^]^[^s^;+^d^;-^d^]^[=^d^;^s^] is greater than the number^/^3xof existing comments (^d)",
         pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
         arg_in.set, arg_in.no,
         arg_in.op+1, arg_in.addend,
         arg_in.set=LAST | arg_in.op^=UNSET, arg_in.result,
         src_array.Ncoms);
   if arg_in.result <= 0 then do;
      if d.ag.op.type ^= MODIFY & arg_in.set = LAST & arg_in.op = MINUS then
         arg_in.result = 1;
      else
         call check_error (error_table_$bad_arg, CALLER, "^/^a^/^3xComment selection expression ^[^d^;^slast^]^[^s^;+^d^;-^d^]^[=^d^;^s^] is less than comment number 1.",
	  pathname_$component(d.seg.dir, d.seg.ent, d.seg.comp),
	  arg_in.set, arg_in.no,
	  arg_in.op+1, arg_in.addend,
	  arg_in.set=LAST | arg_in.op^=UNSET, arg_in.result);
      end;
   return(arg_in.result);

   end get_range;
   
   end select_comments;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

sort_comments:
	proc (Porig);


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This procedure is called upon to sort multiple history comments into the proper	*/
	/* order, i.e., ascending by comment number.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	

dcl Porig                      ptr,
    Psort_copy		 ptr;		

dcl 1 V			 aligned,			/* sort vector of pointers */
      2 N			 fixed bin (18),
      2 vector		 (Porig->src_array.Ncoms) ptr unaligned;
	
dcl 1 src_copy		 aligned based(Psort_copy),
      2 Ncoms		 fixed bin,
      2 comments(0 refer(src_copy.Ncoms)) like src_array.comments;

dcl 1 comment                  aligned like src_array.comments based;

dcl Idx1			 fixed bin;

dcl  sort_items_$char  entry(ptr, fixed bin(24));
	
          Psort_copy = d.temp_seg.Psort_copy;
	Psort_copy->src_copy.Ncoms = Porig->src_array.Ncoms;

	V.N = dim(Porig->src_array.comments,1);
	do Idx1 = lbound(Porig->src_array.comments,1) to hbound(Porig->src_array.comments,1);
	     V.vector(Idx1) = addr(Porig->src_array.comments(Idx1));
						/* get ptr value to it			*/
	     end;
                               
	call sort_items_$char (addr(V), 12);
						/* sort on change date and seq no		*/
    
          do Idx1 = 1 to V.N;
            Psort_copy->src_copy.comments(Idx1) = V.vector(Idx1)->comment;
            end;
    
          Porig = Psort_copy;

end sort_comments;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

%include format_document_options;

dcl	1 fdoc			aligned like format_document_options automatic;

%include hcom_data;

dcl	1 orig_array		aligned based(Porig_array),
	  2 Ncoms			fixed bin,
	  2 comments (0 refer (orig_array.Ncoms)) like src_array.comments,
	Porig_array		ptr;

%include hcom_field_names;

%include hcom_query_info;

%include pnotice_paths;

end hcom_process_seg_;




		    list_pnotice_names.pl1          02/13/86  1224.3rew 02/13/86  1217.2       69138



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */



/****^  HISTORY COMMENTS:
  1) change(86-02-10,LJAdams), approve(86-02-10,MCR7150),
     audit(86-02-10,Wallman), install(86-02-13,MR12.0-1017):
     Recompiled to use modified include file pnotice_paths.incl.pl1
                                                   END HISTORY COMMENTS */


list_pnotice_names:
	
	proc;


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* Name:	        list_pnotice_names						*/
	/*									*/
	/* Function:								*/
	/*      A simple command wherein a user of the protection software can obtain a list of	*/
	/* the available protection notice templates.					*/
	/*									*/
	/* STATUS:								*/
	/*									*/
	/* CREATED       June 1981 by JM Stansbury					*/
	/* MODIFIED      July 17,1981 by JM Stansbury					*/
	/*	       added clean up handler, changed name from print_pnotice_names to its	*/
	/*               current name per MCR Board.					*/
	/* MODIFIED      December 1981 by JM Stansbury					*/
	/*	       implemented the -check and -all control args. These are used as follows: */
	/*	    -check							*/
	/*	       will cause a list of every template in the search list to be output	*/
	/*               and there will be heuristic checks on the contents of each template.	*/
	/*               Error messages will be output.					*/
	/*	    -all								*/
          /*               will list every template in the search list.	Duplicates will be  */
	/*	       flagged with an asterisk (*), and a short explanatory note will follow	*/
	/*									*/
	/*									*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	
%page;
	
/* A U T O M A T I C */
dcl Iarg		          fixed bin,
    Idir		          fixed bin,		/* index for which search dir we are in */
    Idx		          fixed bin,
    Idx2		          fixed bin,
    Larg		          fixed bin (21),
    Nargs		          fixed bin,
    Nprocessed	          fixed bin,
    Parg		          ptr,
    code		          fixed bin (35),
    explain_dups	          bit (1),			/* used to control output of short note */
    v_ptr 	          ptr,			/* for sort */
    i_ptr 	          ptr;			/* for sort */
dcl 1 flags,					/* structure for passing control info to */
						/* the pnotice_paths_ routine */
      2 check_bit	          bit (1) unal,
      2 all_bit		bit (1) unal;


/* E X T E R N A L  E N T R I E S */
dcl com_err_		entry() options(variable),
    cu_$arg_count		entry (fixed bin, fixed bin(35)),
    cu_$arg_ptr		entry (fixed bin, ptr, fixed bin(21), fixed bin(35)),
    ioa_			entry() options(variable),
    pnotice_paths_		entry (char(*), bit(*), ptr, fixed bin(35)),
    release_temp_segment_	entry (char(*), ptr, fixed bin(35)),
    sort_items_indirect_$char	entry (ptr, ptr, fixed bin(24)),
    terminate_file_		entry (ptr, fixed bin(24), bit(*), fixed bin(35));


/* B U I L T I N */
dcl (addr,
     addrel,
     before,
     bin,
     currentsize,
     dim,
     null,
     string)	          builtin;


/* E X T E R N A L   S T A T I C */
dcl error_table_$badopt	fixed bin(35) ext static,
    error_table_$noentry	fixed bin(35) ext static,
    error_table_$wrong_no_of_args
		          fixed bin(35) ext static;
	

/* I N T E R N A L   S T A T I C */
dcl ME		          char (19) int static options(constant) init ("list_pnotice_names"),
    True		          bit(1) int static options (constant) init ("1"b);


/* C O N D I T I O N S */
dcl cleanup	          condition;

/* B A S E D */
dcl argument	          char(Larg) based (Parg);

dcl 1 V		          aligned based (v_ptr),
      2 N		          fixed bin (24),
      2 vector	          (0 refer (V.N)) ptr unaligned;

dcl 1 I		          aligned based (i_ptr),
      2 N		          fixed bin (24),
      2 index		(0 refer (I.N)) fixed bin (24);

%page;
	Ppaths = null;
	explain_dups = "0"b;
	flags = "0"b;
	v_ptr = null;
	i_ptr = null;
	on cleanup call clean_up;
	call cu_$arg_count (Nargs, code);
	if Nargs > 2 then do;
	     code = error_table_$wrong_no_of_args;
	     Parg = addr(Parg);
	     Larg = 0;
	     goto USAGE;
	     end;
	else if code ^= 0 then do;
               Parg = addr(Parg);
	     Larg = 0;
	     goto USAGE;
	     end;
	else do Iarg = 1 to Nargs;
	     call cu_$arg_ptr (Iarg, Parg, Larg, code);
	     if (argument = "-check" | argument = "-ck") then do;
		flags.all_bit = True;
		flags.check_bit = True;
		end;
	     else if (argument = "-all" | argument = "-a") then
		flags.all_bit = True;
	     else do;
		code = error_table_$badopt;
		go to USAGE;
		end;
	     end;

	call ioa_ ("");
	call pnotice_paths_ (ME, string(flags), Ppaths, code);
	if code ^= 0 then do;			/* pnotice_paths_ will complain for us. */
	     call clean_up;
	     return;
	     end;
	if pnotice_paths.Ntemplates = 0 then do;	/* something is really wrong. */
	     call com_err_ (error_table_$noentry, ME, "
Fatal Error - No templates found using the pnotice search list.");
	     call clean_up;
	     return;
	     end;
	Nprocessed = 0;				/* no templates sorted yet. */
	i_ptr = addrel (Ppaths, currentsize(pnotice_paths));

	do Idir = 1 to pnotice_paths.Ndirs;
	     if pnotice_paths.dirs(Idir).Ifirst_template > pnotice_paths.dirs(Idir).Ilast_template then do;
		call ioa_ ("No templates in ^a.^/", pnotice_paths.dirs(Idir).dir_path);
		goto NEXT_DIR;
		end;
	     I.N = pnotice_paths.dirs(Idir).Ilast_template - pnotice_paths.dirs(Idir).Ifirst_template + 1;
	     do Idx = 1 to I.N;
		I.index(Idx) = Idx;
		end;
	     v_ptr = addrel (i_ptr, currentsize(I));
	     V.N = I.N;
	     Idx2 = 0;
	     do Idx = pnotice_paths.dirs(Idir).Ifirst_template to pnotice_paths.dirs(Idir).Ilast_template;
		Idx2 = Idx2 + 1;
		V.vector(Idx2) = addr(pnotice_paths.templates(Idx).primary_name);
		end;
	     call sort_items_indirect_$char (v_ptr, i_ptr, 32);
	     call ioa_ ("Templates in ^a", pnotice_paths.dirs(Idir).dir_path);
	     do Idx = 1 to I.N;
		if pnotice_paths.templates(I.index(Idx)+Nprocessed).duplicate
		   & flags.all_bit then
						/* if ALL and we found dups, a short note is needed. */
		     explain_dups = True;
		call ioa_ ("^[*^]^3t^a^[ (default Trade Secret) ^; (default Copyright)^]^[^/^]",
		     pnotice_paths.templates(I.index(Idx)+Nprocessed).duplicate ^= "0"b,
		     before(pnotice_paths.templates(I.index(Idx)+ Nprocessed).primary_name, ".pnotice"),
		     bin(pnotice_paths.templates(I.index(Idx)+ Nprocessed).defaultC
		     || pnotice_paths.templates(I.index(Idx)+ Nprocessed).defaultTS),
		     Idx = I.N);
		end;
	     Nprocessed = Nprocessed + I.N;		/* keep count of how many we have done */
NEXT_DIR:	     end;
	if explain_dups then
	     call ioa_ ("
The asterisk (*) denotes duplicate templates which will
be ignored given present search path order.");
	call clean_up;
	return;

USAGE:	call com_err_ (code, ME, "^a
Usage: list_pnotice_names {-control_arg(s)}
Control Arg: -check, -ck
             -all, -a", argument);
	return;


clean_up: proc;
	if Ppaths ^= null then do;
	     do Idx = 1 to dim(pnotice_paths.templates, 1);
		call terminate_file_ (pnotice_paths.templates(Idx).Ptemplate,
		   pnotice_paths.templates(Idx).Ltemplate * 9, TERM_FILE_TERM, code);
		end;
	     call release_temp_segment_ (ME, Ppaths, code);
	     end;
	end clean_up;

%page;
%include pnotice_paths;
%page;
%include terminate_file;

	end list_pnotice_names;




		    parse_pnotice_info_.rd          03/17/86  1520.7rew 03/17/86  1431.9      106740



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   *                                                         *
   *********************************************************** */


	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* parse_pnotice_info_:  A routine to parse >tools>psp_info_ for display_psp and	*/
	/* generate_pnotice commands.							*/
	/*									*/
	/* 0) Created 04/14/81 by R. Holmstedt						*/
	/* 1) Modified 10/15/84 by G. Dixon - use search rules to find psp_info_.		*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

/*  open set of reductions for software ids  */

/*++
BEGIN	/<no-token>		/ERROR (1) /RETURN   \  


in_parm  /Define : <validate_MI> ;      /LEX (2) MI_prod LEX (2)   /in_parm \

        /product : <any-token> ;        /LEX (2) prod_name LEX (2)  /in_parm \

        /titles : <quoted-string> ;     /LEX (2) prod_title LEX (2) /in_parm \

        /STI : <validate_STI> ;         /LEX (2) prod_STI LEX (2)   /in_parm \


        /use : <any-token> ;            /LEX (2) prod_USE LEX (2)   /in_parm \

        /source_C :                     /LEX (2) [obj_sw = "0"b] PUSH(in_parm)      /names   \

        /object_C :                     /LEX (2) [obj_sw = "1"b] PUSH(in_parm)      /names   \

        /x_path : <check_path> ;        /LEX (2) prod_path("xecute") LEX (2)  /in_parm \
        /x_path : <any-token> ;	/LEX (2) ERROR (2) NEXT_STMT/in_parm \

        /source_path : <check_path> ;   /LEX (2) prod_path("source") LEX (2)  /in_parm \
        /source_path : <any-token> ;	/LEX (2) ERROR (2) NEXT_STMT/in_parm \

        /object_path : <check_path> ;	/LEX (2) prod_path("object") LEX (2)  /in_parm \
        /object_path : <any-token> ;	/LEX (2) ERROR (2) NEXT_STMT/in_parm \


        / End;	   	           / LEX (2)	       / finish \
         /<any-token>                    /ERROR(4)  NEXT_STMT      /in_parm \
         /<no-token>                     /ERROR (3)	       /RETURN \


finish
	/ <any-token>		 / ERROR (5)               / RETURN \
	/ <no-token>	           /		       / RETURN \

names    / <any-token>                   /prod_C LEX PUSH(names)   /punct    \
         / ;                             /ERROR(2) LEX             /STACK_POP\
         / ,                             / LEX                     /names    \
         / <any-token>                   /ERROR(2) LEX PUSH(names) /punct    \
         / <no-token>                    /ERROR(3)                 /RETURN   \

punct    /;                               / LEX POP                /STACK_POP\
         /,                               / LEX                    /STACK_POP\
         / <any-token>                    / ERROR(2) NEXT_STMT POP /STACK_POP\
         / <no-token >                    / ERROR(2)               /RETURN   \

++*/



/*   close set of reductions    */




%;

parse_pnotice_info_: procedure (input_ptr, code);

dcl (APstmt, APtoken) ptr init (null ());
dcl  LEGAL char (80)aligned init ("    0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'_-^` ");
dcl (LEXDLM, LEXCTL) char (128) varying internal static;
dcl (BREAKS, IGBREAKS) char (128) varying internal static;
dcl Ccode fixed bin (35);
dcl STI char(12);
dcl bit_ch fixed bin (24);
dcl bc fixed bin (21);
dcl code fixed bin (35);
dcl count_S fixed bin;
dcl count_O fixed bin;
dcl cf_ptr ptr;
dcl dirname char(168);
dcl 01 error_control_table (6) internal static options (constant),
       02 severity fixed bin (17) unaligned init ((6) 2),
       02 Soutput_stmt bit (1) unaligned init ((6) (1) "1"b),
       02 message char (80) varying init (
/* ERROR 1*/ "The psp_info_ segment contains no statments.",
/* ERROR 2*/ "The psp_info_ segment contains an incorrect line.",
/* ERROR 3*/ "The psp_info_ segment does not contain an End statment.",
/* ERROR 4*/ "The line containing the keyword ""^a"" is incorrect.",
/* ERROR 5*/ "Text follows the End statment.",
/* ERROR 6*/ "The STI ""^a"" is incorrect, only uppercase letters or numbers are valid."),
       02 brief_message char (4) varying init ((6) (1) " ");

dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl entryname char (32);
dcl  first bit (1) init ("1"b) int static;
dcl hcs_$status_mins entry (ptr, fixed bin(2), fixed bin(24), fixed bin(35));
dcl i fixed bin;
dcl ii fixed bin init (0);
dcl input_ptr ptr;			/* passed in from a call	       */
dcl lex_error_ entry options (variable);
dcl lex_string_$init_lex_delims entry (char(*), char(*), char(*), char(*),
	char(*), bit(*), char(*) var, char(*) var, char(*) var, char(*) var);

dcl lex_string_$lex  entry (ptr, fixed bin(21), fixed bin(21), ptr, bit(*),
	char(*), char(*), char(*), char(*), char(*), char(*) var,
	char(*) var, char(*) var, char(*) var, ptr, ptr, fixed bin(35));
dcl name char(19) init ("");
dcl obj_sw bit (1);
dcl pathname char (168);
dcl proc_ptr  ptr;
dcl 01 product_init aligned int static options (constant),
       02 num(1),
          03 MI char (7) init (""),
          03 prod_name char(20) init (""),
          03 prod_title char (80) init (""),
          03 prod_STI char (12) init (""),
          03 source_C(10) char (24) init ((10) (1) ""),
          03 object_C(10) char (24) init ((10) (1) ""),
	   03 x_path,
	      04 dirname char(168) init (""),
	      04 entryname char(32) init (""),
	   03 source_path,
	      04 dirname char(168) init (""),
	      04 entryname char(32) init (""),
	   03 object_path,
	      04 dirname char(168) init (""),
	      04 entryname char(32) init (""),
          03 prod_use(10) char (7) init ((10) (1)"");
dcl  psp_info_$ fixed bin(35) ext static;
dcl  translator_temp_$get_segment entry (char(*), ptr, fixed bin(35));
dcl  translator_temp_$release_all_segments entry (ptr, fixed bin(35));


dcl  error_table_$translation_failed fixed bin (35) ext static;

dcl (addr, collate, dimension, divide, length, null, substr, verify) builtin;



%include software_pnotice_info_;

	   
/* START			       */
	name = "parse_pnotice_info_";        /* set command name */
	cf_ptr = null;
	proc_ptr = null;

	call translator_temp_$get_segment (name, proc_ptr, code);
				/* area for lex_string_	       */
	if  code ^= 0 then goto fini;
	
	SI_ptr = input_ptr;		/* work area for info structure      */

	product.prod_number = 0;	/* init the structure count	       */
	

	cf_ptr = addr(psp_info_$);
	call hcs_$status_mins (cf_ptr, 0, bit_ch, code);

	bc = divide (bit_ch + 8, 9, 24, 0);
	if first then do;
	     BREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24) || "()*,:;^";
	     IGBREAKS = substr (collate (), 1, 8) || substr (collate (), 10, 24);

	     call lex_string_$init_lex_delims ("""", """", "/*", "*/", ";", "10"b, BREAKS, IGBREAKS, LEXDLM, LEXCTL);
	     first = "0"b;

	end;


	call lex_string_$lex
          (cf_ptr, bc, 0, proc_ptr, "100"b, """", """", "/*", "*/", ";", BREAKS, IGBREAKS, LEXDLM, LEXCTL, APstmt, APtoken, code);
	Pthis_token = APtoken;

	call SEMANTIC_ANALYSIS ();

	if MERROR_SEVERITY > 1 then do;

	     if code = 0 then code =  error_table_$translation_failed;
	     goto fini;
	end;


fini:	if proc_ptr ^= null then
	     call translator_temp_$release_all_segments ( proc_ptr, Ccode);
	 proc_ptr = null;
	 cf_ptr = null;
	 SI_ptr = null;
	return;
	

/*\014 */
MI_prod: proc;


	     product.prod_number = product.prod_number + 1;	/* fill up the structure   */
	     product.num(product.prod_number) = product_init.num(1);
				/* clean it up before using	       */

	     product.num(product.prod_number).MI = token_value;

	     ii = 0;		/* init the Use field count	       */
	     count_O = 0;		/*init the count of object for prod_C*/
	     count_S = 0;		/*init the count of source for prod_C*/

	     return;
	end MI_prod;

prod_name: proc;


	     product.num(product.prod_number).prod_name = token_value;

	     return;
	end prod_name;


check_path: proc returns (bit (1));

dcl  R bit (1);
dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
dcl dirname char(168);
dcl entryname char (32);
dcl pathname char (168);
	  
	  pathname = token_value;
	  call expand_pathname_ (pathname, dirname, entryname, code);
	  if code = 0 then R = "1"b;
	  else R = "0"b;
	  return (R);
       end check_path;
       

prod_title: proc;
	     product.num(product.prod_number).prod_title = token_value;

	     return;
	end prod_title;


prod_USE: proc;

				/* set ii to 0 in MI_prod procedure  */
	ii = ii + 1;		/* count the number of MIs  used*/
	product.num(product.prod_number).prod_use(ii) = token_value;

	return;
	end prod_USE;

validate_MI:
	proc returns (bit (1));
	
	dcl alph char(26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ");
	dcl numbers char (10) init static options (constant) init ("1234567890");
	dcl MI_check char (7);

	if length(token_value) ^= 7 then return ("0"b);

	MI_check = token_value;
	if verify (substr(MI_check,1,3), alph) ^= 0 then return ("0"b);

	if verify(substr(MI_check,4,4), numbers) ^= 0 then return ("0"b);
	return ("1"b);
     end validate_MI;
     
	 
validate_STI: proc  returns (bit (1));

	    dcl parse_pnotice_info_$validate_sti entry (char(12)) returns (bit(1));

	    STI = token_value;
	    if parse_pnotice_info_$validate_sti (STI) then return ("1"b);
	    else return ("0"b);
	    

         end validate_STI;

prod_STI:	    proc;
	    
	    product.num(product.prod_number).prod_STI = token_value;
	    return;
	    end prod_STI;
	         

prod_C: proc;
        
        if obj_sw then do;
	   count_O = count_O + 1;
	   product.num(product.prod_number).object_C(count_O) = token_value;
        end;
        else do;
	   count_S = count_S + 1;
	   product.num(product.prod_number).source_C(count_S) = token_value;
        end;
	     return;
	end prod_C;

prod_path: proc (type);

dcl type char (6);
	 
	  
	  pathname = token_value;
	  call expand_pathname_ (pathname, dirname, entryname, code);
	  if code ^= 0 then do;
	       call statement_error (2, token_value, "");
	       return;
	  end;
	  
	  if type = "source" then do;
	     product.num(product.prod_number).source_path.dirname = dirname;
	     product.num(product.prod_number).source_path.entryname = entryname;
	end;
	else if type = "object" then do;
	     product.num(product.prod_number).object_path.dirname = dirname;
	     product.num(product.prod_number).object_path.entryname = entryname;
	end;
	else if type = "xecute" then do;
	     product.num(product.prod_number).x_path.dirname = dirname;
	     product.num(product.prod_number).x_path.entryname = entryname;
	end;
	     return;
	end prod_path;


statement_error: proc (error_num, parm1, parm2);

dcl  error_num fixed bin;
dcl  parm1 char (*);
dcl  parm2 char (*);
dcl (stmt_ptr, token_ptr) ptr init (null);

	     stmt_ptr = token.Pstmt;
	     token_ptr = Pthis_token;

	     call lex_error_ (error_num, SERROR_PRINTED (error_num), (error_control_table.severity (error_num)),
		MERROR_SEVERITY, stmt_ptr, token_ptr, SERROR_CONTROL,
		(error_control_table.message (error_num)), (error_control_table.brief_message (error_num)),
		parm1, parm2);

	     return;

	end statement_error;

validate_sti: entry (entered_value) returns (bit (1));

	dcl R bit (1);
	dcl entered_value char(12);
	dcl valid_numeric char(36) int static options (constant)  init("ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789");

	    R = "1"b;

	    do i = 1 to 12;
	         if verify (substr(entered_value,i,1),valid_numeric) ^= 0 then R = "0"b;
				/* only uppercase and numbers valid  */
	    end;


	    if verify (substr(entered_value,2,1),"1234") ^= 0 then R = "0"b;
				/* only 4 numbers are valid	       */

	    return (R);		/* good return		       */





		    pnotice_language_info_.cds      04/26/87  1557.5rew 04/26/87  1556.0       97218



/* ***********************************************************
   *                                                         *
   * Copyright, (C) Honeywell Information Systems Inc., 1981 *
   *                                                         *
   *********************************************************** */


/* HISTORY COMMENTS:
  1) change(81-05-14,Stansbury), approve(), audit(),
     install(86-08-21,MR12.0-1138):
     Created.
  2) change(82-02-02,Stansbury), approve(), audit(),
     install(86-08-21,MR12.0-1138):
     Modified - Added the 'pmac' suffix for the PL/1 macro expander.
  3) change(82-06-04,Stansbury), approve(), audit(),
     install(86-08-21,MR12.0-1138):
     Modified - Added the 'ld' suffix for the library descriptor language.
  4) change(82-06-17,Stansbury), approve(), audit(),
     install(86-08-21,MR12.0-1138):
     Modified - Added the following suffixes: pascal, cmdb, header, mexp,
     runoff, linus
  5) change(82-09-28,Stansbury), approve(), audit(),
     install(86-08-21,MR12.0-1138):
     Modified - Added the ted and qedx suffixes.
  6) change(85-09-03,LJAdams), approve(85-09-27,MCR7150),
     audit(86-02-07,Wallman), install(86-02-13,MR12.0-1017):
     Added  Type  4  and  Type  5.   Type  4  allows the comment begin
     characters  to  be  "/****^  "  so  the  history comments will be
     indented  properly  by  format  pl1.   Type  5  is for runoff and
     compose files.  Blank lines will not be inserted before and after
     the history comment block as they are interpreted as space blocks
     by compose.
  7) change(85-11-13,LJAdams), approve(85-11-13,MCR7150),
     audit(86-02-07,Wallman), install(86-02-13,MR12.0-1017):
     Changed pascal begin/end delimiters to (* and *) respectively.  Added xdw
     language type suffix.  Changed pmac suffix to type 4.
  8) change(86-01-29,LJAdams), approve(86-01-29,MCR7150),
     audit(86-02-07,Wallman), install(86-02-13,MR12.0-1017):
     Added support for "C" language and micro_assembler.
  9) change(86-07-28,LJAdams), approve(86-08-01,MCR7509),
     audit(86-08-05,Blair), install(86-08-21,MR12.0-1138):
     Added support for lap language.
 10) change(86-09-08,LJAdams), approve(86-09-08,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Added .cmf, .ttf, .rtmf, .ssl, .teco, and iodt suffixes.
 11) change(86-09-23,LJAdams), approve(86-09-23,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Added support for bind_fnp suffix.
 12) change(87-03-16,LJAdams), approve(87-04-22,MCR7653),
     audit(87-04-02,Gilcrease), install(87-04-26,MR12.1-1026):
     Added support for C language header files (.H) files. (phx20795)
                                                   END HISTORY COMMENTS */

     
pnotice_language_info_:
	proc;

	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
	/*									*/
	/* This program creates the pnotice_language_info_ data structure for language names, and */
	/* for their associated comment delimiters.					*/
	/*									*/
	/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */

	      
%page;
dcl  create_data_segment_ entry (ptr, fixed bin (35));

dcl  1 cdsa	     aligned like cds_args;

dcl  code		     fixed bin (35);

dcl  name		     char (22) aligned static init
                         ("pnotice_language_info_") options (constant),
     NL		     char (1) aligned int static options(constant) init ("
"),
     exclude_pad         (1) char (32) aligned static options (constant) init
		     ("pad*");

dcl (dim,
     addr,
     size,
     string)	     builtin;

%include pnotice_language_info_;

dcl 1 lang_info aligned,
      2 languages,
        3 N fixed bin,
        3 lang_array (41) like pnotice_language_info.lang_array;


	lang_info.languages.N = dim(lang_info.languages.lang_array, 1);

	lang_info.lang_type(1) = 4;
	lang_info.lang_name(1) = "pl1";		/* PL/1 */
	lang_info.comment_start(1) = "/****^ ";
	lang_info.comment_end(1) = "*/";
	
	lang_info.lang_type(2) = 2;
	lang_info.lang_name(2) = "alm";		/* ALM */
	lang_info.comment_start(2) = """";
	lang_info.comment_end(2) = NL;

	lang_info.lang_type(3) = 2;
	lang_info.lang_name(3) = "fortran";		/* FORTRAN */
	lang_info.comment_start(3) = "c";
	lang_info.comment_end(3) = NL;
	
	lang_info.lang_type(4) = 2;
	lang_info.lang_name(4) = "cobol";		/* COBOL */
	lang_info.comment_start(4) = "*";
	lang_info.comment_end(4) = NL;
	
	lang_info.lang_type(5) = 2;
	lang_info.lang_name(5) = "lisp";		/* LISP */
	lang_info.comment_start(5) = ";;;";
	lang_info.comment_end(5) = NL;
	
	lang_info.lang_type(6) = 5;
	lang_info.lang_name(6) = "compin";		/* COMPIN */
	lang_info.comment_start(6) = ".*";
	lang_info.comment_end(6) = NL;

	lang_info.lang_type(7) = 1;
	lang_info.lang_name(7) = "cds";		/* CDS */
	lang_info.comment_start(7) = "/*";
	lang_info.comment_end(7) = "*/";

	lang_info.lang_type(8) = 1;
	lang_info.lang_name(8) = "et";		/* ET, ERROR_TABLE */
	lang_info.comment_start(8) = "/*";
	lang_info.comment_end(8) = "*/";

	lang_info.lang_type(9) = 1;
	lang_info.lang_name(9) = "bind";		/* BIND, BINDER */
	lang_info.comment_start(9) = "/*";
	lang_info.comment_end(9) = "*/";

	lang_info.lang_type(10) = 1;
	lang_info.lang_name(10) = "rd";		/* RD, REDUCTION COMPILER */
	lang_info.comment_start(10) = "/*";
	lang_info.comment_end(10) = "*/";

	lang_info.lang_type(11) = 1;
	lang_info.lang_name(11) = "compdv";		/* COMPDV, COMPOSE DEVICE TABLES */
	lang_info.comment_start(11) = "/*";
	lang_info.comment_end(11) = "*/";

	lang_info.lang_type(12) = 1;
	lang_info.lang_name(12) = "macro";		/* MACRO, COMPOSE MACROS */
	lang_info.comment_start(12) = "/*";
	lang_info.comment_end(12) = "*/";

	lang_info.lang_type(13) = 1;
	lang_info.lang_name(13) = "gdt";		/* GDT, GRAPHICS DEVICE TABLES */
	lang_info.comment_start(13) = "/*";
	lang_info.comment_end(13) = "*/";

	lang_info.lang_type(14) = 2;
	lang_info.lang_name(14) = "bcpl";		/* BCPL */
	lang_info.comment_start(14) = "//";
	lang_info.comment_end(14) = NL;

	lang_info.lang_type(15) = 2;
	lang_info.lang_name(15) = "map355";		/* MAP355 */
	lang_info.comment_start(15) = "*";
	lang_info.comment_end(15) = NL;

	lang_info.lang_type(16) = 3;
	lang_info.lang_name(16) = "ec";		/* EC, EXEC_COM */
	lang_info.comment_start(16) = "&";		/* this is modified as needed, by pnotice tools */
	lang_info.comment_end(16) = NL;
	
	lang_info.lang_type(17) = 2;
	lang_info.lang_name(17) = "basic";		/* BASIC */
	lang_info.comment_start(17) = "rem";
	lang_info.comment_end(17) = NL;

	lang_info.lang_type(18) = 3;
	lang_info.lang_name(18) = "absin";		/* ABSIN, ABSENTEE */
	lang_info.comment_start(18) = "&";		/* this is modified as needed by pnotice tools */
	lang_info.comment_end(18) = NL;

	lang_info.lang_type(19) = 4;
	lang_info.lang_name(19) = "pmac";		/* PL/1 MACRO EXPANDER */
	lang_info.comment_start(19) = "/****^ ";
	lang_info.comment_end(19) = "*/";

	lang_info.lang_type(20) = 1;
	lang_info.lang_name(20) = "ld";		/* LIBRARY DESCRIPTOR */
	lang_info.comment_start(20) = "/*";
	lang_info.comment_end(20) = "*/";

	lang_info.lang_type(21) = 1;
	lang_info.lang_name(21) = "pascal";		/* PASCAL */
	lang_info.comment_start(21) = "(*";
	lang_info.comment_end(21) = "*)";

	lang_info.lang_type(22) = 1;
	lang_info.lang_name(22) = "cmdb";		/* MRDS DB SOURCE */
	lang_info.comment_start(22) = "/*";
	lang_info.comment_end(22) = "*/";

	lang_info.lang_type(23) = 1;
	lang_info.lang_name(23) = "header";		/* HARDCORE HEADER */
	lang_info.comment_start(23) = "/*";
	lang_info.comment_end(23) = "*/";

	lang_info.lang_type(24) = 2;
	lang_info.lang_name(24) = "mexp";		/* OLD MACRO EXPANDER */
	lang_info.comment_start(24) = """";
	lang_info.comment_end(24) = "NL";

	lang_info.lang_type(25) = 5;
	lang_info.lang_name(25) = "runoff";		/* RUNOFF SOURCE */
	lang_info.comment_start(25) = ".*";
	lang_info.comment_end(25) = "NL";

	lang_info.lang_type(26) = 1;
	lang_info.lang_name(26) = "linus";		/* LINUS INVOKE MACROS */
	lang_info.comment_start(26) = "/*";
	lang_info.comment_end(26) = "*/";

	lang_info.lang_type(27) = 2;
	lang_info.lang_name(27) = "ted";		/* TED */
	lang_info.comment_start(27) = """";
	lang_info.comment_end(27) = NL;

	lang_info.lang_type(28) = 2;
	lang_info.lang_name(28) = "qedx";		/* QEDX */
	lang_info.comment_start(28) = """";
	lang_info.comment_end(28) = NL;

	lang_info.lang_type(29) = 2;
	lang_info.lang_name(29) = "table";		/* TABLE */
	lang_info.comment_start(29) = """";
	lang_info.comment_end(29) = NL;

	lang_info.lang_type(30) = 4;
	lang_info.lang_name(30) = "xdw";		/* EXPAND DEVICE WRITER*/
	lang_info.comment_start(30) = "/****^ ";
	lang_info.comment_end(30) = "*/";

	lang_info.lang_type(31) = 2;			/* MICRO ASSEMBLER */
	lang_info.lang_name(31) = "asm";
	lang_info.comment_start(31) = ";";
	lang_info.comment_end(31) = NL;
	
	lang_info.lang_type(32) = 1;			/* C */
	lang_info.lang_name(32) = "c";
	lang_info.comment_start(32) = "/*";
	lang_info.comment_end(32) = "*/";

	lang_info.lang_type(33) = 2;
	lang_info.lang_name(33) = "lap";		/* LAP */
	lang_info.comment_start(33) = ";;;";
	lang_info.comment_end(33) = NL;

	lang_info.lang_type(34) = 4;
	lang_info.lang_name(34) = "cmf";		/* CMF */
	lang_info.comment_start(34) = "/****^ ";
	lang_info.comment_end(34) = "*/";

	lang_info.lang_type(35) = 4;
	lang_info.lang_name(35) = "ttf";		/* TTF */
	lang_info.comment_start(35) = "/****^ ";
	lang_info.comment_end(35) = "*/";

	lang_info.lang_type(36) = 4;
	lang_info.lang_name(36) = "rtmf";		/* RTMF */
	lang_info.comment_start(36) = "/****^ ";
	lang_info.comment_end(36) = "*/";

	lang_info.lang_type(37) = 4;
	lang_info.lang_name(37) = "iodt";		/* IODT */
	lang_info.comment_start(37) = "/****^ ";
	lang_info.comment_end(37) = "*/";

	lang_info.lang_type(38) = 2;
	lang_info.lang_name(38) = "ssl";		/* SSL */
	lang_info.comment_start(38) = "*";
	lang_info.comment_end(38) = "NL";

	lang_info.lang_type(39) = 1;
	lang_info.lang_name(39) = "teco";		/* TECO */
	lang_info.comment_start(39) = "!";
	lang_info.comment_end(39) = "!";

	lang_info.lang_type(40) = 1;
	lang_info.lang_name(40) = "bind_fnp";		/* BIND_FNP */
	lang_info.comment_start(40) = "/*";
	lang_info.comment_end(40) = "*/";

	lang_info.lang_type(41) = 1;			/* C Header */
	lang_info.lang_name(41) = "h";
	lang_info.comment_start(41) = "/*";
	lang_info.comment_end(41) = "*/";

/* Now set up call to create data base */

	cdsa.sections (1).p = addr (lang_info);
	cdsa.sections (1).len = size (lang_info);
	cdsa.sections (1).struct_name = "lang_info";
	cdsa.seg_name = name;
	cdsa.num_exclude_names = 1;
	cdsa.exclude_array_ptr = addr (exclude_pad);
	string (cdsa.switches) = "0"b;
	cdsa.switches.have_text = "1"b;
	call create_data_segment_ (addr (cdsa), code);

	% include cds_args;
	end pnotice_language_info_;




		    pnotice_mlr_.alm                09/09/83  1128.8rew 09/09/83  1103.5       25344



" ***********************************************************
" *                                                         *
" * Copyright, (C) Honeywell Information Systems Inc., 1981 *
" *                                                         *
" * Copyright (c) 1972 by Massachusetts Institute of        *
" * Technology and Honeywell Information Systems, Inc.      *
" *                                                         *
" ***********************************************************


" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  * "
"								"
" N__a_m_e_s:  pnotice_mlr_, pnotice_mrl_							"
"								"
"   This subroutine uses the MLR and MRL machine instructions to move a source	"
" character string to a target location.  The appropriate entry point must be	"
" to ensure proper direction of movement when the source overlaps the target.	"
" The figure below shows which to use:					"
"								"
"				MLR				"
"								"
"		        target					"
"		 _________|__________				"
"		/		\				"
"		 _____________________________			"
"		|__________|__________|_________|			"
"								"
"			\___________________/			"
"				|				"
"			         source				"
"								"
"				MRL				"
"								"
"		        source					"
"		 _________|__________				"
"		/		\				"
"		 _____________________________			"
"		|__________|__________|_________|			"
"								"
"			\___________________/			"
"				|				"
"			         target				"
"								"
"								"
"								"
" U__s_a_g_e								"
"								"
"     declare pnotice_mlr_ (ptr, fixed bin(21), ptr, fixed bin(21));		"
"     call pnotice_mlr_ (Psource, Lsource, Ptarget, Ltarget);			"
"								"
"	or							"
"								"
"     declare pnotice_mrl_ (ptr, fixed bin(21), ptr, fixed bin(21));		"
"     call pnotice_mrl_ (Psource, Lsource, Ptarget, Ltarget);		"
"								"
"								"
" S__t_a_t_u_s								"
"								"
" 0) Created by:  Gary C. Dixon, January, 1976.				"
" 1) Modified by: JM Stansbury, July 1981.                                      "
"    renamed entrypoints to be consistent with the protection SW.               "
"								"
" *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  * "

"
	name	pnotice_mlr_

	segdef	pnotice_mlr_
	segdef	pnotice_mrl_

pnotice_mlr_:	
	ldx0	0,du			" set entry point switch
	tra	common

pnotice_mrl_:	
	ldx0	4,du			" set entry point switch

common:	epp1	ap|2,*			" get ptr to source
	epp1	1|0,*
	lda	ap|4,*			" get length of source
	epp3	ap|6,*			" get ptr to target
	epp3	3|0,*
	ldq	ap|8,*			" get length of target
	tra	move,x0			" perform appropriate move instruction

	even
move:	mlr	(pr,rl),(pr,rl),fill(040)
	desc9a	1|0,al
	desc9a	3|0,ql
	tra	common2

	mrl	(pr,rl),(pr,rl),fill(040)
	desc9a	1|0,al
	desc9a	3|0,ql

common2:	short_return

	end
	



		    pnotice_paths_.pl1              02/16/88  1454.4r w 02/16/88  1411.9      151722



/****^  ***********************************************************
        *                                                         *
        * Copyright, (C) Honeywell Information Systems Inc., 1981 *
        *                                                         *
        *********************************************************** */


/****^  HISTORY COMMENTS:
  1) change(81-05-01,Stansbury), approve(), audit(),
     install(86-11-12,MR12.0-1213):
     Created.
  2) change(81-12-01,Stansbury), approve(), audit(),
     install(86-11-12,MR12.0-1213):
     Modified - Changed calling sequence to include option flags.
  3) change(82-10-01,Stansbury), approve(), audit(),
     install(86-11-12,MR12.0-1213):
     Modified - Added functionality to deal with public domain notices.
     These notices must have "public.domain" as the first and second
     components in their name.
  4) change(85-09-27,LJAdams), approve(85-09-27,MCR7150),
     audit(86-02-07,Wallman), install(86-02-13,MR12.0-1017):
     Accept public_domain as a template name.  Search for <yr> indicator
     in template rather than date.  Allow multiple component prefixes
     for template name.
  5) change(86-09-08,LJAdams), approve(86-09-08,MCR7526),
     audit(86-11-05,GDixon), install(86-11-12,MR12.0-1213):
     Corrected code that allowed stringrange error to occur.
                                                   END HISTORY COMMENTS */


pnotice_paths_:
     proc (caller, flags, Ppnotice_info, ncode);


/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */
/*									*/
/* NAME:	        pnotice_paths_						*/
/*									*/
/* FUNCTION:								*/
/*      This is the subroutine interface to the software protection tools that provides	*/
/* pathnames of the directories which contain the protection notice templates. It sets	*/
/* up proper search paths for the user of the tools, and initiates each of the known	*/
/* templates providing pointers and lengths, primary names, and whether or not a	*/
/* particular template is a default template. The include file pnotice_paths.incl.pl1	*/
/* contains the structure which is filled in by this subroutine.			*/
/*									*/
/* USAGE:									*/
/*      dcl pnotice_paths_ entry (char(*), bit(*), ptr, fixed bin (35));		*/
/*									*/
/*      call pnotice_paths_ (name, option_flags, Ppaths, Acode);			*/
/* where:									*/
/* 1.   name		  (In)						*/
/*     is the name of the procedure that called this subroutine.			*/
/* 2.   option_flags            (In)						*/
/*     are passed as a bit string and are used by the list_pnotice_names command to	*/
/* control the checking of templates and filling in of the pnotice_paths structure.	*/
/* Callers of this procedure other than list_pnotice_names should set this parameter to	*/
/* "00"b !								*/
/*      Meaning of these flags:						*/
/*      The check flag, which is first, is set when list_pnotice_names is the caller AND	*/
/* the -check control arg has been used.  When this is the case, any errors found while	*/
/* checking the text of a template will be reported, and the template will not be removed	*/
/* from the list returned to the caller. The all flag, which is second, is set		*/
/* when list_pnotice_names is the caller AND the -all control arg has been  used. When	*/
/* this is the case, all properly formatted templates in every directory will be  listed. */
/* Any with duplicate names will be flagged with an asterisk (*) and an explanation will	*/
/* be printed.								*/
/*									*/
/*									*/
/*									*/
/* 3.   Ppaths	            (In)						*/
/*     is a pointer to a temporary segment used to allocate the contents of the		*/
/* pnotice_paths structure. If the caller has not provided a temp seg, i.e., Ppaths is	*/
/* null, this subroutine will obtain one.					*/
/* 4.   Acode		  (Out)						*/
/*     is a standard system error code.						*/
/*									*/
/*									*/
/*									*/
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * */


%page;
	dcl     caller		 char (*),	/* IN */
	        flags		 bit (*),		/* IN */
	        Ppnotice_info	 ptr,		/* IN / OUT */
	        ncode		 fixed bin (35);	/* OUT */


/*  A U T O M A T I C  */
	dcl     component		 char (32) varying,
	        Icurrent_entry	 fixed bin,
	        Idir		 fixed bin,
	        Idx		 fixed bin,
	        Idx1		 fixed bin,
	        Iname		 fixed bin,
	        Itemplate		 fixed bin,
	        Itextdate		 fixed bin,
	        Lline		 fixed bin (21),
	        Ltemp		 fixed bin (21),
	        Ltext		 fixed bin (21),
	        Nentries		 fixed bin,
	        Pline		 ptr,
	        Ptemp		 ptr,
	        Ptext		 ptr,		/* ptr to temp seg of template text */
	        bit_count		 fixed bin (24),
	        errors_found	 bit (1),		/* bit to check for any internal template errors */
	        tcode		 fixed bin (35),	/* temp error code */
	        type		 fixed bin,
	        work_area		 area (8192);	/* area for search_paths_$get and hcs_$star */
	dcl     1 option_flags,
		2 check		 bit (1) unal,
		2 all		 bit (1) unal;

	dcl     1 template		 like pnotice_paths.templates;


/*  B A S E D  */
	dcl     line		 char (Lline) based (Pline),
	        temp		 char (Ltemp) based (Ptemp),
	        temp_chr		 (Ltemp) char (1) based (Ptemp),
	        text		 char (Ltext) based (Ptext);

/*  B U I L T I N */
	dcl     (addcharno,
	        addr,
	        after,
	        before,
	        divide,
	        empty,
	        index,
	        null,
	        reverse,
	        rtrim,
	        search,
	        string,
	        substr,
	        sum,
	        verify)		 builtin;

/*  C O N D I T I O N S  */
	dcl     cleanup		 condition;


/*  E X T E R N A L   E N T R I E S  */
	dcl     com_err_		 entry () options (variable),
	        get_temp_segment_	 entry (char (*), ptr, fixed bin (35)),
	        hcs_$initiate_count	 entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)),
	        hcs_$star_		 entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)),
	        hcs_$terminate_noname	 entry (ptr, fixed bin (35)),
	        search_paths_$get	 entry (char (*), bit (36), char (*), ptr, ptr, fixed bin, ptr, fixed bin (35));


/* E X T E R N A L   S T A T I C  */
	dcl     error_table_$empty_search_list fixed bin (35) ext static,
	        error_table_$improper_data_format fixed bin (35) ext static,
	        error_table_$nomatch	 fixed bin (35) ext static;


/* I N T E R N A L   S T A T I C  */
	dcl     True		 bit (1) int static options (constant) init ("1"b),
	        False		 bit (1) int static options (constant) init ("0"b),
	        NL		 char (1) int static options (constant) init ("
"),
	        HT		 char (1) int static options (constant) init ("	"),
	        HT_SP_VT_NP		 char (4) int static options (constant) init ("	 ");


%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

	ncode = 0;

	string (option_flags) = flags;
	on cleanup begin;
		if Ptext ^= null then
		     call hcs_$terminate_noname (Ptext, tcode);
	     end;


	if Ppnotice_info = null then do;		/* if we were not given a temp seg ptr,		*/
		call get_temp_segment_ (caller, Ppnotice_info, ncode);
						/* get one on the caller's behalf		*/
		if ncode ^= 0 then do;
			call com_err_ (ncode, caller, "
Obtaining a temporary segment for pnotice template info.");
			return;
		     end;				/* things are probably so fouled up now,	*/
	     end;
	Ppaths = Ppnotice_info;
	pnotice_paths.Ndirs = 0;
	pnotice_paths.Ntemplates = 0;
	type = UNDEFINED;

	call search_paths_$get ("pnotice", sl_control_default, "", null (),
	     addr (work_area), sl_info_version_1, sl_info_p, ncode);
	if ncode ^= 0 then do;			/* anything unexpected, clean up and get out	*/
		call com_err_ (ncode, caller, "
Searching the pnotice search list.");
		return;
	     end;
	pnotice_paths.Ndirs = sl_info.num_paths;	/* no. of search paths			*/
	if pnotice_paths.Ndirs = 0 then do;		/* truly a bad situation			*/
		ncode = error_table_$empty_search_list;
		call com_err_ (ncode, caller, "
No directories were found in the pnotice search list.");
		return;
	     end;
	else do Idir = 1 to pnotice_paths.Ndirs;
		pnotice_paths.dirs (Idir).dir_path = sl_info.paths (Idir).pathname;
						/* obtain pathname				*/
		pnotice_paths.dirs (Idir).Ifirst_template = pnotice_paths.Ntemplates + 1;
						/* set up index				*/
		pnotice_paths.dirs (Idir).Ilast_template = 0;

		call hcs_$star_ (pnotice_paths.dirs (Idir).dir_path, "**.pnotice",
		     star_ALL_ENTRIES, addr (work_area), star_entry_count,
		     star_entry_ptr, star_names_ptr, ncode);
		if ncode ^= 0 then do;
			if ncode = error_table_$nomatch then do; /* none in this dir				*/
				ncode = 0;
				goto NEXT_DIR;
			     end;
			else do;
				call com_err_ (ncode, caller, "
Obtaining star names matching **.pnotice in ^a", pnotice_paths.dirs (Idir).dir_path);
						/* complain				*/
				ncode = 0;	/* prevent other abnormalities		*/
				goto NEXT_DIR;	/* go onto next. */
			     end;
		     end;
		pnotice_paths.dirs (Idir).Ifirst_template = pnotice_paths.Ntemplates + 1;
						/* set index for first template in this dir	*/
		do Nentries = 1 to star_entry_count;	/* for all entries in this dir,		*/
		     Icurrent_entry = pnotice_paths.Ntemplates + 1;
						/* set index of current template		*/
		     template.defaultC = False;
						/* initialize variables to False		*/
		     template.defaultTS = False;
		     templates.duplicate = False;

		     do Itemplate = 1 to pnotice_paths.Ntemplates;
						/* check for duplicates			*/
			if star_names (star_entries (Nentries).nindex) =
			     pnotice_paths.templates (Itemplate).primary_name then do;
				if ^option_flags.all then
				     goto NEXT_TEMPLATE; /* skip it				*/
				else
				     template.duplicate = True;
						/* turn on bit				*/
			     end;
		     end;
		     call hcs_$initiate_count (pnotice_paths.dirs (Idir).dir_path,
			star_names (star_entries (Nentries).nindex),
			"", bit_count, 0,
			Ptext, tcode);		/* get pointer to each one			*/
		     if Ptext = null then do;
			     call com_err_ (tcode, caller, "
Initiating ^a^[>^]^a",
				pnotice_paths.dirs (Idir).dir_path, pnotice_paths.dirs (Idir).dir_path ^= ">",
				star_names (star_entries (Nentries).nindex));
			     goto NEXT_TEMPLATE;	/* some problem here, don't let it stop now	*/
			end;
		     Ltext = divide (bit_count, 9, 17, 0);

		     errors_found = False;		/* prepare to...				*/
						/* do checks on this one			*/
						/* the errors_found flag lets us report ALL errors*/
		     call find_line$init (Ptext, Ltext);/* set up for finding multiple lines		*/


		     component = rtrim (star_names (star_entries (Nentries).nindex));
						/* strip trailing blanks			*/
		     component = after (reverse (component), "ecitonp.");
						/*drop off pnotice suffix			*/
		     component = reverse (before (component, "."));
						/*find the component prior to .pnotice		*/
		     if component = "trade_secret" then do;
						/* FOR TRADE SECRET ONLY			*/
			     type = TRADE_SECRET;
			     if search (text, "0123456789") ^= 0 then
				call format_error ("Text of Trade Secret notices should not contain dates.");
			     if index (text, "<yr>") ^= 0 then
				call format_error
				     ("Text of Trade Secret notices should not contain a generic year indicator, <yr>.");
			     if index (text, "PROPRIETARY") = 0 then
				call format_error ("Text of Trade Secret notices must contain ""PROPRIETARY"".");
			end;
		     else if component = "public_domain" |
			component = "domain" then do; /* name of this notice should be 		*/
						/* public_domain.pnotice			*/
						/* FOR PUBLIC DOMAIN ONLY			*/
			     if component = "domain" |
				verify (before (star_names (star_entries (Nentries).nindex), "."), "public_domain") ^= 0 then
				call format_error ("A public domain pnotice can only be named public_domain.");
			     type = PUBLIC_DOMAIN;
			     if search (text, "0123456789") ^= 0 then
				call format_error ("Text of the public domain notice must not contain a date.");
			     if index (text, "<yr>") ^= 0 then
				call format_error
				     ("Text of the public domain notice must not contain a generic year indicator, <yr>.");
			     if index (text, "PUBLIC DOMAIN") = 0 then
				call format_error ("Text of public domain notice must contain ""PUBLIC DOMAIN"".");
			end;
		     else do;			/* FOR COPYRIGHT				*/
			     type = COPYRIGHT;
			     Itextdate = search (text, "<yr>");
			     if Itextdate = 0 then
				call format_error
				     ("Copyright notice text must contain a ""<yr>"" place holder.");
			     if index (text, "Copyright") = 0 then
				call format_error ("Text of Copyright notices must include ""Copyright"".");
			end;
		     do while (find_line ());
			if search (line, HT) ^= 0 then
			     call format_error ("Text contains a horizontal tab character.");
			if search (line, "*") ^= 0 then
			     call format_error ("Text contains an asterisk (*).");
			if Lline > 71 then
			     call format_error ("Length of a template line exceeds 71 characters.
This may result in poor formatting.");
			Idx = verify (line, HT_SP_VT_NP);
			Idx1 = verify (reverse (line), HT_SP_VT_NP);
			if Idx = 0 & Idx1 = 0 then
			     call format_error ("A template line is blank.");
			else
			     if Idx ^= 1 then
			     call format_error ("Template line has leading white space.");
			else
			     if Idx1 ^= 1 then
			     call format_error ("A template line has trailing white space other than NL.");
		     end;
		     if errors_found then
			goto NEXT_TEMPLATE;		/* don't include this one			*/
		     else do;			/* THIS ONE PASSED, ADD IT TO THE LIST		*/
			     template.primary_name = star_names (star_entries (Nentries).nindex);
						/* obtain primary name first			*/
			     template.Ptemplate = Ptext;
			     template.Ltemplate = Ltext;
			     template.type = type;
			     template.Isearch_dir = Idir;
						/* remember dir index that this one came from.	*/
			     do Iname = 1 to star_entries (Nentries).nnames - 1;
						/* check the names on this entry.		*/
						/* check to see if it is a default pnotice	*/
				if before (star_names (star_entries (Nentries).nindex + Iname), ".") =
				     "default_trade_secret" then
				     template.defaultTS = "1"b;
				else if before (star_names (star_entries (Nentries).nindex + Iname), ".") =
				     "default_copyright" then
				     template.defaultC = "1"b;
				else do;
					call format_error (
					     "Only ""default_trade_secret.pnotice"" and ""default_copyright.pnotice"" are allowed as add names.");
					goto NEXT_TEMPLATE;
				     end;
			     end;
			     pnotice_paths.Ntemplates = Icurrent_entry;
			     pnotice_paths.templates (Ntemplates) = template;
			end;
		     goto KEEP_TEMPLATE;
NEXT_TEMPLATE:	     call hcs_$terminate_noname (Ptext, tcode);
						/* prevent abnormal happenings if user QUITs	*/
KEEP_TEMPLATE:	     Ptext = null;
		end;
		pnotice_paths.dirs (Idir).Ilast_template = pnotice_paths.Ntemplates;
						/* index of last template in this dir		*/
NEXT_DIR:	     end;

RETURN:	return;

%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
find_line:
     proc returns (bit (1));

	if Ltemp <= 0 then
	     return (False);
	else do;
		Pline = Ptemp;
		Lline = search (temp, NL);
		if Lline = 0 then /* there was no NL in the first place..		*/
		     Lline = Ltemp;
		if length(temp) > length(line) then
		   Ptemp = addr(temp_chr(length(line)+1));
		Ltemp = Ltemp - length(line);
		if substr (line, Lline, 1) ^= NL & option_flags.check then
		     call format_error ("A line of this template does not end with a NL.");
		else
		     Lline = Lline - 1;		/* remove the NL				*/
	     end;
	return (True);

find_line$init:
     entry (Pstr, Lstr);
	dcl     Pstr		 ptr,
	        Lstr		 fixed bin (21);

	Ptemp = Pstr;
	Ltemp = Lstr;
	return;

     end find_line;
%page;

/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/

format_error:
     proc (Amsg);

	dcl     Amsg		 char (*) var;
	dcl     Acode		 fixed bin (35);

	if option_flags.check then do;		/* complaints allowed only if asked for.	*/
		Acode = error_table_$improper_data_format;
		call com_err_ (Acode, caller, "^/^a^/(^a^[>^]^a)^/", Amsg,
		     pnotice_paths.dirs (Idir).dir_path, pnotice_paths.dirs (Idir).dir_path ^= ">",
		     star_names (star_entries (Nentries).nindex));
	     end;
	errors_found = True;
	return;
     end format_error;
%page;
/*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  * 	*/
%include sl_info;
%page;
%include sl_control_s;
%page;
%include star_structures;
%page;
%include pnotice_paths;

     end pnotice_paths_;





		    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
