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