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) = "" & verify (pnotices.pword (i), "0123456789") = 0 & length (pnotices.pword (i)) = length ("1986") then ; else if template.tword (i) = "." & 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, ""); 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, "") = 0 then call ioa_ ("^a^/", Pt -> template); else do; Iyr = index (Pt -> template, ""); 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 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 } {-id } {-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 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,""); 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 / ) change ( , ) / [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 \ / ) change ( , / LEX(7) MY_ERROR(19) / RETURN \ / ) change ( , / LEX(6) MY_ERROR(3) / RETURN \ / ) change ( / LEX(4) MY_ERROR(2) / RETURN \ / ) / MY_ERROR(1) / RETURN \ / / MY_ERROR(4) / RETURN \ / / MY_ERROR(5) / RETURN \ punct / : / LEX set_text / RETURN \ / , / LEX / opt \ / / MY_ERROR(6) /RETURN \ / / MY_ERROR(7) /RETURN \ opt / approve ( / / opt_arg \ / audit ( / / opt_arg \ / install ( / / opt_arg \ / ( / MY_ERROR(16) /RETURN\ / / MY_ERROR(17) /RETURN \ / / 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 ( , ) / 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 ( , ) / 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 ( , ) / LEX(2) [src_array_comment.install_dt = date_out] LEX(2) [src_array_comment.install_id = ident] LEX(2) / punct \ / approve ( , / LEX(5) MY_ERROR(19) / RETURN \ / approve ( , / LEX(4) MY_ERROR(11) / RETURN \ / approve ( / LEX(2) MY_ERROR(10) / RETURN \ / approve / LEX MY_ERROR(6) / RETURN \ / audit ( , / LEX(5) MY_ERROR(19) / RETURN \ / audit ( , / LEX(4) MY_ERROR(13) / RETURN \ / audit ( / LEX(2) MY_ERROR(12) / RETURN \ / audit / LEX MY_ERROR(6) / RETURN \ / install ( , / LEX(5) MY_ERROR(19) / RETURN \ / install ( , / LEX(4) MY_ERROR(15) / RETURN \ / install ( / LEX(2) MY_ERROR(14) / RETURN \ / install / LEX MY_ERROR(6) / RETURN \ / / MY_ERROR(8) / RETURN \ / / 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 / /ERROR (1) /RETURN \ in_parm /Define : ; /LEX (2) MI_prod LEX (2) /in_parm \ /product : ; /LEX (2) prod_name LEX (2) /in_parm \ /titles : ; /LEX (2) prod_title LEX (2) /in_parm \ /STI : ; /LEX (2) prod_STI LEX (2) /in_parm \ /use : ; /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 : ; /LEX (2) prod_path("xecute") LEX (2) /in_parm \ /x_path : ; /LEX (2) ERROR (2) NEXT_STMT/in_parm \ /source_path : ; /LEX (2) prod_path("source") LEX (2) /in_parm \ /source_path : ; /LEX (2) ERROR (2) NEXT_STMT/in_parm \ /object_path : ; /LEX (2) prod_path("object") LEX (2) /in_parm \ /object_path : ; /LEX (2) ERROR (2) NEXT_STMT/in_parm \ / End; / LEX (2) / finish \ / /ERROR(4) NEXT_STMT /in_parm \ / /ERROR (3) /RETURN \ finish / / ERROR (5) / RETURN \ / / / RETURN \ names / /prod_C LEX PUSH(names) /punct \ / ; /ERROR(2) LEX /STACK_POP\ / , / LEX /names \ / /ERROR(2) LEX PUSH(names) /punct \ / /ERROR(3) /RETURN \ punct /; / LEX POP /STACK_POP\ /, / LEX /STACK_POP\ / / ERROR(2) NEXT_STMT POP /STACK_POP\ / / 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 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, "") ^= 0 then call format_error ("Text of Trade Secret notices should not contain a generic year indicator, ."); 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, "") ^= 0 then call format_error ("Text of the public domain notice must not contain a generic year indicator, ."); 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, ""); if Itextdate = 0 then call format_error ("Copyright notice text must contain a """" 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