canonicalize.pl1 04/25/90 1435.4rew 04/12/90 1653.5 800667 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1978 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(71-01-01,VanVleck), approve(), audit(), install(): Written by THVV, date unknown (above date is made up). 2) change(71-01-01,Vinograd), approve(), audit(), install(): Modified by D. Vinograd to add subroutine entry (date unknown). 3) change(78-11-01,Spector), approve(), audit(), install(): Modified by David Spector: 1. Bug which could cause a fatal process error fixed. 2. Subroutine entry made to call clean_up when done. 3. Bug in which final lines not terminated by NL, VT, or FF were deleted fixed. 4. Bug in which final lines consisting only of NL, VT, or FF ("null lines") were deleted fixed. 5. Command made to check for error when setting bit count of the output segment. 6. Truncation of output segment now done in right place and with right count. 7. Precision of several char length calculations corrected to 21 bits. 8. Command made to check for write access to output segment. 9. Bug in which allocated "bead" not freed upon certain errors fixed. 10. Command made to use expand_pathname_ instead of expand_path_. 4) change(80-03-26,Herbst), approve(), audit(), install(): Modified by S. Herbst to leave zero-length seg alone. 5) change(81-04-01,Wallman), approve(), audit(), install(): Modified by E. Wallman to enforce range of printing chars. 6) change(84-01-01,Lippard), approve(85-12-30,MCR7322), audit(86-01-15,KFleming), install(86-01-20,MR12.0-1006): Modified by Jim Lippard to: 1. allow input tab length specification 2. refuse to canonicalize object segments and archives 3. not delete nonprinting characters 4. terminate zero-length segments 5. query if input segment is to be overwritten 6. add the name "-ev" to "-every" 7. optimize processing of non-overstruck data (speedup from Calgary's modified canonicalize by Tom Oke) 7) change(86-02-11,Lippard), approve(86-02-11,PBF7322), audit(86-02-11,Dickson), install(86-02-17,MR12.0-1018): Modified to determine if a character is a nonprinting character correctly. 8) change(86-03-06,Lippard), approve(86-03-14,MCR7371), audit(86-04-22,Dickson), install(86-04-22,MR12.0-1042): Modified to calculate the increment of col correctly. 9) change(86-08-21,Lippard), approve(86-09-08,MCR7537), audit(86-09-30,Dickson), install(86-10-07,MR12.0-1178): Modified to properly strip white space off the ends of lines which contain no other characters. 10) change(88-05-26,TLNguyen), approve(88-05-26,MCR7879), audit(88-10-04,RBarstad), install(90-04-12,MR12.4-1004): SCP6348: allow MSF in canon. 11) change(90-03-02,LZimmerman), approve(90-03-02,MCR8158), audit(90-03-07,Kallstrom), install(90-04-12,MR12.4-1004): Correct unwarranted termination of input segment. (canonicalize_, canonicalize_tabs_) END HISTORY COMMENTS */ /* format: style4 */ canonicalize: canon: proc; /* CANONICALIZE - fix file up to be canonical form. take out tabs too. (option to put in again) */ /* Syntax as a command: canon path1 {path2} {-control_args} */ /* automatic variables */ dcl Access_ptr ptr; /* access pointer */ /* the structure defined below is needed for both special cases: */ /* SSF canonicalize MSF (expanded); MSF canonicalize SSF (shrunk) */ /* Warning: the access structure defined below must be the same as */ /* the access structure defined in the access_.pl1 program */ /* access.set can be: 0 = NO, 1 = ACL_ADDED, or 2 = ACL_REPLACED */ /* access.type can be SEGMENT, DIRECTORY, or MSF */ /* access.old_mode to be reset when ACL_REPLACED */ /* directory path whose access was changed */ /* entryname whose access was changed */ dcl 1 Access aligned based (Access_ptr), 2 version char (8), 2 set fixed bin, 2 type fixed bin (2), 2 old_mode bit (36), 2 dir char (168) unaligned, 2 ent char char (32) unaligned; dcl Arg_len fixed bin; /* length of an input argument */ dcl Arg_numb fixed bin; /* counter */ dcl Arg_ptr ptr; /* pointer to an input argument. */ dcl Arg_count fixed bin; /* counter */ dcl Area_ptr ptr; dcl Bead_ptr ptr; dcl Bead_storage (1024) fixed bin; dcl Bead_storage_size fixed bin; dcl Beg_line fixed bin (21); /* location of the beginning of the next line */ dcl Bitc fixed bin (24); /* bit count of an input segment */ dcl Cantab_flag bit (1) aligned; dcl Chars_in_line fixed bin (21); /* counter */ dcl Chars_to_remove fixed bin (21); /* counter */ dcl Charx fixed bin; /* counter */ dcl Col fixed bin; /* column position in input scan */ dcl Create_temp_msf_flag bit (1) aligned; dcl Desired_access bit (36); dcl Dn char (168); /* directory name of an input segment. */ dcl Do_not_create_temp_msf_flag bit (1) aligned; dcl Ec fixed bin (35); /* error code */ dcl En char (32); /* entryname of an input segment */ dcl Eof_flag bit (1) aligned; /* set when end of file of an input segment reaches. */ dcl Eqln char (32); /* equal entryname of an output segment. Got from calling expand_pathname_, given an output segment pathname. */ dcl Everytab fixed bin; dcl Fs_util_type char (32); /* determine the type of a specified entry */ dcl Have_infile_flag bit (1) aligned; /* set if an input segment is specified */ dcl Have_outfile_flag bit (1) aligned; /* set if an output segment is specified */ dcl Ii fixed bin (21); /* counter */ dcl In_everytab fixed bin; dcl In_nstops fixed bin; dcl In_msf_comp_bitc fixed bin (24); /* bit count of a component of an input MSF */ /* the number of components in an input MSF */ dcl In_msf_total_original_comps fixed bin (24); dcl Input_msf_comp_index fixed bin; /* the number of components in an input MSF */ dcl Input_msf_comp_ptr ptr; /* pointer to a component of an input msf */ dcl Input_msf_fcb_ptr ptr; /* pointer to the FCB for an input MSF */ dcl In_stops (40) fixed bin; dcl In_stopx fixed bin; dcl Jj fixed bin (21); /* counter */ dcl Kk fixed bin (21); /* counter */ dcl Lth fixed bin (21); /* line length */ dcl Mm fixed bin; /* counter */ dcl Nch fixed bin (21); /* population of Beads */ dcl Next_pos fixed bin; /* number of positions output */ dcl Nonexistent_outfile_flag bit (1) aligned; dcl Nstops fixed bin; dcl Obuf_ptr ptr; /* ptr to output buffer temp */ dcl Out_seg_ptr ptr; /* ptr to an Outc segment. */ dcl Outc_ptr ptr; /* ptr to Outc which holds a line of canonical characters */ dcl Out_dname char (168); /* a directory name contains a specified Outc file (path2) */ dcl Out_ename char (32); /* an entryname of a specified Outc file (path2) */ dcl Outc_len fixed bin (21); /* the length of Outc which holds a line of canonical chars */ dcl Output_segment_length_in_words fixed bin (19); dcl Overwrite_exist_path_flag bit (1); dcl Ox fixed bin (21); /* output line index */ dcl Spaces_to_go fixed bin; /* counter */ dcl Second_temp_seg_ptr ptr; dcl Specified_infile_type fixed bin (2); dcl Specified_temp_file_flag bit (1) aligned; /* set when -temp_file PATH is specified */ dcl Seg_ptr ptr; /* ptr to an input segment. */ dcl Stops (40) fixed bin; dcl Stopx fixed bin; /* counter */ dcl Subroutine_call_flag bit (1) aligned; dcl Tab_flag bit (1) aligned; /* set if insert tabs. */ dcl Target_tabstop fixed bin; dcl Temp_msf_comp_bitc fixed bin (24); /* bit count of an component of an output MSF */ dcl Temp_msf_fcb_ptr ptr; /* pointer to the FCB for an output MSF */ dcl Temp_ptr ptr; dcl Temp_dn char (168); /* directory name contains a temp file */ dcl Temp_en char (32); /* temp file */ dcl Temp_seg_len fixed bin (21); /* the length of a temp seg */ dcl Temp_seg_len_in_chars fixed bin (21); /* the length of a temp seg in characters */ dcl Temp_seg_ptr ptr; /* points to a temp seg */ dcl Temp_msf_total_components fixed bin (24); /* the number of components in a temp MSF */ dcl Temp_msf_comp_index fixed bin; dcl Temp_msf_comp_ptr ptr; /* pointer to an component of an output MSF. */ dcl This_tabstop fixed bin; /* based */ dcl Arg char (Arg_len) based (Arg_ptr); /* temp storage for for each input argument on the command line. */ dcl Bcs char (Lth) based (Seg_ptr) aligned; /* holds the contents of the input file in NONcanonical form */ /* Temp storage for a char string in line. It has a char position and char value fields */ dcl 1 Bead (Bead_storage_size) based (Bead_ptr) aligned, 2 loc fixed bin (26) unal, 2 char char (1) unal; dcl Obuf char (512) based (Obuf_ptr); /* holds up to 512 chars of path1 in NONcanonical form */ /* temporary segment holds the contents of path1 in CANONICAL form */ dcl Outc char (Outc_len) based (Outc_ptr); /* holds the contents of one line of characters in CANONICAL form */ dcl Second_temp_seg char (Temp_seg_len_in_chars) based (Second_temp_seg_ptr); dcl Temp_seg char (Temp_seg_len_in_chars) based (Temp_seg_ptr); dcl System_area area based (Area_ptr); dcl Word_array (Output_segment_length_in_words) bit (36) based; /* an array of an output segment in words. */ /* builtin */ dcl ( addr, copy, divide, hbound, index, max, min, null, rank, reverse, rtrim, search, substr, unspec, verify ) builtin; /* condition */ dcl (cleanup, record_quota_overflow) condition; /* external entries */ dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl access_$reset entry (ptr, fixed bin (35)); dcl access_$set_temporarily entry (char (*), char (*), fixed bin (2), bit (*), ptr, fixed bin (35)); dcl active_fnc_err_ entry options (variable); dcl archive_$next_component entry (ptr, fixed bin (24), ptr, fixed bin (24), char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl com_err_$suppress_name entry options (variable); dcl command_query_$yes_no entry () options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); dcl dm_error_$file_in_use fixed bin (35) external; dcl ( error_table_$active_function, error_table_$archive_pathname, error_table_$bad_arg, error_table_$badopt, error_table_$dirseg, error_table_$empty_file, error_table_$rqover, error_table_$noarg, error_table_$noentry, error_table_$no_m_permission, error_table_$no_r_permission, error_table_$no_w_permission, error_table_$not_seg_type, error_table_$zero_length_seg ) fixed bin (35) external; dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl fs_util_$get_type entry (char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32) aligned); dcl get_pdir_ entry returns (char (168)); dcl get_system_free_area_ entry () returns (ptr); dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35)); dcl initiate_file_$create entry (char (*), char (*), bit (*), ptr, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3), fixed bin (35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$msf_get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)); dcl msf_manager_$open entry (char (*), char (*), ptr, fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin (24), bit (*), fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); /* like attribute */ dcl 1 oi aligned like object_info; /* static constants */ dcl ACL_REPLACED fixed bin (2) int static options (constant) init (2); dcl HT char (1) int static options (constant) init (" "); dcl NLVTFF char (3) int static options (constant) init (" "); dcl SP char (1) int static options (constant) init (" "); dcl BS char (1) int static options (constant) init (""); dcl CR char (1) int static options (constant) init (" "); dcl SPBSCRHT char (4) int static options (constant) init ("  "); dcl HTSP char (2) int static options (constant) init (" "); dcl BSCR char (2) int static options (constant) init (" "); dcl COMPONENT_ZERO fixed bin int static options (constant) init (0); dcl DIRECTORY fixed bin (2) int static options (constant) init (2); dcl MSF fixed bin (2) int static options (constant) init (3); dcl SEGMENT fixed bin (2) int static options (constant) init (1); dcl FALSE bit (1) int static options (constant) init ("0"b); dcl TRUE bit (1) int static options (constant) init ("1"b); dcl PRECISION_FIXED_BIN_17 fixed bin int static options (constant) init (17); dcl PRECISION_FIXED_BIN_19 fixed bin int static options (constant) init (19); dcl PRECISION_FIXED_BIN_21 fixed bin int static options (constant) init (21); dcl SWITCHES bit (6) int static options (constant) init ("100111"b); dcl THREE_BIT_SWITCH bit (3) int static options (constant) init ("111"b); dcl ME char (12) int static options (constant) init ("canonicalize"); /* -------------------------------------------------------------------------- */ %page; /* begin canonicalize main program */ call initialization; call parsing_input_arguments; if Ec ^= 0 then return; if ^Have_infile_flag then do; /* forget path1 */ call com_err_$suppress_name ((0), ME, "Usage: ^a path1 {path2} {-control_args}", ME); return; end; /* prepare access values for later reference */ if ^Have_outfile_flag then Desired_access = RW_ACCESS; /* when wanted to overwrite the original input file (segment or MSF) */ else Desired_access = R_ACCESS; /* otherwise, only "read" access is needed */ on cleanup begin; call clean_up; call term_segs; end; /* mainly proceeds canonicalization of an input file whose type is either a Segment or a Multisegment_file */ call get_temp_segment_ (ME, Outc_ptr, Ec); /* points to a temp storage Outc which holds one line of canincal chars */ if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get temp segment."); return; end; if ^Specified_temp_file_flag then do; /* by default, create a temp seg in the process directory */ /* points to a temp storage Temp_seg which holds a segment size of canonical chars */ call get_temp_segment_ (ME, Temp_seg_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get temp segment."); return; end; end; else do; /* -temp_file PATH was specified */ call hcs_$make_seg (Temp_dn, Temp_en, "", RW_ACCESS_BIN, Temp_seg_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en)); return; end; end; /* determine the entry type of an input file path1 and its length in bits */ call hcs_$status_minf (Dn, En, 1, Specified_infile_type, Bitc, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (Dn, En)); call release_temp_segment_ (ME, Outc_ptr, (0)); call release_temp_segment_ (ME, Temp_seg_ptr, (0)); return; end; if Specified_infile_type = SEGMENT then call canon_segment; else if Specified_infile_type = DIRECTORY then call canon_msf; else do; call com_err_ (error_table_$not_seg_type, ME, "^a", pathname_ (Dn, En)); call release_temp_segment_ (ME, Outc_ptr, (0)); call release_temp_segment_ (ME, Temp_seg_ptr, (0)); return; end; call clean_up; call term_segs; return; /* complete canonicalize main program */ /* --------------------------------------------------------------------------- */ %page; parsing_input_arguments: proc; /* evaluate each input argument specified on the command level. */ /* begin parsing_input_arguments procedure */ Ec = 0; call cu_$arg_count (Arg_count, Ec); if Ec ^= 0 then do; if Ec = error_table_$active_function then call active_fnc_err_ (Ec, ME); else call com_err_ (Ec, ME); return; end; do Arg_numb = 1 to Arg_count; call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME); return; end; if index (Arg, "-") = 1 then do; if Arg = "-output_tabs" | Arg = "-otabs" then do; Tab_flag = TRUE; Arg_numb = Arg_numb + 1; if Arg_numb > Arg_count then do; Ec = error_table_$noarg; call com_err_ (Ec, ME); return; end; call continue_parsing_arguments; if Ec ^= 0 then return; end; else if Arg = "-no_output_tabs" | Arg = "-notabs" then Tab_flag = FALSE; else if Arg = "-input_tabs" | Arg = "-itabs" then do; Arg_numb = Arg_numb + 1; if Arg_numb > Arg_count then do; Ec = error_table_$noarg; call com_err_ (Ec, ME); return; end; call continue_parsing_arguments; if Ec ^= 0 then return; end; else if Arg = "-force" | Arg = "-fc" then Overwrite_exist_path_flag = TRUE; else if Arg = "-no_force" | Arg = "-nfc" then Overwrite_exist_path_flag = FALSE; else if Arg = "-temp_file" | Arg = "-tf" then do; Specified_temp_file_flag = TRUE; if Arg_numb = Arg_count then do; /* -temp_file */ Ec = -1; call com_err_ (0, ME, "Missing PATH argument for ^a.", Arg); return; end; else do; /* -temp_file PATH */ Arg_numb = Arg_numb + 1; call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get PATH argument for -temp_file."); return; end; if index (Arg, "-") = 1 then do; /* -temp_file -bad_input_argument */ Ec = error_table_$badopt; call com_err_ (Ec, ME, "^a. Missing PATH argument for -temp_file.", Arg); return; end; call expand_pathname_ (Arg, Temp_dn, Temp_en, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot expand the given PATH argument ^a for -temp_file.", Arg); return; end; /* since the equal convention is allowed to specify a temp file similar to the input file */ call get_equal_name_ (En, Temp_en, Temp_en, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get an equal name similar to the original input file name ^a", pathname_ (Dn, En)); return; end; end; end; else do; Ec = error_table_$badopt; call com_err_ (Ec, ME, "^a", Arg); return; end; end; else if ^Have_infile_flag then do; call expand_pathname_ (Arg, Dn, En, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot expand the given input path1 ^a", Arg); return; end; Have_infile_flag = TRUE; end; else if ^Have_outfile_flag then do; Have_outfile_flag = TRUE; call expand_pathname_ (Arg, Out_dname, Eqln, Ec); if Ec ^= 0 then do; /* name for output seg */ call com_err_ (Ec, ME, "Cannot expand the specified output path2 ^a", Arg); return; end; call get_equal_name_ (En, Eqln, Out_ename, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get an equal name similar to the original file name ^a", pathname_ (Dn, En)); return; end; end; else do; Ec = error_table_$bad_arg; call com_err_$suppress_name (Ec, ME, "Usage: ^a path1 {path2} {-control_args}", ME); return; end; end; return; /* return from parsing_input_arguments procedure to canonicalize main program */ /* --------------------------------------------------------------------------- */ %page; continue_parsing_arguments: proc; call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", Arg); return; end; if Arg = "-every" | Arg = "-ev" then do; Arg_numb = Arg_numb + 1; if Arg_numb > Arg_count then do; Ec = error_table_$noarg; call com_err_ (Ec, ME, "Missing value for ^a", Arg); return; end; call cu_$arg_ptr (Arg_numb, Arg_ptr, Arg_len, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME); return; end; if Tab_flag then Everytab = cv_dec_check_ (Arg, Ec); else In_everytab = cv_dec_check_ (Arg, Ec); if Ec ^= 0 then do; Ec = error_table_$bad_arg; call com_err_ (Ec, ME, "^a", Arg); return; end; end; else do; if Tab_flag then call grab_tabs (Stops, Nstops); else call grab_tabs (In_stops, In_nstops); if Ec ^= 0 then return; end; return; /* return to parsing_input_arguments procedure */ end continue_parsing_arguments; /* --------------------------------------------------------------------------- */ %page; grab_tabs: proc (p_stops, p_nstop); dcl p_nstop fixed bin, /* number of stops set */ p_stops (*) fixed bin; /* array of set tab stops */ /* begin grab_tabs procedure */ Ec = 0; Kk = 1; do while (Kk < Arg_len); Jj = index (substr (Arg, Kk), ","); if Jj = 0 then Jj = Arg_len - Kk + 2; Mm = cv_dec_check_ (substr (Arg, Kk, Jj - 1), Ec); if Ec ^= 0 then do; Ec = error_table_$bad_arg; call com_err_ (Ec, ME, "^a", substr (Arg, Kk, Jj - 1)); return; end; p_nstop = p_nstop + 1; if p_nstop > hbound (p_stops, 1) - 1 then do; Ec = -1; /* indicates error */ call com_err_ (0, ME, "Too many ^[output^;input^] tabstops: ^d - max is ^d", Tab_flag, Mm, hbound (p_stops, 1) - 1); return; /* we blew it */ end; p_stops (p_nstop) = Mm; Kk = Kk + Jj; end; return; /* return to parsing_input_arguments. */ end grab_tabs; /* --------------------------------------------------------------------------- */ %page; end parsing_input_arguments; /* --------------------------------------------------------------------------- */ %page; canonicalize_tabs_: entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_tab_flag, p_code); dcl p_tab_flag bit (1); /* input parameter */ /* begin canonicalize_tabs_ external entry */ call initialization; Tab_flag = p_tab_flag; if Tab_flag then Everytab = 10; goto NON_MSF_COMMON; /* ----------------------------------------------------------------------- */ canonicalize_: entry (p_input_ptr, p_input_len, p_output_ptr, p_output_len, p_code); dcl p_code fixed bin (35); dcl p_input_ptr ptr; dcl p_input_len fixed bin (21); dcl p_output_ptr ptr; dcl p_output_len fixed bin (21); /* begin canonicalize_ entry */ call initialization; NON_MSF_COMMON: p_code = 0; /* prepare canonicalization of the given input file whose type is segment */ Seg_ptr = p_input_ptr; Lth = p_input_len; if Lth = 0 then do; /* the given input file is empty */ p_code = error_table_$zero_length_seg; return; end; on cleanup call clean_up; call get_temp_segment_ (ME, Outc_ptr, p_code); /* each line of the input file is canonicalized and then a line of */ /* canonical characters are stored in a temp segment pointed by Outc_ptr pointer */ if p_code ^= 0 then return; /* the entire input file is canonicalized and then the entire canonical */ /* characters are stored in a temp segment pointed by Temp_seg_ptr pointer */ call get_temp_segment_ (ME, Temp_seg_ptr, p_code); if p_code ^= 0 then return; /* do not create a temp MSF when canonicalization of an input file */ /* causes a temp segment reach its max seg size while canonicalization is in progress */ Do_not_create_temp_msf_flag = TRUE; call do_canon; /* convert the contents of the input SSF into a canonical form */ if Ec ^= 0 then p_code = Ec; else do; p_output_ptr -> Temp_seg = Temp_seg; /* copy Temp_seg into a specified output file whose type is segment */ p_output_len = Temp_seg_len_in_chars; /* update the length of the output file */ end; Seg_ptr = null; call clean_up; return; /* complete either canonicalize_tabs_ or canonicalize_ */ /* --------------------------------------------------------------------------- */ %page; validate_access: proc (p_dir, p_ename, p_type, p_desired_access, p_overwritten_flag); /* validate the access modes of the directory input parameter. If that */ /* directory doesn't have a "modify" mode then canon reports an error. */ /* Otherwise, an appropriate queried message will be printed when an user */ /* wanted to overwrite an input path1 or a specified existent output path2, */ /* but he either did not have a "write" access mode to it or has a */ /* sufficient access (rew or rw) to it. */ /* For the case of unsufficient access, if he answers yes to the question, */ /* a "write" mode is TEMPORARILY set on it. Otherwise, canon returns to the */ /* command level. */ /* in/out parameters */ dcl p_desired_access bit (*); /* input */ dcl (p_dir, p_ename) char (*); /* input */ dcl p_type char (*); /* input */ dcl p_overwritten_flag bit (1); /* input/output */ /* local */ dcl full_pathname char (168); dcl grand_dn char (168); dcl mode fixed bin (5); dcl msf_directory_pathname char (168); dcl parents_dn char (32); dcl ring fixed bin; dcl user_id char (32); /* begin validate_access procedure */ Ec = 0; full_pathname = " "; grand_dn = " "; mode = 0; msf_directory_pathname = " "; parents_dn = " "; ring = -1; /* indicates that a default value of the validation level of the calling process is used */ user_id = " "; on cleanup call clean_up; call absolute_pathname_ (p_dir, full_pathname, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get the absolute pathname of the directory ^a", p_dir); return; end; call expand_pathname_ (full_pathname, grand_dn, parents_dn, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot expand the directory ^a", full_pathname); return; end; user_id = get_group_id_ (); call hcs_$get_user_effmode (grand_dn, parents_dn, user_id, ring, mode, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get the user effective mode of directory ^a", pathname_ (grand_dn, parents_dn)); return; end; if (mode ^= M_ACCESS_BIN) & (mode ^= SM_ACCESS_BIN) & (mode ^= SMA_ACCESS_BIN) then do; Ec = error_table_$no_m_permission; call com_err_ (Ec, ME, "^a", pathname_ (grand_dn, parents_dn)); return; end; if p_type = FS_OBJECT_TYPE_SEGMENT then do; call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?", pathname_ (p_dir, p_ename)); if ^p_overwritten_flag then return; call access_$set_temporarily (p_dir, p_ename, SEGMENT, p_desired_access, Access_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot set ""write"" access mode on ^a", pathname_ (p_dir, p_ename)); return; end; end; if p_type = FS_OBJECT_TYPE_MSF then do; msf_directory_pathname = pathname_ (p_dir, p_ename); call hcs_$get_user_effmode (msf_directory_pathname, "0", user_id, ring, mode, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get effective access mode of component 0 for MSF ^a", pathname_ (p_dir, p_ename)); return; end; if (mode = N_ACCESS_BIN) | (mode = E_ACCESS_BIN) | (mode = W_ACCESS_BIN) then do; Ec = error_table_$no_r_permission; call com_err_ (Ec, ME, "^a", pathname_ (p_dir, p_ename)); return; end; else if (mode = R_ACCESS_BIN) | (mode = RE_ACCESS_BIN) then do; call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to update the protected file ^a?", pathname_ (p_dir, p_ename)); if ^p_overwritten_flag then return; /* add a "write" access mode temporarily on a "read" only MSF */ call access_$set_temporarily (p_dir, p_ename, MSF, p_desired_access, Access_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot set ""write"" access mode on ^a", pathname_ (p_dir, p_ename)); return; end; end; /* ask for overwritten a specified existent MSF after finding that */ /* it has a sufficient ACL (either RW_ACCESS_BIN or REW_ACCESS_BIN */ else call command_query_$yes_no (p_overwritten_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (p_dir, p_ename)); end; return; end validate_access; /* --------------------------------------------------------------------------- */ %page; canon_msf: proc; /* given an input file whose type is MSF, an user's request was wanted to */ /* convert its NONCANONICAL characters into a CANONICAL form. */ /* The canonical data can be put either back into that input file if wanted */ /* to overwrite it (e.g. canon infile_MSF) or into a specified output */ /* file (e.g. canon infile_MSF existent_or_nonexistent_outfile). Note */ /* that a specified output file can be ALREADY existed in an user's working */ /* working directory or NOT existed yet. */ /* */ /* If an output path2 is specified and is not existed yet in the current */ /* working directory, it will be created in one of the following methods: */ /* (a) by calling initiate_file_$create when canonicalization of the */ /* input MSF gives canonical characters which are stored in the */ /* Temp_seg and Temp_seg length has NEVER reached its max segment */ /* length. */ /* (b) by creating a temporary MSF when canonicalization of the input */ /* MSF gives canonical characters which are stored in the Temp_seg */ /* and Temp_seg length has reached its maximum segment length */ /* AT LEAST ONCE while canonicalization is in progress. This causes */ /* a temp MSF to be created to copy Temp_seg's contents into an */ /* appropriate component of the temp MSF in order to continue */ /* canonicalization of the remaining components of the input MSF. */ /* */ /* There are two cases for processing canonicalization of the original */ /* inut file whose entry type is Multissegment file (MSF): */ /* Case 1: MSF canonicalize MSF (unchanged: type is unchanged) */ /* Canonicalization of an input file, whose type is MSF, gives */ /* canonical characters to be stored in an output file. */ /* The length of the canonical output file is GREATER than the */ /* max length of a segment. So its type is MSF which is the same */ /* type as the type of the noncanonical input file path1. */ /* */ /* Case 2: MSF canonicalize SSF (shrink: type changed from MSF to SSF) */ /* Canonicalization of an input file path1, whose type is MSF, */ /* gives canonical characters to be stored in an output file. */ /* The length of the canonical output file is LESS or EQUAL than */ /* the max length of a segment. So the type of the canonical */ /* output file is SSF which is different type with the */ /* noncanonical input file path1 whose type is MSF. */ /* */ /* begin canon_msf procedure */ In_msf_total_original_comps = Bitc; /* save the total components of the input path1 MSF for later reference */ on cleanup call clean_up; if Bitc = 0 then do; /* the input path1 is a directory type which is not allowed for canon. */ call com_err_ (error_table_$dirseg, ME, "Cannot canonicalize a directory. ^a", pathname_ (Dn, En)); return; end; /* make sure that acceptable path1 type is either segment or Multisegment-file. */ call get_specified_file_type (Dn, En, Fs_util_type); if Ec ^= 0 then return; if ^Have_outfile_flag then do; /* only an input path1 is specified */ call validate_access (Dn, En, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag); if Ec ^= 0 then return; if ^Overwrite_exist_path_flag then return; /* did not want to overwrite the input path2 MSF */ end; else do; /* an output file path2 is specified */ call initiate_specified_output_file; if Ec ^= 0 then return; /* the specified output file path2 exists and do not want to overwrite it */ if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return; end; /* open the specified input path1 whose type is MSF */ call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot open MSF input file. ^a", pathname_ (Dn, En)); return; end; /* for each component of input path1 MSF, call do_canon to convert */ /* its noncanonical data into a canonical data which stored in Temp_seg */ do Input_msf_comp_index = COMPONENT_ZERO to (In_msf_total_original_comps - 1); /* get a specified component of the input file path1 whose type is MSF */ call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, FALSE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec); if Ec ^= 0 then do; /* the input MSF and the temp MSF will be closed in the clean_up internal proc */ if Seg_ptr ^= null then /* sp points to a specified component of the input file (MSF) path1 */ Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of the input MSF */ call com_err_ (Ec, ME, "Cannot get component ^d of input MSF ^a.", Input_msf_comp_index, pathname_ (Dn, En)); return; end; Seg_ptr = Input_msf_comp_ptr; /* prepare for converting a particular component's contents into a canonical form */ /* calculate the length of that component in characters */ Lth = divide (In_msf_comp_bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0); if Lth = 0 then do; Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of an input MSF */ Ec = error_table_$empty_file; call com_err_ (Ec, ME, "The component ^d of the input MSF ^a is empty.", Input_msf_comp_index, rtrim (pathname_ (Dn, En))); return; end; call do_canon; /* perform canonicalization of a specified component of the input MSF */ if Ec ^= 0 then do; /* the input MSF path1 and temp MSF will be closed in the clean_up int.proc */ Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of an input MSF */ return; end; Eof_flag = FALSE; /* prepare to convert the next component's contents of the input MSF into a canonical form */ end; /* complete read in components of the input path1 MSF */ if ^Create_temp_msf_flag then do; /* case: MSF canonicalize SSF SHRUNK */ if ^Have_outfile_flag then do; /* wanted to overwrite the input path1 MSF */ call copy_temp_seg_into_msf (Dn, En, Input_msf_fcb_ptr, COMPONENT_ZERO, Input_msf_comp_ptr, In_msf_comp_bitc, Temp_msf_total_components); if Ec ^= 0 then return; call msf_manager_$adjust (Input_msf_fcb_ptr, COMPONENT_ZERO, In_msf_comp_bitc, THREE_BIT_SWITCH, Ec); if Ec ^= 0 then do; /* the input MSF path1 will be closed in the clean_up internal proc. */ Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of an input MSF */ call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", COMPONENT_ZERO, rtrim (pathname_ (Dn, En))); return; end; end; /* only the input path1 was specified */ else do; /* output path2 was specified */ if Out_seg_ptr ^= null then /* the specified output path2 exists and its type is SSF */ /* put the contents of Temp_seg into a specified existent output path2 SSF */ call copy_temp_seg_into_segment; else if Nonexistent_outfile_flag then do; /* output path2 was specified and did not exist yet since Out_seg_ptr value is null */ /* so, creates and initiates the specified nonexistent output path2 */ call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec); if Ec ^= 0 then do; /* will close the input MSF path1 in the clean_up internal proc. */ Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of an input MSF */ call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; /* copy the contents of Temp_seg into a newly created segment */ call copy_temp_seg_into_segment; end; /* output path2 was specified and did not exist yet */ else if Fs_util_type = FS_OBJECT_TYPE_MSF then do; /* copy Temp_seg into the specified output path2 whose type is MSF */ call copy_temp_seg_into_spec_pth2_MSF; if Ec ^= 0 then do; /* will close the input MSF path1 in the clean_up internal proc. */ Seg_ptr = null; /* do not call terminate_file_ to terminate the current component of an input MSF */ return; end; end; /* copy Temp_seg into a specified existent path2 whose type is MSF */ end; /* copy Temp_seg into a specified path2 whose type is either SSF or MSF */ end; /* case: MSF canonicalize SSF SHRUNK */ else do; /* case: MSF canonicalize MSF UNCHANGED */ if Temp_seg_len_in_chars > 0 then do; call temp_seg_to_temp_msf; /* copy Temp_seg into a the next created component of a temp MSF */ if Ec ^= 0 then return; /* will close the input MSF path1 in the clean_up; temp MSF is already closed */ end; if ^Have_outfile_flag then do; /* only the input MSF path1 was specified */ call temp_msf_to_infile_or_outfile (Dn, En); if Ec ^= 0 then return; end; else do; /* open the specified output file path2 */ call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec); if Ec ^= 0 then do; if Ec ^= error_table_$noentry then do; call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; else Ec = 0; /* no problem. It will be created soon by the call to msf_manager_$msf_get_ptr */ end; /* copy temp MSF into the specified output file */ call temp_msf_to_infile_or_outfile (Out_dname, Out_ename); if Ec ^= 0 then return; if Out_seg_ptr ^= null then Out_seg_ptr = null; /* points to a specified output SSF path2. Do not call terminate_file_ */ end; /* output file path2 was specified */ end; /* case: MSF canonicalize MSF UNCHANGED */ return; end canon_msf; /* ------------------------------------------------------------------------ */ %page; canon_segment: proc; /* given an input file whose type is Segment, an user's request was to */ /* convert its NONCANICAL characters into a CANONICAL form. */ /* Canonical chars can be put either back into that input file if wanted */ /* to overwrite it (e.g. canon infile_MSF) or into a specified output */ /* file (e.g. canon infile_MSF existent_or_nonexistent_outfile). Note */ /* that a specified output file can be ALREADY existed in an user's working */ /* working directory or NOT existed yet. */ /* */ /* If an output path2 is specified and is not existed yet in the current */ /* working directory, it will be created in one of the following methods: */ /* (a) by calling initiate_file_$create when canonicalization of the */ /* input SSF gives canonical characters which are stored in the */ /* Temp_seg and Temp_seg length has NEVER reached its max segment */ /* length. */ /* (b) by creating a temporary MSF when canonicalization of the input */ /* SSF gives canonical characters which are stored in the Temp_seg */ /* and Temp_seg length has reached its maximum segment length */ /* AT LEAST ONCE while canonicalization is in progress. This causes */ /* a temp MSF to be created to copy Temp_seg's contents into an */ /* appropriate component of the temp MSF in order to continue */ /* canonicalization of the remaining components of the input SSF. */ /* */ /* There are two cases for processing canonicalization of a specified input */ /* file whose type is segment (SSF). */ /* */ /* Case 1: SSF canonicalize SSF (type is unchanged) */ /* Canonicalization of input file path1, whose type is SSF, gives */ /* canonical characters to be stored in an output file. */ /* Because the length of the canonical output file is LESS or EQUAL */ /* the maximum length of a segment, so the type of the output file */ /* is SSF which is the same type as the noncanical input file path1 */ /* */ /* Case 2: SSF canonicalize MSF (expanded: type is changed from SSF to MSF) */ /* Canonicalization of input file path1, whose type is SSF, gives */ /* canonical characters to be stored in an output file. */ /* Because the max length of canonical output file is GREATER than */ /* the max length of a segment, so the type of the canonical output */ /* file is MSF which is different type with the noncanonical input */ /* file path1 whose type is SSF. */ /* */ /* begin canon_segment procedure */ on cleanup call clean_up; if Bitc = 0 then do; /* the input path1 whose type is SSF is empty */ call com_err_ (error_table_$zero_length_seg, ME, "^a", pathname_ (Dn, En)); return; end; /* initiate the input path1 SSF */ call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, Ec); if Ec ^= 0 then do; if Ec = error_table_$no_w_permission then do;/* do not treat as an error until digging in details */ Fs_util_type = FS_OBJECT_TYPE_SEGMENT; call validate_access (Dn, En, Fs_util_type, Desired_access, Overwrite_exist_path_flag); if Ec ^= 0 then return; if ^Overwrite_exist_path_flag then return; /* must reinitiate again to get Seg_ptr pointer pointing to an input SSF path1 */ call initiate_file_ (Dn, En, Desired_access, Seg_ptr, Bitc, (0)); end; else do; call com_err_ (Ec, ME, "^a", pathname_ (Dn, En)); return; end; end; /* an error occured while initiating the input path1 */ /* assume had no problem with initiation. Ask for overwritting the input path1 */ if ^Have_outfile_flag & ^Overwrite_exist_path_flag then do; call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Dn, En)); if ^Overwrite_exist_path_flag then return; /* at this point, users want to overwrite the input path1 SSF */ Fs_util_type = FS_OBJECT_TYPE_SEGMENT; /* mark for later reference for the case: SSF canonicalize MSF (expanded) */ end; call archive_$next_component (Seg_ptr, Bitc, (null ()), (0), (""), Ec); if Ec = 0 then do; Ec = error_table_$archive_pathname; call com_err_ (Ec, ME, "The specified path is an archive. ^a", pathname_ (Dn, En)); return; end; oi.version_number = object_info_version_2; call object_info_$brief (Seg_ptr, Bitc, addr (oi), Ec); if Ec = 0 then do; Ec = error_table_$bad_arg; call com_err_ (Ec, ME, "The specified path is an object segment. ^a", pathname_ (Dn, En)); return; end; /* calculate the length of input path1 SSF in characters */ Lth = divide (Bitc + (BITS_PER_CHAR - 1), BITS_PER_CHAR, PRECISION_FIXED_BIN_21, 0); if Have_outfile_flag then do; /* output path2 is specified */ call initiate_specified_output_file; if Ec ^= 0 then return; /* the specified output file path2 exists and do not want to overwrite it */ if ^Nonexistent_outfile_flag & ^Overwrite_exist_path_flag then return; end; else Out_seg_ptr = Seg_ptr; /* Out_seg_ptr points to an input file path1 SSF because wanted to overwrite it */ call do_canon; /* convert the contents of the input SSF into a canonical form */ if Ec ^= 0 then return; if ^Create_temp_msf_flag then do; /* case: SSF canonicalize SSF (canonical chars are stored in a temp seg) */ if Out_seg_ptr ^= null then /* copy Temp_seg into either the input file (SSF) path1, or */ /* the specified existent output file (SSF) path2 */ call copy_temp_seg_into_segment; else if Nonexistent_outfile_flag then do; /* the specified output file path2 did not exist */ call initiate_file_$create (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Nonexistent_outfile_flag, Bitc, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; call copy_temp_seg_into_segment; /* copy Temp_seg contents into the newly created output file (SSF) path2 */ end; else do; /* the specified existent output path2 is a Multisegment-file (MSF) */ call copy_temp_seg_into_spec_pth2_MSF; if Ec ^= 0 then return; end; /* the specified existent output path2 is a Multisegment-file (MSF) */ /* terminate the input path1 SSF pointed by Seg_ptr pointer by call terminate_file_ */ call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0)); end; /* case: SSF canonicialize SSF */ else do; /* case: SSF canonicalize MSF */ if Temp_seg_len_in_chars > 0 then do; /* Temp_seg contains canonical characters */ call temp_seg_to_temp_msf; /* copy the contents of Temp_seg into a proper component of a temp MSF */ if Ec ^= 0 then return; end; if ^Have_outfile_flag then do; /* for overwritten an input path1 SSF */ call msf_manager_$open (Dn, En, Input_msf_fcb_ptr, Ec); if Ec ^= 0 then do; /* will close temp MSF in the clean_up internal proc. */ call com_err_ (Ec, ME, "^a", pathname_ (Dn, En)); return; end; /* copy the contents of temp msf into the input path1 SSF which converted to MSF */ call temp_msf_to_infile_or_outfile (Dn, En); if Ec ^= 0 then return; Seg_ptr = null; /* don't call terminate_file_ because the input SSF path1 has converted to MSF */ end; else do; /* a output path2 was specified */ /* open either a specified existent output path2 whose type either SSF or MSF */ /* or a specified nonexistent output file path2 */ call msf_manager_$open (Out_dname, Out_ename, Input_msf_fcb_ptr, Ec); if Ec ^= 0 then do; if Ec ^= error_table_$noentry then do; /* will close the temp MSF in the clean_up internal procedure */ call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; else Ec = 0; /* OK for specifying a nonexistent output file path2 */ /* it will be created when msf_manager_$msf_get_ptr is called */ end; /* copy the contents of temp MSF into a specified output file path2 */ call temp_msf_to_infile_or_outfile (Out_dname, Out_ename); if Ec ^= 0 then do; if Nonexistent_outfile_flag then call delete_$path (Out_dname, Out_ename, SWITCHES, ME, (0)); return; end; /* call terminate_file_ to terminate the input SSF path1 after */ /* copying the contents of temp MSF into a specified output file path2 */ call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0)); end; end; /* case: SSF CANONICALIZE MSF EXPANDED */ return; end canon_segment; /* --------------------------------------------------------------------------- */ %page; clean_up: proc; /* begin clean_up procedure */ if Access_ptr ^= null then do; /* a write access mode has been temporarily added to a read only file */ if Create_temp_msf_flag then do; /* a temp MSF has been created earlier */ if Fs_util_type = FS_OBJECT_TYPE_SEGMENT then do; /* must take care the ACL of the converted MSF whose original type is SSF */ Access.type = MSF; /* reinitialize to 3 to indicate that the new entry type is MSF */ Access.set = ACL_REPLACED; /* prepare to replace the current ACL with its original ACL */ Access.old_mode = R_ACCESS; /* restore its origial access mode */ call access_$reset (Access_ptr, (0)); /* replace the current ACL with the original ACL */ end; /* the original type of the converted path2 MSF was SSF */ if Fs_util_type = FS_OBJECT_TYPE_MSF then /* the original entry type was MSF */ call access_$reset (Access_ptr, (0)); /* remove the "write" access mode that temporarily added earlier */ end; /* a temp MSF was created */ else if Fs_util_type ^= " " then do; /* a temp MSF has NEVER been created and the entry type is SSF or MSF */ if Fs_util_type = FS_OBJECT_TYPE_MSF then /* the original type of the converted path2 SSF was MSF */ Access.type = SEGMENT; /* update the entry type which is SSF */ call access_$reset (Access_ptr, (0)); /* remove the "write" access mode that temporarily added earlier */ end; end; /* a "write" access mode has been temporarily added to a "read" only in/out file */ if Input_msf_fcb_ptr ^= null then do; call msf_manager_$close (Input_msf_fcb_ptr); if Seg_ptr ^= null then Seg_ptr = null; /* double check since sp pointed to a specified component of an input MSF path1 */ /* or to the convert input MSF path1 whose original type was SSF */ end; if Temp_msf_fcb_ptr ^= null then do; call msf_manager_$close (Temp_msf_fcb_ptr); if Out_seg_ptr ^= null then Out_seg_ptr = null; /* double check since Out_seg_ptr pointed to the converted output MSF path2 whose original type is SSF */ end; if Temp_ptr ^= null then free Temp_ptr -> Bead; if Outc_ptr ^= null then call release_temp_segment_ (ME, Outc_ptr, (0)); if Temp_seg_ptr ^= null then do; if ^Specified_temp_file_flag then call release_temp_segment_ (ME, Temp_seg_ptr, (0)); else do; Temp_seg_ptr = null; call delete_$path (Temp_dn, Temp_en, SWITCHES, ME, (0)); end; end; if Second_temp_seg_ptr ^= null then call release_temp_segment_ (ME, Second_temp_seg_ptr, (0)); return; end clean_up; /***************************************************************************/ /* This is part of the clean_up procedure that is not required if the call has come thru canonicalize_ or canonicalize_tabs_. */ term_segs: proc; if Out_seg_ptr = Seg_ptr then Out_seg_ptr = null; /* Out_seg_ptr also pointed to source since wanted to overwrite the input file path1 */ if Seg_ptr ^= null then call terminate_file_ (Seg_ptr, (0), TERM_FILE_TERM, (0)); if Out_seg_ptr ^= null then call terminate_file_ (Out_seg_ptr, (0), TERM_FILE_TERM, (0)); end term_segs; /****************************************************************************/ /* -------------------------------------------------------------------------- */ %page; copy_temp_seg_into_msf: proc (p_dn, p_en, p_fcb_ptr, p_comp_index, p_comp_ptr, p_comp_bitc, p_temp_msf_total_components); /* put the contents of Temp_seg which contains canonical characters into */ /* either an appropriate component of the temp MSF or component 0 of a */ /* specified output path2 whose type is MSF. */ /* parameters */ dcl (p_dn, p_en) char (*); dcl (p_comp_ptr, p_fcb_ptr) ptr; dcl p_comp_index fixed bin; dcl (p_comp_bitc, p_temp_msf_total_components) fixed bin (24); /* begin copy_temp_seg_into_msf procedure */ Ec = 0; on cleanup call clean_up; on record_quota_overflow begin; Ec = error_table_$rqover; call msf_manager_$close (p_fcb_ptr); revert record_quota_overflow; goto temp_seg_to_msf_ERROR_RETURN; end; /* want to create a specified component if it doesn't exist yet */ call msf_manager_$msf_get_ptr (p_fcb_ptr, p_comp_index, TRUE, p_comp_ptr, p_comp_bitc, Ec); if Ec ^= 0 then do; call msf_manager_$close (p_fcb_ptr); if Fs_util_type = FS_OBJECT_TYPE_MSF then call com_err_ (Ec, ME, "Cannot get component ^d of specified output MSF ^a", p_comp_index, pathname_ (p_dn, p_en)); else call com_err_ (Ec, ME, "Cannot get component ^d of temp MSF ^a", p_comp_index, pathname_ (p_dn, p_en)); return; end; p_comp_ptr -> Temp_seg = Temp_seg; /* copy the contents of Temp_seg into into a specified component */ if (p_comp_index = 0) & (p_temp_msf_total_components = 0) then /* case of a specified path2 is nonexistent and a temp MSF has been created */ p_temp_msf_total_components = 1; /* update the total number of components in a temp MSF */ /* calculate the bitc count of that component */ p_comp_bitc = Temp_seg_len_in_chars * BITS_PER_CHAR; temp_seg_to_msf_ERROR_RETURN: return; end copy_temp_seg_into_msf; /* --------------------------------------------------------------------------- */ %page; copy_temp_seg_into_spec_pth2_MSF: proc; /* copy the contents of Temp_seg into the component 0 of a specified output */ /* path2 whose type is MSF. */ /* begin copy_temp_seg_into_spec_pth2_MSF procedure */ /* get File control Block pointer */ call msf_manager_$open (Out_dname, Out_ename, Temp_msf_fcb_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; /* copy Temp_seg into the component 0 of the specified output path2 MSF */ call copy_temp_seg_into_msf (Out_dname, Out_ename, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Temp_msf_total_components); if Ec ^= 0 then return; /* sets the bit count, truncates, and terminates its component 0 */ call msf_manager_$adjust (Temp_msf_fcb_ptr, (Temp_msf_comp_index), Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec); if Ec ^= 0 then do; call msf_manager_$close (Temp_msf_fcb_ptr); call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Out_dname, Out_ename)); return; end; return; end copy_temp_seg_into_spec_pth2_MSF; /* --------------------------------------------------------------------------- */ %page; copy_temp_seg_into_segment: proc; /* when canonicalization of an input SSF is finished and Temp_seg length has */ /* not reached the system defined max length yet, CHARS_PER_SEGMENT, */ /* copy_temp_seg_into_segment copies the contents of Temp_seg into one */ /* of the following files: */ /* (a) the specified output path2. Note that if it did not exist, it */ /* was created by calling initiate_file_$create earlier. */ /* (b) the original input path1. */ dcl output_segment_length_in_bits fixed bin (24); /* begin copy_temp_seg_into_segment procedure */ output_segment_length_in_bits = 0; on cleanup call clean_up; on record_quota_overflow begin; Ec = error_table_$rqover; revert record_quota_overflow; goto temp_seg_to_segment_ERROR_RETURN; end; Output_segment_length_in_words = divide (Temp_seg_len_in_chars + (CHARS_PER_WORD - 1), CHARS_PER_WORD, PRECISION_FIXED_BIN_19, 0); call terminate_file_ (Out_seg_ptr, (Output_segment_length_in_words), TERM_FILE_TRUNC, Ec); if Ec ^= 0 then do; if Out_seg_ptr = Seg_ptr then call com_err_ (Ec, ME, "^a", pathname_ (Dn, En)); else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; /* Clear last word used */ Out_seg_ptr -> Word_array (Output_segment_length_in_words) = FALSE; Out_seg_ptr -> Temp_seg = Temp_seg; /* copy canonical data into either input path1 or a specified output path2 */ output_segment_length_in_bits = Temp_seg_len_in_chars * BITS_PER_CHAR; call terminate_file_ (Out_seg_ptr, (output_segment_length_in_bits), TERM_FILE_BC, Ec); if Ec ^= 0 then do; if Out_seg_ptr = Seg_ptr then call com_err_ (Ec, ME, "^a", pathname_ (Dn, En)); else call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; temp_seg_to_segment_ERROR_RETURN: call terminate_file_ (Out_seg_ptr, (0), TERM_FILE_TERM, Ec); return; end copy_temp_seg_into_segment; /* -------------------------------------------------------------------------- */ %page; do_canon: procedure; /* Each line of either the input segment or the specified component of the */ /* input MSF is read in. Scan each character in that line to find out */ /* whether it is a normal character or a specified character. For standard */ /* characters, no convertion to canonical form is made, just copied them */ /* into Outc. However, for special characters such as Backspace (BS), SP, */ /* Carriage return (CR), Horizontal tab (HT), ect., special processing is */ /* required to convertion them into standard (canonical) form before storing */ /* in Outc. So, continue to proceed the input line until a slew character */ /* is found. Then copy the Outc which contains a line of characters in */ /* standard (canonical) form into the Temp_seg. At this point, canon */ /* checks the length of Temp_seg in order to decide what actions will be */ /* taken next if tem_seg length reaches the maximum segment length. */ /* (a) Assume that the max segment length has not been reached. Read in the */ /* next input line. Repeat canonicalization of that line. do_canon */ /* terminates the convertion after the last line of the input segment */ /* or of a specified component of the input MSF has been converted into */ /* a canonical form. */ /* (b) Assume that the max segment length has been reached while */ /* canonicalization is in progress. A temporarly MSF is created in */ /* either the process directory with a unique name (by default) or */ /* in a specified directory (-temp_file was specified). Copy Temp_seg */ /* which is now full into a specified component of the newly created */ /* temp MSF. Then clear out the Temp_seg before continuing to put the */ /* remaining contents of Outc (which is left over) into Temp_seg. */ /* do_canon terminates the canonicalization of the input file after */ /* the last line of the input file has been converted. */ /* */ /* A "slew" character is a line-terminator (NL, VT, or FF). */ dcl available_pos_for_insertion fixed bin (21); dcl next_char_pos fixed bin (21); dcl remaining_pos_for_insertion fixed bin (21); dcl slew_index fixed binary (21); dcl slew_present_flag bit (1); %page; /* begin do_canon procedure */ Ec = 0; available_pos_for_insertion = 0; remaining_pos_for_insertion = 0; Obuf_ptr = null; Beg_line = 1; /* beginning line position */ on cleanup call clean_up; Bead_storage_size = hbound (Bead_storage, 1); Bead_ptr = addr (Bead_storage); Area_ptr = get_system_free_area_ (); do while (^Eof_flag); /* scan each existing line of the input (segment or MSF component). */ Outc_len, Ox = 0; /* clear out Outc which contains a line of caninical chars before continuing */ /* to convert the next input line into canonical form and store them in Outc */ Nch = 0; /* no chars seen */ Obuf_ptr = addr (substr (Bcs, Beg_line, 1)); /* locate begin of line */ Chars_in_line = search (substr (Bcs, Beg_line), NLVTFF); /* find end of line */ if Chars_in_line = 0 then do; /* no more NL or other slew chars remain in input */ slew_present_flag = FALSE; Chars_in_line = Lth - Beg_line + 2; /* include a mythical slew char in count */ end; else slew_present_flag = TRUE; /* NL or other slew char found in input */ Beg_line = Beg_line + Chars_in_line; /* up to begin of next line */ if Beg_line > Lth then Eof_flag = TRUE; slew_index = Chars_in_line; /* Remove trailing SPBSCRHTs. */ Chars_to_remove = verify (reverse (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1)), SPBSCRHT); if Chars_to_remove = 0 then Chars_to_remove = Chars_in_line; Chars_in_line = Chars_in_line - Chars_to_remove + 1; Col, Jj, In_stopx, Stopx, Next_pos = 1; if search (substr (Obuf_ptr -> Bcs, 1, Chars_in_line - 1), BSCR) ^= 0 then do; /* special processing necessary */ do while (Jj <= Chars_in_line - 1); /* .. simulating a typewriter */ if substr (Obuf, Jj, 1) = BS then do; Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), BS) - 1; Jj = Jj + Ii; Col = max (Col - Ii, 1); /* don't backspace off end */ end; else if substr (Obuf, Jj, 1) = CR then do; Col = 1; Jj = Jj + 1; end; else if substr (Obuf, Jj, 1) = HT then do; Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), HT) - 1; if In_nstops > 0 then do; if Col >= In_stops (In_nstops) then Col = Col + Ii; else do; do In_stopx = In_stopx to In_nstops + 1 while (Col >= In_stops (In_stopx)); end; if In_stopx + Ii > In_nstops then Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops; else Col = In_stops (In_stopx + Ii - 1); end; end; else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1; Jj = Jj + Ii; end; else if substr (Obuf, Jj, 1) = SP then do; Ii = verify (substr (Obuf, Jj, Chars_in_line - Jj), SP) - 1; Jj = Jj + Ii; Col = Col + Ii; end; else do; /* printing char */ Nch = Nch + 1; /* allocate */ if Nch > Bead_storage_size then do; /* make sure don't blow array */ Mm = Bead_storage_size; Bead_storage_size = 2 * Bead_storage_size; allocate Bead set (Temp_ptr) in (System_area); Bead_storage_size = Mm; Temp_ptr -> Bead = Bead; if Bead_ptr ^= addr (Bead_storage) then free Bead; Bead_ptr = Temp_ptr; Bead_storage_size = 2 * Bead_storage_size; end; Bead (Nch).char = substr (Obuf, Jj, 1); Bead (Nch).loc = Col; /* note (aparent) position */ if (rank (substr (Obuf, Jj, 1)) >= rank (" ") & rank (substr (Obuf, Jj, 1)) <= rank ("~")) then Col = Col + 1; Jj = Jj + 1; end; end; /* looping termination */ call sort; /* all chars done. sort array */ Next_pos = 1; /* next output pos */ do Charx = 1 to Nch; /* now put out the chars in right order */ if Charx > 1 then do; if unspec (Bead (Charx)) = unspec (Bead (Charx - 1)) then goto do_canon_SKIP; end; /* Canonical form says no duplicate in same pos */ Spaces_to_go = Bead (Charx).loc - Next_pos; /* number of spaces to put */ if Spaces_to_go > 0 then do; /* if space needed */ if Tab_flag & Spaces_to_go > 1 then do; /* inserting tabs? */ if Nstops > 0 then do; do Stopx = 1 to Nstops while (Next_pos >= Stops (Stopx)); end; Cantab_flag = (Stopx <= Nstops); do while (Cantab_flag & (Bead (Charx).loc >= Stops (Stopx))); call output (HT); Next_pos = Stops (Stopx); Spaces_to_go = Bead (Charx).loc - Next_pos; /* Recalculate spaces needed. */ if Stopx >= Nstops then Cantab_flag = FALSE; else if Stops (Stopx + 1) > Bead (Charx).loc then Cantab_flag = FALSE; else Stopx = Stopx + 1; end; end; else do; /* -every case */ Target_tabstop = Everytab * divide (Bead (Charx).loc - 1, Everytab, PRECISION_FIXED_BIN_17, 0) + 1; do while (Next_pos < Target_tabstop); call output (HT); This_tabstop = Everytab * divide (Next_pos - 1 + Everytab, Everytab, PRECISION_FIXED_BIN_17, 0) + 1; Next_pos = This_tabstop; Spaces_to_go = Bead (Charx).loc - Next_pos; /* Recalculate spaces needed */ end; end; end; do Ii = 1 to Spaces_to_go; /* put out blanks */ call output (SP); end; end; /* We consider nonprinting characters to not take up space for the purposes of calculating tabs and so forth, but we don't actually want to separate them by backspaces. */ if Spaces_to_go < 0 & (rank (Bead (Charx).char) >= rank (" ") & rank (Bead (Charx).char) <= rank ("~")) then call output ((BS)); /* never more than one */ call output (Bead (Charx).char); /* type char out */ Next_pos = Bead (Charx).loc + 1; /* next column */ do_canon_SKIP: end; end; /* typewriter simulation */ else do; /* just take the whole line */ Nch = 1; /* non_zero to start copy */ if ^Tab_flag then do; /* process case with space fill */ do while (Nch ^= 0); Nch = index (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT); /* find HT */ if Nch = 0 then Ii = Chars_in_line - Jj; else Ii = Nch - 1; /* omit the tab in copy */ if Ii > 0 then do; Outc_len = Outc_len + Ii; substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii); do Kk = Jj to (Jj + Ii - 1); if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~")) then Col = Col + 1; end; Ox = Ox + Ii; Jj = Jj + Ii; end; if Nch ^= 0 then do; /* fill spaces */ Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1; /* take out multiples */ Next_pos = Col; if In_nstops > 0 then do; if Col >= In_stops (In_nstops) then Spaces_to_go = Ii; else do; do In_stopx = In_stopx to In_nstops + 1 while (Col >= In_stops (In_stopx)); end; if In_stopx + Ii > In_nstops then Spaces_to_go = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops - Col; else Spaces_to_go = In_stops (In_stopx + Ii - 1) - Next_pos; end; end; else Spaces_to_go = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1 - Next_pos; /* number of spaces to fill in */ Outc_len = Outc_len + Spaces_to_go; substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go); Ox = Ox + Spaces_to_go; Col = Col + Spaces_to_go; Jj = Jj + Ii; /* add source space for the tab */ end; end; end; %page; /* Process Case with Tab Fill */ else do; do while (Jj <= Chars_in_line - 1); /* Clip spacing before section */ do while (search (substr (Obuf_ptr -> Bcs, Jj, 1), HTSP) ^= 0); if substr (Obuf_ptr -> Bcs, Jj, 1) = SP then do; Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), SP) - 1; Col = Col + Ii; Jj = Jj + Ii; end; else do; Ii = verify (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HT) - 1; if In_nstops > 0 then do; if Col >= In_stops (In_nstops) then Col = Col + Ii; else do; do In_stopx = In_stopx to In_nstops + 1 while (Col >= In_stops (In_stopx)); end; if In_stopx + Ii > In_nstops then Col = In_stops (min (In_stopx + Ii - 1, In_nstops)) + In_stopx + Ii - 1 - In_nstops; else Col = In_stops (In_stopx + Ii - 1); end; end; else Col = In_everytab * (divide (Col - 1, In_everytab, PRECISION_FIXED_BIN_17, 0) + Ii) + 1; Jj = Jj + Ii; end; end; /* At this point initial white space has been clipped, Col = column after the white space, and Next_pos = last column printed + 1. Now section through the tabulation. */ Spaces_to_go = Col - Next_pos;/* number of spaces to put */ if Spaces_to_go > 0 then do; /* if space needed */ if (Tab_flag) & (Spaces_to_go > 1) then do; /* inserting tabs? */ if Nstops > 0 then do; if Next_pos > Stops (Nstops) then goto omit_simple_spaces; /* beyond reach */ /* Start from last tabstop for scan */ do Stopx = Stopx to Nstops + 1 while (Next_pos >= Stops (Stopx)); end; do Ii = Stopx to Nstops + 1 while (Col >= Stops (Ii)); end; /* find terminator */ Ii = Ii - Stopx; /* number of tabs involved */ if Ii < 1 then goto omit_simple_spaces; /* no tabs involved */ Spaces_to_go = Col - Stops (Ii + Stopx - 1); /* spaces after last tab */ end; else do; /* -every */ /* tabstop number */ Target_tabstop = divide (Col - 1, Everytab, PRECISION_FIXED_BIN_17, 0); /* number of tabs to do */ Ii = Target_tabstop - divide (Next_pos - 1, Everytab, PRECISION_FIXED_BIN_17, 0); if Ii < 1 then goto omit_simple_spaces; /* no tabbing involved */ Spaces_to_go = Col - (Target_tabstop * Everytab + 1); /* spaces left after */ end; if Ii > 0 then do; Outc_len = Outc_len + Ii; substr (Outc, Ox + 1, Ii) = copy (HT, Ii); Ox = Ox + Ii; /* Output Horizontal tabs */ end; end; omit_simple_spaces: if Spaces_to_go > 0 then do; Outc_len = Outc_len + Spaces_to_go; substr (Outc, Ox + 1, Spaces_to_go) = copy (SP, Spaces_to_go); Ox = Ox + Spaces_to_go; end; end; /* Take out a string of text, to next gap. */ Ii = search (substr (Obuf_ptr -> Bcs, Jj, Chars_in_line - Jj), HTSP) - 1; if Ii < 1 then Ii = Chars_in_line - Jj; Outc_len = Outc_len + Ii; substr (Outc, Ox + 1, Ii) = substr (Obuf_ptr -> Bcs, Jj, Ii); /* output string */ Ox = Ox + Ii; do Kk = Jj to (Jj + Ii - 1); if (rank (substr (Obuf_ptr -> Bcs, Kk, 1)) >= rank (" ") & rank (substr (Obuf_ptr -> Bcs, Kk, 1)) <= rank ("~")) then Col = Col + 1; end; Jj = Jj + Ii; Next_pos = Col; end; /* end of parse loop */ end; end; if slew_present_flag then /* finally, append the slew char to the Outc which contains a line of CANONINCAL chars */ call output (substr (Obuf, slew_index, 1)); /* check the boundary of temp seg after adding an entire line of canonincal chars to it */ if (Temp_seg_len_in_chars + Outc_len) < CHARS_PER_SEGMENT then do; /* copy the entire line of canonical chars (stored in Outc) into the Temp_seg */ next_char_pos = Temp_seg_len_in_chars + 1; Temp_seg_len_in_chars = Temp_seg_len_in_chars + Outc_len; substr (Temp_seg, next_char_pos, Outc_len) = Outc; end; else do; /* case of reaching the maximum length of Temp_seg */ /* calculate the number of spaces left in temp seg, then filled up temp seg */ available_pos_for_insertion = CHARS_PER_SEGMENT - Temp_seg_len_in_chars; next_char_pos = Temp_seg_len_in_chars + 1; Temp_seg_len_in_chars = Temp_seg_len_in_chars + available_pos_for_insertion; substr (Temp_seg, next_char_pos, available_pos_for_insertion) = substr (Outc, 1, available_pos_for_insertion); if Do_not_create_temp_msf_flag then do; /* the canonicalize_tab_ and canonincal_ entries don't want to expand path1 SSF into MSF */ Ec = error_table_$rqover; return; end; /* temp seg containing canonical characters is full */ if ^Create_temp_msf_flag then do; Create_temp_msf_flag = TRUE; if ^Specified_temp_file_flag then do; /* by default: prepare to create a temp MSF in the process directory with an unique name */ Temp_dn = get_pdir_ (); Temp_en = unique_chars_ (FALSE); end; else do; /* a temp segment ws created ealier by hcs_$make_seg when -tf was given */ /* this specified temp segment will be converted to a temp MSF very soon. */ /* So, canon must get another temp seg for continuing canonicalization. */ call get_temp_segment_ (ME, Second_temp_seg_ptr, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get temp segment."); return; end; /* copy the specified temp segment's contents into another temp segment */ Second_temp_seg_ptr -> Second_temp_seg = Temp_seg_ptr -> Temp_seg; /* assign Temp_seg_ptr points to another temp segment */ /* such that the remaining canonical chars will be stored in the second temp seg */ /* and the specified temp segment in a specified directory will be */ /* converted into a temp MSF by calling msf_manager_$msf_get_ptr soon */ /* in the call to copy_temp_seg_into_msf internal procedure */ Temp_seg_ptr = Second_temp_seg_ptr; Second_temp_seg_ptr = null; /* no need */ end; /* open temp MSF. Wants a pointer that points to the FCB of the temp MSF */ call msf_manager_$open (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Ec); if Ec ^= 0 then do; if Ec ^= error_table_$noentry then do; call com_err_ (Ec, ME, "^a", pathname_ (Temp_dn, Temp_en)); return; end; else Ec = 0; /* OK for temp MSF not found. It will be created in copy_temp_seg_into_msf */ end; end; /* prepare to request a component greater than 0 */ if Temp_msf_total_components > 0 then do; Temp_msf_comp_index = Temp_msf_total_components; Temp_msf_total_components = Temp_msf_total_components + 1; end; /* copy tem_seg into an appropriate component of a newly created temp MSF */ call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Temp_msf_total_components); if Ec ^= 0 then return; Temp_seg_len_in_chars = 0; /* clear out Temp_seg to indicate it is now empty. */ /* Is any char left in the Outc after filled up tem_seg? */ remaining_pos_for_insertion = Outc_len - available_pos_for_insertion; if remaining_pos_for_insertion > 0 then do; /* copy left over canonical characters from the Outc into Temp_seg */ Temp_seg_len_in_chars = remaining_pos_for_insertion; substr (Temp_seg, 1, remaining_pos_for_insertion) = substr (Outc, available_pos_for_insertion + 1, remaining_pos_for_insertion); end; end; /* case of reaching the boundary of Temp_seg */ end; /* end of do while (^Eof_flag) */ return; /* return from do_canon procedure */ /* --------------------------------------------------------------------------- */ %page; output: proc (p_slew_char); /* append a slew character (NL, VT, or FF) to Outc which contains a line */ /* of canonical (standard) characters. */ dcl p_slew_char char (1); /* input parameter */ /* begin output procedure which is called by do_canon procedure */ Outc_len, Ox = Ox + 1; /* update canonical line length. Also update output line index */ substr (Outc, Ox, 1) = p_slew_char; /* append a slew character to a line of canonical character */ return; /* return to do_canon procedure */ end output; /* -------------------------------------------------------------------------- */ %page; sort: proc; /* Sort characters in Bead array of record. Bead contains characters */ /* and corresponding character positions in the current line. Nch is */ /* the actual upper bound of the array. */ dcl d fixed bin; dcl i fixed bin; dcl swaps fixed bin; dcl temp bit (36) aligned; /* begin sort procedure */ d = Nch; /* get the actual max array index */ sort_pass: swaps = 0; /* prepare to sort characters in alphabetic order */ d = divide (d + 1, 2, 17, 0); /* split the entire portion into two equal array portions */ do i = 1 to Nch - d; /* loop through the upper portion */ /* compare each character in the upper portion with each character in the lower portion, respectively */ if unspec (Bead (i)) > unspec (Bead (i + d)) then do; swaps = swaps + 1; temp = unspec (Bead (i)); unspec (Bead (i)) = unspec (Bead (i + d)); unspec (Bead (i + d)) = temp; end; end; if d > 1 then goto sort_pass; /* continue to split the upper array portion based on upper array portion's update max index */ if swaps > 0 then goto sort_pass; return; /* return to do_canon procedure */ end sort; /* --------------------------------------------------------------------------- */ %page; end do_canon; /* --------------------------------------------------------------------------- */ %page; get_specified_file_type: proc (p_dn, p_en, p_fs_util_type); /* get the entry type of a specified file by calling fs_util_$get_type. */ /* Only accept canonicalization of either a single Segment file (SSF) or */ /* a Multisegment_file (MSF). */ /* parameters */ dcl (p_dn, p_en) char (*); /* input */ dcl p_fs_util_type char (32); /* in/out */ /* begin get_specified_file_type procedure */ Ec = 0; call fs_util_$get_type (p_dn, p_en, p_fs_util_type, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en)); return; end; if p_fs_util_type = FS_OBJECT_TYPE_DIRECTORY then do; Ec = error_table_$dirseg; call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en)); end; if p_fs_util_type = FS_OBJECT_TYPE_DM_FILE then do; Ec = dm_error_$file_in_use; call com_err_ (Ec, ME, "^a", pathname_ (p_dn, p_en)); end; return; end get_specified_file_type; /* ------------------------------------------------------------------------ */ %page; initialization: proc; /* initializes all automatic variables. They are grouped together */ /* depending on their data types. For each group, their appearance */ /* is based on alphabetic order. This purpose is used to speed up canon. */ /* begin initialization procedure */ Access_ptr, Input_msf_comp_ptr, Input_msf_fcb_ptr, Outc_ptr, Out_seg_ptr, Second_temp_seg_ptr, Seg_ptr, Temp_msf_comp_ptr, Temp_msf_fcb_ptr, Temp_ptr, Temp_seg_ptr = null; Bitc, Ec, Everytab, Input_msf_comp_index, In_msf_comp_bitc, In_msf_total_original_comps, In_nstops, In_stops (*), Mm, Nstops, Specified_infile_type, Stops (*), Temp_msf_comp_bitc, Temp_msf_comp_index, Temp_msf_total_components, Temp_seg_len, Temp_seg_len_in_chars = 0; Dn, En, Fs_util_type, Out_dname, Out_ename, Temp_dn, Temp_en = " "; Create_temp_msf_flag, Do_not_create_temp_msf_flag, Eof_flag, Have_infile_flag, Have_outfile_flag, Overwrite_exist_path_flag, Nonexistent_outfile_flag, Specified_temp_file_flag, Subroutine_call_flag, Tab_flag = FALSE; Desired_access = (36)"0"b; In_everytab = 10; /* by default */ return; end initialization; /* --------------------------------------------------------------------------- */ %page; initiate_specified_output_file: proc; /* initiate the specified output file path2. If suceeds initiatation, ask */ /* for overwritten the specified existent output path2. */ /* begin initiate_specified_output_file procedure */ Ec = 0; call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec); if Ec ^= 0 then do; if Ec = error_table_$noentry then do; /* it's OK for a specified NONEXISTENT output path2. Will make it exist later on */ /* depending on either case MSF canonicalize MSF or MSF canonicalize SSF */ Ec = 0; Nonexistent_outfile_flag = TRUE; /* mark that the specified output path2 does not exist. */ end; else if Ec = error_table_$no_w_permission then do; /* do not treat as an error until digging in details */ Fs_util_type = FS_OBJECT_TYPE_SEGMENT; call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag); if Ec ^= 0 then return; if ^Overwrite_exist_path_flag then return; /* must reinitiate again to get its pointer value, Out_seg_ptr */ call initiate_file_ (Out_dname, Out_ename, RW_ACCESS, Out_seg_ptr, Bitc, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; end; else if Ec = error_table_$dirseg then do; /* the specified output path2 EXISTS and its type is either directory or MSF */ /* do not treat as an error until digging in details */ call get_specified_file_type (Out_dname, Out_ename, Fs_util_type); if Ec ^= 0 then return; call validate_access (Out_dname, Out_ename, Fs_util_type, RW_ACCESS, Overwrite_exist_path_flag); if Ec ^= 0 then return; if ^Overwrite_exist_path_flag then return; end; /* the specified path2 exists and its type is either directory or MSF */ else do; call com_err_ (Ec, ME, "^a", pathname_ (Out_dname, Out_ename)); return; end; end; /* an error occured while initiating the specified output path2 */ if ^Overwrite_exist_path_flag & ^Nonexistent_outfile_flag then do; /* assume had no problem when initiated the specified EXISTENT output path2 */ call command_query_$yes_no (Overwrite_exist_path_flag, (0), ME, "", "Do you want to overwrite ^a?", pathname_ (Out_dname, Out_ename)); if ^Overwrite_exist_path_flag then return; Fs_util_type = FS_OBJECT_TYPE_SEGMENT; end; return; end initiate_specified_output_file; /* --------------------------------------------------------------------------- */ %page; temp_seg_to_temp_msf: proc; /* copies the contents of Temp_seg into the next component of the temp MSF. */ /* This is done by calling the internal procedure named */ /* copy_temp_seg_into_msf. Then calls msf_manager_$adjust to set */ /* the bit count, truncate, and terminate that component. */ /* begin temp_seg_to_temp_msf procedure */ if Temp_msf_total_components > 0 then do; /* prepare to create another component in the temp MSF */ Temp_msf_comp_index = Temp_msf_total_components; Temp_msf_total_components = Temp_msf_total_components + 1; end; /* copy the contents of Temp_seg into a specified component of a temp. MSF */ call copy_temp_seg_into_msf (Temp_dn, Temp_en, Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Temp_msf_total_components); if Ec ^= 0 then do; /* close temp MSF */ call msf_manager_$close (Temp_msf_fcb_ptr); return; end; /* sets the bit count, truncates and terminates the components of the temp. MSF */ call msf_manager_$adjust (Temp_msf_fcb_ptr, Temp_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec); if Ec ^= 0 then do; /* close temp MSF */ call msf_manager_$close (Temp_msf_fcb_ptr); call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a", Temp_msf_comp_index, pathname_ (Temp_dn, Temp_en)); return; end; return; end temp_seg_to_temp_msf; /* --------------------------------------------------------------------------- */ %page; temp_msf_to_infile_or_outfile: proc (p_dirname, p_enname); /* copy each component of a temp MSF into the corresponding component of */ /* either the input file path1 or a specified output file path2. */ /* If path2 was specified and does not exist, the call to */ /* msf_manager_$msf_get_ptr will create it as a MSF. */ /* input parameters */ dcl p_dirname char (*); dcl p_enname char (*); /* begin temp_msf_to_infile_or_outfile procedure */ Ec = 0; on record_quota_overflow begin; Ec = error_table_$rqover; call msf_manager_$close (Input_msf_fcb_ptr); call msf_manager_$close (Temp_msf_fcb_ptr); revert record_quota_overflow; goto temp_msf_ERROR_RETURN; end; Temp_seg_len = Temp_seg_len_in_chars; /* save the current length of Temp_seg */ Temp_seg_len_in_chars = CHARS_PER_SEGMENT; /* prepare to copy full components (whose length has reached the max */ /* component length) of a temp MSF */ do Temp_msf_comp_index = COMPONENT_ZERO to (Temp_msf_total_components - 1); /* prepare to create a specified component */ Input_msf_comp_index = Temp_msf_comp_index; /* create a specified component if it does not exist yet */ call msf_manager_$msf_get_ptr (Input_msf_fcb_ptr, Input_msf_comp_index, TRUE, Input_msf_comp_ptr, In_msf_comp_bitc, Ec); if Ec ^= 0 then do; call msf_manager_$close (Input_msf_fcb_ptr); call msf_manager_$close (Temp_msf_fcb_ptr); call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a", Input_msf_comp_index, pathname_ (p_dirname, p_enname)); return; end; /* get a specified component of the temp MSF */ call msf_manager_$msf_get_ptr (Temp_msf_fcb_ptr, Temp_msf_comp_index, FALSE, Temp_msf_comp_ptr, Temp_msf_comp_bitc, Ec); if Ec ^= 0 then do; call com_err_ (Ec, ME, "Cannot get component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (Temp_dn, Temp_en)); call msf_manager_$close (Input_msf_fcb_ptr); call msf_manager_$close (Temp_msf_fcb_ptr); return; end; /* have the last component of the temp MSF been reached */ if Temp_msf_comp_index = (Temp_msf_total_components - 1) then /* prepare to copy the last component of the temp MSF */ Temp_seg_len_in_chars = Temp_seg_len; /* copy the contents of each component of temp MSF into the corresponding */ /* component of either input file path1 or a specified output file path2 */ Input_msf_comp_ptr -> Temp_seg = Temp_msf_comp_ptr -> Temp_seg; end; /* complete copied one by one component */ /* sets bit count, truncates, and terminates the components of that file */ call msf_manager_$adjust (Input_msf_fcb_ptr, Input_msf_comp_index, Temp_msf_comp_bitc, THREE_BIT_SWITCH, Ec); if Ec ^= 0 then do; call msf_manager_$close (Input_msf_fcb_ptr); call msf_manager_$close (Temp_msf_fcb_ptr); call com_err_ (Ec, ME, "Cannot adjust component ^d of MSF ^a.", Input_msf_comp_index, pathname_ (p_dirname, p_enname)); return; end; temp_msf_ERROR_RETURN: return; end temp_msf_to_infile_or_outfile; /* --------------------------------------------------------------------------- */ %page; %include access_mode_values; %page; %include object_info; %page; %include system_constants; %page; %include terminate_file; %page; %include copy_flags; %page; %include suffix_info; end canonicalize;  compare.pl1 04/09/85 1514.1r w 04/08/85 1128.7 157014 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: off */ compare: proc; /* The compare command and active function compares two segments. Usage: compare pathA{|offsetA} pathB{|offsetB} {-control_args} Written 08/07/79 S. Herbst */ /* Added -inhibit_error, -no_inhibit_error, -short, -total 09/25/84 S. Herbst */ /* Changed to work on archive components 11/14/84 Steve Herbst */ /* Fixed compilation warning about star_entry_ptr 12/03/84 Steve Herbst */ /* Fixed equal convention broken by last installation 12/05/84 Steve Herbst */ /* Backed out change to use max length if bit count = 0 12/11/84 Steve Herbst */ /* Constants */ dcl ME char (32) int static options (constant) init ("compare"); dcl FORMAT (2) char (32) int static options (constant) init ("^4x^6o^2x^w", "^26x^6o^2x^w"); dcl STRING_FORMAT (2) char (32) int static options (constant) init ("^4x^a", "^26x^a"); dcl DOUBLE_FORMAT char (32) int static options (constant) init ("^4x^6o^2x^w^2x^6o^2x^w"); dcl SKIP (2) char (32) int static options (constant) init ("^9x|^4x--------", "^31x|^4x--------"); dcl DOUBLE_SKIP char (32) int static options (constant) init ("^9x|^4x--------^9x|^4x--------"); /* Based */ dcl word (0:max_len) bit (36) based; dcl area area based (area_ptr); /* Automatic */ dcl 1 info (1:2), 2 path char (194), 2 msf_component_name char (32), 2 (done_sw, msf_sw, noentry_sw) bit (1), 2 (ptr, entries_ptr, names_ptr) ptr, 2 (k, len, msf_count, msf_index, offset) fixed bin; dcl arg char (arg_len) based (arg_ptr); dcl return_arg char (return_len) varying based (return_ptr); dcl dn char (168); dcl (cn, cn1, en, en1, xcn, xen) char (32); dcl (bad_arg, bad_base) character (10) varying; dcl mask bit (36); dcl (af_sw, brief_sw, inhibit_error_sw, printed_header_sw, printed_component_header_sw, short_sw, totals_sw) bit (1); dcl (area_ptr, arg_ptr, return_ptr) ptr; dcl (arg_count, arg_len, block_len, col, common_len, dis_count) fixed bin; dcl (given_len, i, j, max_len, path_count, return_len, word_count) fixed bin; dcl max_length fixed bin (19); dcl bit_count fixed bin (24); dcl (code, octal_mask) fixed bin (35); /* External */ dcl error_table_$bad_conversion fixed binary (35) external static; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$dirseg fixed bin (35) ext; dcl error_table_$item_too_big fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$not_archive fixed bin (35) ext; /* Entries */ dcl complain entry variable options (variable); dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)); dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl ioa_ entry options (variable); dcl pathname_ entry (char(*), char(*)) returns(char(168)); dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (168)); dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl (addrel, divide, index, max, min, null, substr, sum, unspec) builtin; dcl cleanup condition; %page; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then do; af_sw = "0"b; complain = com_err_; end; else do; af_sw = "1"b; complain = active_fnc_err_; end; if arg_count < 2 then do; USAGE: if af_sw then call active_fnc_err_$suppress_name (0, ME, "Usage: [compare pathA{|offsetA} pathB{|offsetB} {-control_args}]"); else call com_err_$suppress_name (0, ME, "Usage: compare pathA{|offsetA} pathB{|offsetB} {-control_args}"); return; end; given_len, path_count = 0; mask = (36) "1"b; brief_sw, inhibit_error_sw, short_sw, totals_sw = "0"b; unspec (info) = "0"b; do i = 1 to 2; ptr (i), entries_ptr (i), names_ptr (i) = null; end; area_ptr = null; on condition (cleanup) call clean_up; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-brief" | arg = "-bf" then if af_sw then go to BADOPT; else brief_sw = "1"b; else if arg = "-inhibit_error" | arg = "-ihe" then if ^af_sw then go to BADOPT; else inhibit_error_sw = "1"b; else if arg = "-long" | arg = "-lg" then if af_sw then go to BADOPT; else brief_sw = "0"b; else if arg = "-length" | arg = "-ln" then do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call complain (0, ME, "No value specified for -length"); return; end; given_len = cv_oct_check_ (arg, code); bad_arg = "-length"; if code ^= 0 then do; BAD_OCTAL_NUM: bad_base = "an octal"; BAD_NUM: call complain (error_table_$bad_conversion, ME, "^a requires ^a number, not ^a.", bad_arg, bad_base, arg); return; end; if given_len <= 0 then do; bad_base = "a positive"; go to BAD_NUM; end; end; else if arg = "-mask" then do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call complain (0, ME, "No value specified for -mask"); return; end; octal_mask = cv_oct_check_ (arg, code); if code ^= 0 then do; bad_arg = "-mask"; go to BAD_OCTAL_NUM; end; mask = unspec (octal_mask); end; else if arg = "-no_inhibit_error" | arg = "-nihe" then if ^af_sw then go to BADOPT; else inhibit_error_sw = "0"b; else if arg = "-short" | arg = "-sh" then if af_sw then go to BADOPT; else short_sw = "1"b; else if arg = "-totals" | arg = "-total" | arg = "-tt" then if af_sw then go to BADOPT; else totals_sw = "1"b; else do; BADOPT: call complain (error_table_$badopt, ME, "^a", arg); return; end; else do; path_count = path_count + 1; if path_count > 2 then go to USAGE; call get_path (path_count); end; end; if path_count ^= 2 then go to USAGE; if noentry_sw (1) | noentry_sw (2) then do; if inhibit_error_sw then do; if noentry_sw (1) & noentry_sw (2) then do; call complain (error_table_$noentry, ME, "^/^5x^a^/^5x^a", path (1), path (2)); go to RETURN; end; else do; return_arg = "false"; /* note that -inhibit_error is only allowed with active function */ go to RETURN; end; end; else do; if noentry_sw (1) then i = 1; else i = 2; call complain (error_table_$noentry, ME, "^a", path (i)); go to RETURN; end; end; if ptr (1) = ptr (2) & ^msf_sw (1) & offset (1) = offset (2) then do; call complain (0, ME, "Attempt to compare data with itself."); call clean_up; return; end; if min (len (1), len (2)) = 0 & af_sw then do; /* one or both zero length */ if len (1) = len (2) then return_arg = "true"; else return_arg = "false"; call clean_up; return; end; dis_count, word_count = 0; printed_header_sw = "0"b; if ^msf_sw (1) & ^msf_sw (2) then call print_discrepancies (); /* both are segments */ else do; if af_sw & msf_sw (1) ^= msf_sw (2) then do; return_arg = "false"; go to RETURN; end; do while (^done_sw (1) & ^done_sw (2)); call get_next_msf_component (1); call get_next_msf_component (2); printed_component_header_sw = "0"b; call print_discrepancies (); end; do i = 1 to 2; if ^done_sw (i) then do; dis_count = dis_count + 1; if ^af_sw then call ioa_ ("Remaining components of MSF ^a", path (i)); do while (^done_sw (i)); call get_next_msf_component (i); word_count = word_count + len (i); if ^af_sw then call ioa_ (STRING_FORMAT (i), get_msf_component_name (i)); end; end; end; end; /* Print totals */ if af_sw then do; return_arg = "true"; go to RETURN; end; if dis_count = 0 then call ioa_ ("No discrepancies."); else call ioa_ ("^/Total ^d discrepanc^[ies^;y^], ^d word^[s^]", dis_count, dis_count > 1, word_count, word_count > 1); RETURN: call clean_up; return; %page; clean_up: proc; dcl i fixed bin; do i = 1 to 2; if ptr (i) ^= null then call terminate_file_ (ptr (i), 0, TERM_FILE_TERM, code); if entries_ptr (i) ^= null then free entries_ptr (i) -> star_entries in (area); if names_ptr (i) ^= null then free names_ptr (i) -> star_names in (area); end; end clean_up; %page; get_msf_component_name: proc (P_i) returns (char (64)); /* Returns either "Segment" or "Component " */ dcl P_i fixed bin; if ^msf_sw (P_i) then return ("Segment"); else return ("Component " || msf_component_name (P_i)); end get_msf_component_name; %page; get_next_msf_component: proc (P_i); /* Positions to next component of an MSF, turns on done_sw (P_i) if the last one. */ /* For a segment, just turns on done_sw (P_i). */ dcl P_i fixed bin; if ^msf_sw (P_i) then done_sw (P_i) = "1"b; else do; msf_index (P_i) = min (msf_index (P_i) + 1, msf_count (P_i)); if msf_index (P_i) = msf_count (P_i) then done_sw (P_i) = "1"b; msf_component_name (P_i) = names_ptr (P_i) -> star_names (entries_ptr (P_i) -> star_entries (msf_index (P_i)).nindex); call initiate_file_ (path (P_i), msf_component_name (P_i), R_ACCESS, ptr (P_i), bit_count, code); if code ^= 0 then do; call complain (code, ME, "MSF component ^a", pathname_ (path (P_i), msf_component_name (P_i))); go to RETURN; end; len (P_i) = divide (bit_count + 35, 36, 17, 0); end; end get_next_msf_component; %page; get_path: proc (P_i); dcl P_i fixed bin; j = index (arg, "|"); if j = arg_len then do; /* no offset after "|" */ BAD_OFFSET: call complain (code, ME, "Invalid offset in ^a", arg); goto RETURN; end; if j ^= 0 then do; offset (P_i) = cv_oct_check_ (substr (arg, j + 1), code); if code ^= 0 then do; code = error_table_$bad_conversion; goto BAD_OFFSET; end; arg_len = j - 1; end; call expand_pathname_$component (arg, dn, en, cn, code); if code ^= 0 & code ^= error_table_$not_archive then do; call complain (code, ME, "^a", arg); go to RETURN; end; if P_i = 2 then do; call get_equal_name_$component (en1, cn1, en, cn, xen, xcn, code); if code ^= 0 then do; call complain (code, ME, "^a^[::^a^] applied to ^a^[::^a^]", en, cn ^= "", cn, en1, cn1 ^= "", cn1); go to RETURN; end; en = xen; cn = xcn; end; else do; en1 = en; /* save for 2nd time through */ cn1 = cn; end; path (P_i) = pathname_$component (dn, en, cn); /* for an error message if needed */ if cn ^= "" then call initiate_file_$component (dn, en, cn, R_ACCESS, ptr (P_i), bit_count, code); else call initiate_file_ (dn, en, R_ACCESS, ptr (P_i), bit_count, code); if ptr (P_i) = null then do; if code = error_table_$dirseg then do; bit_count = 0; call hcs_$status_minf (dn, en, 1, 0, bit_count, 0); if bit_count ^= 0 then do; /* MSF */ if offset (P_i) ^= 0 then do; call complain (0, ME, "Nonzero offset not allowed for MSF ^a", pathname_ (dn, en)); go to RETURN; end; msf_sw (P_i) = "1"b; if area_ptr = null then area_ptr = get_system_free_area_ (); call hcs_$star_ (pathname_ (dn, en), "**", star_BRANCHES_ONLY, area_ptr, star_entry_count, star_entry_ptr, star_names_ptr, code); if code ^= 0 then do; if code = error_table_$nomatch then call complain (0, ME, "Invalid MSF ^a", pathname_ (dn, en)); else call complain (code, ME, "^a", pathname_ (dn, en)); go to RETURN; end; entries_ptr (P_i) = star_entry_ptr; names_ptr (P_i) = star_names_ptr; msf_count (P_i) = star_entry_count; msf_index (P_i) = 0; len (P_i) = 1; /* ie., not zero length */ return; end; end; else if code = error_table_$noentry then do; noentry_sw (P_i) = "1"b; return; /* catch this later */ end; else call complain (code, ME, "^a", path (P_i)); go to RETURN; end; len (P_i) = divide (bit_count + 35, 36, 17, 0); if offset (P_i) > len (P_i) then do; call complain (error_table_$item_too_big, ME," Base-zero offset ^d greater than length ^d", offset (P_i), len (P_i)); go to RETURN; end; end get_path; %page; print_discrepancies: proc; max_len = max (len (1), len (2)); common_len = min (len (1) - offset (1), len (2) - offset (2)); if given_len ^= 0 then do; max_len = min (max_len, offset (1) + given_len, offset (2) + given_len); common_len = min (common_len, given_len); end; k (1) = offset (1); k (2) = offset (2); block_len = 0; do i = 1 to common_len; do i = i to common_len while ((mask & ptr (1) -> word (k (1) + block_len)) ^= (mask & ptr (2) -> word (k (2) + block_len))); block_len = block_len + 1; end; if block_len > 0 then do; /* block of discrepancies */ if af_sw then do; return_arg = "false"; go to RETURN; end; if ^printed_header_sw then call print_header; if ^printed_component_header_sw then do; printed_component_header_sw = "1"b; if (msf_sw (1) | msf_sw (2)) & ^totals_sw then call ioa_ ("^a / ^a:", get_msf_component_name (1), get_msf_component_name (2)); end; dis_count = dis_count + 1; word_count = word_count + block_len; if short_sw | totals_sw then do; if ^totals_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o", block_len, block_len > 1, k (1)); k (1) = k (1) + block_len; k (2) = k (2) + block_len; end; else if block_len > 3 & brief_sw then do; call ioa_ (DOUBLE_FORMAT, k (1), ptr (1) -> word (k (1)), k (2), ptr (2) -> word (k (2))); call ioa_ (DOUBLE_SKIP); k (1) = k (1) + block_len; /* skip block */ k (2) = k (2) + block_len; call ioa_ (DOUBLE_FORMAT, k (1) - 1, ptr (1) -> word (k (1) - 1), k (2) - 1, ptr (2) -> word (k (2) - 1)); end; else do; do j = 1 to block_len; call ioa_ (DOUBLE_FORMAT, k (1), ptr (1) -> word (k (1)), k (2), ptr (2) -> word (k (2))); k (1) = k (1) + 1; /* skip block */ k (2) = k (2) + 1; end; end; if i <= common_len then do; /* skip matching word ending the block */ k (1) = k (1) + 1; k (2) = k (2) + 1; end; block_len = 0; end; else do; /* no discrepancy, skip 1 matching word */ k (1) = k (1) + 1; k (2) = k (2) + 1; end; end; if max_len > max (k (1), k (2)) then do; /* print remaining words of longer seg */ if af_sw then do; return_arg = "false"; go to RETURN; end; if ^printed_header_sw then call print_header; if min (len (1), len (2)) = 0 then dis_count = dis_count + 1; else if (mask & ptr (1) -> word (k (1) - 1)) = (mask & ptr (2) -> word (k (2) - 1)) then dis_count = dis_count + 1; /* not continuation of previous discrepancy */ if len (1) > len (2) then col = 1; else col = 2; block_len = max_len - k (col); word_count = word_count + block_len; if totals_sw then; else if short_sw then call ioa_ ("^5d word^[s^; ^] at: ^6o (file ^d)", block_len, block_len > 1, k (col), col); else if block_len > 3 & brief_sw then do; call ioa_ (FORMAT (col), k (col), ptr (col) -> word (k (col))); call ioa_ (SKIP (col)); call ioa_ (FORMAT (col), max_len - 1, ptr (col) -> word (max_len - 1)); end; else do j = k (col) to max_len - 1; call ioa_ (FORMAT (col), j, ptr (col) -> word (j)); end; end; end print_discrepancies; %page; print_header: proc; printed_header_sw = "1"b; if short_sw | totals_sw then return; call ioa_ ("Discrepancies:"); call ioa_ ("^4xoffset^4xcontents^4xoffset^4xcontents"); end print_header; %page; %include access_mode_values; %page; %include star_structures; %page; %include terminate_file; end compare;  convert_characters.pl1 11/04/82 1951.6rew 11/04/82 1627.6 114309 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ convert_characters: cvc: proc; /* procedure to convert a predefined set of characters in a segment to a different set */ /* Originally coded by E. Franklin Recode for SSS by R. Mullen */ dcl unique_chars_ entry (bit (*)) returns (char (15)); /* to make tempname */ dcl establish_cleanup_proc_ entry (entry); /* remember to cleanup */ dcl ioa_ ext entry options (variable); /* input output ascii */ dcl com_err_ ext entry options (variable); dcl cu_$arg_count ext entry (fixed bin); dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$terminate_noname ext entry (ptr, fixed bin (35)); dcl hcs_$initiate_count ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (12), ptr, fixed bin (35)); dcl hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, ptr, fixed bin (35)); dcl hcs_$fs_move_seg entry (ptr, ptr, fixed bin (1), fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl (inptr, tempptr, outptr) ptr init (null); /* point to segs to be dealt with */ dcl fs_flag bit (1) aligned init ("0"b); /* 1 => setting from_string */ dcl string char (charnum) based; dcl (bcd_flag, dart_flag, uc_flag, lc_flag, mult_flag, sp_flag) bit (1) unaligned init ("0"b); dcl ts_flag bit (1) aligned init ("0"b); /* 1 => setting to_string */ dcl procname char (18) aligned init ("convert_characters"); dcl tempname char (24) aligned; /* name of seg in process dir */ dcl max_nargs fixed bin init (3); /* will be set to two for some entrys */ dcl (from_string, to_string) char (128) varying aligned init (""); /* define the conversion */ dcl (static_from_string, static_to_string) char (128) varying aligned /* define the default conversion */ internal static init (""); dcl (code, bcode) fixed bin (35); /* status codes */ dcl (error_table_$action_not_performed, /* to make sure user knows */ error_table_$noarg, error_table_$too_many_args) fixed bin (35) external static; dcl argptr pointer; /* will point to last arg picked up */ dcl (arglen, nargs) fixed bin (17); dcl aa char (4) aligned; /* aligned arg */ dcl argbuf char (arglen) based (argptr); /* the last arg picked up */ dcl dir char (168) aligned; /* dirname for last patharg picked up */ dcl entry char (32) aligned; /* ename for same */ dcl btcnt fixed bin (24); /* bit count */ dcl (i, j) fixed bin (24); dcl charnum fixed bin (24); /* num of chars in seg being converted */ dcl (addr, addrel, divide, length, min, null, ptr, substr, translate) builtin; /* pawns */ /* This entry converts from one user specified string to another */ call cu_$arg_count (nargs); call cu_$arg_ptr (1, argptr, arglen, code); if code ^= 0 then go to error; aa = argbuf; if aa = "sp" then go to special; else if aa = "bcd" then go to convert_bcd; else if aa = "dart" then go to convert_dartmouth; else if aa = "mp" then go to convert_multics_pl1; else if aa = "uc" then go to convert_upper_case; else if aa = "lc" then go to convert_lower_case; else if aa = "to" then go to convert_to; else if aa = "from" then go to convert_from; else do; call com_err_ (0, procname, "Unrecognized key - ^a", argptr -> argbuf); return; end; special: sp_flag = "1"b; from_string = static_from_string; /* it uses internal static strings */ to_string = static_to_string; /* to define the conversion */ if nargs = 1 then go to print_strings; /* no problem even if int static strings were not set */ if static_from_string = "" then if static_to_string = "" then do; /* complain */ code = error_table_$action_not_performed; call com_err_ (code, procname, "^/First use convert_from and convert_to to specify conversion."); return; end; go to got_nargs; /* if one string is "" then the strings will be unequal below */ /* This entry converts bcd special characters to corresponding ascii/ebcdic ones */ convert_bcd: bcd_flag = "1"b; from_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ%<#&"; to_string = "abcdefghijklmnopqrstuvwxyz()=+"; go to start; convert_dartmouth: dart_flag = "1"b; from_string = "^_>+='{""?"; to_string = "'=""<>:+?!"; go to start; /* This entry converts all lower case letters to upper case */ convert_upper_case: uc_flag = "1"b; from_string = "abcdefghijklmnopqrstuvwxyz"; to_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; go to start; /* This entry converts all upper case letters to lower case. */ convert_lower_case: lc_flag = "1"b; from_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; to_string = "abcdefghijklmnopqrstuvwxyz"; go to start; /* This entry converts from multics pl1 format to 360 pl1 format */ convert_multics_pl1: mult_flag = "1"b; from_string = "abcdefghijklmnopqrstuvwxyz """; to_string = "ABCDEFGHIJKLMNOPQRSTUVWXYZ '"; go to start; /* The above entries all have max_nargs set to 3. If no nore args are given the appropriate from_string and to_string will be printed. If one or two more args are given the first is the pathname of the segment to be converted. If one more arg is given the converted copy will replace the original. If two more args are given then the converted copy will be placed in arg2. The entries below set max_nargs to 2. Only one more arg may be given, either the from_string or the to_string. */ /* This entry causes from string to be reset */ convert_from: fs_flag = "1"b; max_nargs = 2;go to start; /* This entry causes to string to be reset */ convert_to: ts_flag = "1"b; max_nargs = 2;go to start; /* The body of the command starts here. */ start: /* all keys come here except "sp" */ if nargs = 1 then do; if max_nargs = 3 then go to print_strings; /* automatic copies have been set */ else do; /* should have gotten a string to set */ code = error_table_$noarg; /* set up status code */ error: call com_err_ (code, procname); /* come here if nothing to say besides code */ go to RETURN; /* go through cleanup */ end; end; got_nargs: if nargs > max_nargs then do; /* here if nargs ^= 0 */ code = error_table_$too_many_args; /* set status code */ go to error; /* and print a simple message */ end; call cu_$arg_ptr (2, argptr, arglen, code); /* get ptr to arg we know is there */ if code ^= 0 then go to error; /* suprise */ if max_nargs = 2 then do; /* setting a string */ if arglen > 128 then do; /* cmust not be too long */ call com_err_ (0, procname, "The string length (^d) exceeds 128 characters.", arglen); return; /* nothing to clean up */ end; if fs_flag then static_from_string = argbuf; /* copy arg to proper */ else if ts_flag then static_to_string = argbuf; /* internal static string */ return; /* and just return */ end; if sp_flag & length (from_string) ^= length (to_string) then do; /* be sensible */ code = error_table_$action_not_performed; /* let user know nothing happened */ call com_err_ (code, procname, "^/Length of from_string (^d) is not equal to length of to_string (^d).", length (from_string), length (to_string)); /* give useful information */ return; /* and give up */ end; call expand_path_ (argptr, arglen, addr (dir), addr (entry), code); /* get absolute pathname */ if code ^= 0 then do; /* can't */ error_tell_arg: call com_err_ (code, procname, argptr -> argbuf); /* here to tell user which arg loses */ go to RETURN; /* go through cleanup */ end; call establish_cleanup_proc_ (cleanup); /* dont leave a mess in any case */ call hcs_$initiate_count (dir, entry, "", btcnt, 1, inptr, code); /* get ptr to seg to be converted */ if inptr = null then do; /* could not initiate if */ error_tell_dirent: call com_err_ (code, procname, "^a>^a", dir, entry); /* here to tell losing pathname */ go to RETURN; /* go though cleanup */ end; charnum = divide (btcnt+8, 9, 24, 0); /* compute number of characters */ tempname = "cvc_temp." || unique_chars_ ("0"b); /* name for temp seg is reasonable & unique */ call hcs_$make_seg ("", tempname, "", 1011b, tempptr, code); /* create a temporary seg */ if tempptr = null then do; /* could not create it */ call com_err_ (code, procname, /* tell user what happened */ "Unable to create ^a in process directory.", tempname); /* and why */ go to RETURN; /* go through cleanup */ end; if nargs = 3 then do; /* don't write back into original seg */ call cu_$arg_ptr (3, argptr, arglen, code); /* get name of output seg */ if code ^= 0 then go to error; /* give simple message and return */ call expand_path_ (argptr, arglen, addr (dir), addr (entry), code); /* convert arg to abs path */ if code ^= 0 then go to error_tell_arg; /* print errmessage, which arg lost, and return */ call hcs_$make_seg (dir, entry, "", 1011b, outptr, code); /* create output seg if does not exist */ if outptr = null then go to error_tell_dirent; /* tell dir and entry since we know which */ end; else outptr = inptr; /* modify original seg */ /* Here we do conversion. to take advantage of EIS we convert large blocks at a time. To take advantage of the MVT instruction we must use constants in the translate builtin. */ do j = 1 to charnum by 16384; i = min (16384, charnum-j+1); if bcd_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz()=+", "ABCDEFGHIJKLMNOPQRSTUVWXYZ%<#&"); else if dart_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), "^_>+='{""?", "'=""<>:+?!"); else if lc_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz", "ABCDEFGHIJKLMNOPQRSTUVWXYZ"); else if uc_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), "ABCDEFGHIJKLMNOPQRSTUVWXYZ", "abcdefghijklmnopqrstuvwxyz"); else if mult_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), "abcdefghijklmnopqrstuvwxyz """, "ABCDEFGHIJKLMNOPQRSTUVWXYZ '"); else if sp_flag then substr (tempptr -> string, 1, i) = translate (substr (inptr -> string, 1, i), to_string, from_string); tempptr = addrel (tempptr, 4096); inptr = addrel (inptr, 4096); end; call hcs_$set_bc_seg (tempptr, 9*charnum, bcode); /* in case of trouble later */ tempptr = ptr (tempptr, 0); call hcs_$fs_move_seg (tempptr, outptr, 1, code); /* truncate out seg, copy temp, trunc temp */ if code ^= 0 then do; /* somehow failed */ tempptr = null; /* so we won't delete temp */ call com_err_ (code, procname, "^/Converted copy ^a is in process directory.", tempname); /* tell user all is not lost */ if bcode ^= 0 then call com_err_ (bcode, procname, tempname); /* warn if bcnt not set on temp */ go to RETURN; /* cleanup and leave */ end; if outptr ^= inptr then do; /* if same following steps not needed */ call hcs_$set_bc_seg (outptr, 9*charnum, code); /* set btcnt on output seg */ if code ^= 0 then go to error_tell_dirent; /* could not set btcnt, tell user the segments name */ end; RETURN: /* come here to exit if anything to cleanup */ call cleanup; /* use handy internal proc */ return; /* now we can return */ print_strings: /* here to print strings */ call ioa_ ("From string = ""^a""", from_string); /* first one */ call ioa_ (" To string = ""^a""^/", to_string); /* then other */ return; /* and all is done */ /* --------------------------------------------------------------------------- */ cleanup: proc; if tempptr ^= null then call hcs_$delentry_seg (tempptr, code); /* delete temp seg */ if outptr ^= null then if inptr ^= outptr then call hcs_$terminate_noname (outptr, code); if inptr ^= null then call hcs_$terminate_noname (inptr, code); /* & terminate others */ end cleanup; end convert_characters;  dump_segment.pl1 01/12/88 1305.7rew 01/12/88 1245.0 696249 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ dump_segment: ds: proc; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This command dumps the contents of a segment in octal, hex8, or hex9 with */ /* optional ascii, bcd, ebcdic9, ebcdic8, or 4-bit translation. The segment */ /* to be dumped may be specified by octal segment number, SLT name, */ /* (relative) pathname. */ /* */ /* Usage: */ /* */ /* dump_segment seg start count -control_args */ /* or: */ /* dump_segment virtual_pointer count -control_args */ /* */ /* where: */ /* */ /* seg is the segment to dump */ /* start is the first word to dump */ /* count is the number of words to dump */ /* virtual_pointer is a pointer understood by cv_ptr_ */ /* */ /* and control args can be: */ /* */ /* -long (-lg) */ /* -short (-sh) */ /* -character (-ch, -ascii) */ /* -bcd */ /* -ebcdic9 */ /* -ebcdic8 */ /* -4bit */ /* -name (-nm) path */ /* -hex8 */ /* -hex9 */ /* -block (-bk) N */ /* -address (-addr) */ /* -no_address (-nad, -naddr) */ /* -offset (-ofs) N */ /* -no_offset (-nofs) */ /* -header (-he) */ /* -no_header (-nhe) */ /* -entry_point (-ep) name */ /* -interpreted_data (-id) */ /* -no_interpreted_data (-nid) */ /* -raw_data (-rd) */ /* -no_raw_data (-nrd) */ /* -suppress_duplicates (-sd) */ /* -no_suppress_duplicates (nsd) */ /* -rest */ /* -as structure_name */ /* -in pathname */ /* */ /* Defaults for use as a command: */ /* -no_offset, -raw_data, -no_interpreted_data, -suppress_duplicates */ /* Defaults for use as an active function: */ /* -no_header, -no_address, -no_offset, -raw_data, -no_interpreted_data */ /* -no_suppress_duplicates */ /* */ /* Last modified (date and reason): */ /* 5/15/75 by S.Webber Initial coding (discarding earlier code) */ /* 11/15/75 by S.Webber to add -address, -offset, -header, and */ /* -block control args */ /* 04/27/76 by T. Casey to fix "-block N -offset" to reset offset */ /* for each block, to make -name N work right, */ /* to accept control argument abbreviations */ /* -addr and -bk, and clean up code and fix */ /* minor obscure bugs. */ /* 10/18/76 by R.Kissel to add -ebcdic9, -ebcdic8, -4bit, -hex8, */ /* hex9 to clean up code, and to change */ /* the output format. */ /* 02/16/77 by R.Kissel to add the dump_segment_ subroutine entry */ /* point. */ /* 01/16/79 by R.J.C. Kissel to fix error message bug. */ /* 06/22/79 by S. Herbst to fix error message for MSF's. */ /* 04/04/81 by W. Olin Sibert, to use */ /* ring_zero_peek_$get_max_length_ptr */ /* instead of depending on SDW format. */ /* 11/03/81 by J. Bongiovanni for -entry_point */ /* 09/26/83 by C. Spitzer */ /* phx07028 return more than 1 word if invoked as AF. */ /* phx07253 add -raw_data -interpreted_data and complements */ /* phx08128 use current length instead of max length. */ /* phx10338,phx12336 bugfix to print et_$dirseg for */ /* directories. */ /* phx08905 make -lg -hex9 -ch work together. */ /* phx14729 correct display for -hex8 and hex9 format. */ /* suggestion: add -suppress_duplicates and complement */ /* format. */ /* bug: diagnose illegal CAs when used as active function. */ /* bug: correct display for -ch and incompletely filled line*/ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /****^ HISTORY COMMENTS: 1) change(85-12-17,Spitzer), approve(85-12-17,MCR7119), audit(86-01-20,Lippard), install(86-01-29,MR12.0-1009): Make -ep work same as octal offsets. Allow rzd dump stack_0. Add -rest CA. 2) change(85-12-17,Spitzer), approve(85-12-17,MCR7268), audit(86-01-20,Lippard), install(86-01-29,MR12.0-1009): Allow virtual pointers as input. 3) change(86-07-30,Kissel), approve(86-07-30,MCR7476), audit(86-08-01,Ex), install(86-08-19,MR12.0-1132): Changed to call translate_bytes_to_hex9_, which is the new name for translate_to_hex9. 4) change(87-01-02,TLNguyen), approve(87-01-02,MCR7596), audit(87-01-16,GWMay), install(87-03-19,MR12.1-1004): Fixed the "dump_segment" active function to strip trailing spaces. 5) change(87-11-26,GDixon), approve(88-01-05,MCR7817), audit(88-01-06,Farley), install(88-01-12,MR12.2-1012): A) Add -as and -in to display data as a structure. END HISTORY COMMENTS */ %page; /* Automatic */ dcl active_func bit (1) aligned; dcl arg_for_header_given bit (1); dcl argc fixed bin; dcl bit_count fixed bin (24); dcl block fixed bin (18); dcl buffer (64) fixed bin; dcl code fixed bin (35); dcl count fixed bin (18); dcl cur_length fixed bin (18); dcl defn_ptr ptr; dcl dir_len fixed bin; dcl dirname char (168); dcl ename char (32); dcl entry_point_name char (32); dcl entry_point_offset fixed bin (18); dcl entry_type fixed bin; dcl entry_var entry variable options (variable); dcl first fixed bin (18); dcl have_count bit (1); dcl have_entry_point bit (1); dcl have_first bit (1); dcl have_name bit (1); dcl have_structure bit (1); dcl have_structure_path bit (1); dcl hcsp (1) ptr; dcl hc_seg bit (1); dcl highseg fixed bin; dcl i fixed bin; dcl initsw bit (1); dcl iocbp ptr; dcl line_format char (28) var; dcl max_length fixed bin (19); dcl 1 obj_info aligned like object_info; dcl p ptr; /* pointer to the segment we are dumping */ dcl rel_offset fixed bin (18); dcl rest bit (1) aligned; dcl ret_tc fixed bin (21); dcl ret_tp ptr; dcl output_line_len fixed bin (21); dcl output_line char (256); dcl rz_call bit (1); dcl rb2 bit (6); /* third ring bracket number */ dcl segno fixed bin (18); dcl seg_num bit (1); dcl structure_name char(256) varying; /* name of structure to dump. */ dcl structure_path char(168); /* pathname of object pgm compiled with -table */ dcl tc fixed bin; /* count of chars in command_arg */ dcl tca fixed bin; /* count of chars in seg_name */ dcl tp ptr; /* pointer to command_arg */ dcl tpa ptr; /* pointer to seg_name */ /* Format control flags */ %include dump_segment_format; dcl address_fmt bit (1) defined (dump_segment_format) pos (1); dcl offset_fmt bit (1) defined (dump_segment_format) pos (2); dcl short_fmt bit (1) defined (dump_segment_format) pos (3); dcl bcd_fmt bit (1) defined (dump_segment_format) pos (4); dcl char_fmt bit (1) defined (dump_segment_format) pos (5); dcl long_fmt bit (1) defined (dump_segment_format) pos (6); dcl ebcdic9_fmt bit (1) defined (dump_segment_format) pos (7); dcl ebcdic8_fmt bit (1) defined (dump_segment_format) pos (8); dcl bit4_fmt bit (1) defined (dump_segment_format) pos (9); dcl hex8_fmt bit (1) defined (dump_segment_format) pos (10); dcl hex9_fmt bit (1) defined (dump_segment_format) pos (11); dcl octal_fmt bit (1) defined (dump_segment_format) pos (12); dcl header bit (1) defined (dump_segment_format) pos (13); dcl raw_data_fmt bit (1) defined (dump_segment_format) pos (14); dcl interpreted_data_fmt bit (1) defined (dump_segment_format) pos (15); dcl suppress_dup_fmt bit (1) defined (dump_segment_format) pos (16); dcl command_output_fmt bit (1) defined (dump_segment_format) pos (17); /* Based */ dcl command_arg char (tc) based (tp); dcl seg_name char (tca) based (tpa); dcl return_arg char (ret_tc) based (ret_tp) var; /* Conditions */ dcl linkage_error condition; dcl cleanup condition; dcl not_in_read_bracket condition; /* Static */ dcl dots char (33) aligned internal static options (constant) init ((33)"."); dcl first_time bit (1) static init ("1"b); dcl nonprinting_chars char (33) aligned internal static; dcl com_err_fmt (25) char (80) var options (constant) static init ("", "^a", "^s^a>^a", "Nonoctal number: ^a", "name/no of segment", "Hardcore segment won't be dumped.", "block size for dumping", "Zero is illegal for count", "First word is ^4s^o, max_length is only ^o", "No control arguments specified to dump any data.", "Control arguments were specified to dump both raw and interpreted data.", "-hex8 and -hex9.", "entry_point name", "^2s^a$^a", "^1s^a>^a$^a", "word count and -entry_point", "Nonpositive octal number: ^a", "Attempt to dump before the beginning of the referenced segment.", "Count argument and -rest.", "-as must be followed by a structure name.", "-in must be followed by path of object segment.", "-as not allowed with active function.", "Parsing structure ^6s^a.", "Searching for structure ^6s^a in ^[^a^;library^].", "Displaying structure ^6s^a."); dcl active_all_rings_data_$stack_base_segno fixed bin (35) ext static; dcl hcscnt fixed bin static; dcl NL char (1) int static options (constant) init (" "); dcl me (0:1) char (14) internal static options (constant) init ("dump_segment", "ring_zero_dump"); /* External */ dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$dirseg fixed bin (35) ext; dcl error_table_$inconsistent fixed bin(35) ext static; dcl error_table_$lower_ring fixed bin (35) ext; dcl error_table_$msf fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin (35) ext; dcl error_table_$noarg fixed bin (35) ext; dcl error_table_$too_many_args fixed bin (35) ext; dcl iox_$user_output ptr ext; /* Builtin */ dcl (addr, addrel, baseno, baseptr, binary, clock, collate, divide, fixed, index, length, min, mod, null, rel, ptr, reverse, rtrim, search, substr, string, translate, wordno, unspec, verify) builtin; /* Entries */ dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl phcs_$initiate entry (char (*), char (*), char (*), fixed bin, fixed bin, ptr, fixed bin (35)); dcl requote_string_ entry (char(*)) returns(char(*)); dcl (ioa_$ioa_switch, com_err_, active_fnc_err_) entry options (variable); dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)); dcl hcs_$high_low_seg_count entry (fixed bin, fixed bin); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl ring0_get_$segptr entry (char (*), char (*), ptr, fixed bin (35)); dcl ring0_get_$definition entry (ptr, char (*), char (*), fixed bin (18), fixed bin, fixed bin (35)); dcl ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); dcl ring_zero_peek_ entry (ptr, ptr, fixed bin (18), fixed bin (35)); dcl ring_zero_peek_$get_max_length_ptr entry (ptr, fixed bin (19), fixed bin (35)); dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)); dcl (ioa_$rs, ioa_$rsnnl) entry options (variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl translate_bytes_to_hex9_ entry (bit (*), char (*)); dcl get_ring_ entry returns (fixed bin (3)); dcl get_definition_ entry (ptr, char (*), char (*), ptr, fixed bin (35)); dcl object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)); dcl display_data_$for_azm entry (ptr, bit(*) aligned, (*) char(*) var, fixed bin, ptr, ptr, fixed bin(18), ptr, ptr, (2,*) fixed bin(24), fixed bin, fixed bin(35)); dcl structure_find_$pathname entry (char(*), char(*), ptr, fixed bin(35)); dcl structure_find_$search entry (char(*), ptr, fixed bin(35)); dcl structure_ref_$parse entry (char(*), char(*), char(*), (2,*) fixed bin(24), fixed bin, (*) char(*) var, fixed bin, fixed bin(35)); %page; rz_call = "0"b; goto COMMON_CODE; /* dump_segment entry */ ring_zero_dump: rzd: entry; rz_call = "1"b; /* indicate it is legal to dump ring 0 segs */ COMMON_CODE: if first_time then do; /* only once get segment number of last hardcore segment */ call hcs_$high_low_seg_count (highseg, hcscnt); /* so we can know if the given seg is hardcore or not */ nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1); first_time = "0"b; end; /* Initialize */ string (dump_segment_format) = ""b; /* initialize all the format flags to 0 */ iocbp = iox_$user_output; have_name, seg_num, have_first, have_count, have_entry_point, have_structure, have_structure_path, initsw, arg_for_header_given, hc_seg = "0"b; rest = "0"b; rel_offset = 0; entry_point_offset = 0; block = 0; max_length = 0; hcsp (1) = null; tp = null; tc = 0; call cu_$af_return_arg (argc, ret_tp, ret_tc, code); /* see if active function, also get return string info */ if code = 0 then do; active_func = "1"b; /* active function call */ raw_data_fmt = "1"b; return_arg = ""; end; else do; active_func = "0"b; /* command call */ address_fmt, raw_data_fmt, suppress_dup_fmt = "1"b; end; if argc = 0 then call PRINT_ERROR (error_table_$noarg, 5); /* need at least a segment name */ on cleanup call cleaner_upper; /* Loop through all arguments setting flags and variables */ do i = 1 to argc; call get_arg_ptr (i); /* get pointer and length of i'th arg */ if index (command_arg, "-") = 1 then do; /* process control arguments */ if (command_arg = "-long" | command_arg = "-lg") & ^active_func then do; long_fmt = "1"b; short_fmt = "0"b; end; else if (command_arg = "-suppress_duplicates" | command_arg = "-sd") & ^active_func then suppress_dup_fmt = "1"b; else if command_arg = "-no_suppress_duplicates" | command_arg = "-nsd" then suppress_dup_fmt = "0"b; else if command_arg = "-raw" then raw_data_fmt = "1"b; else if command_arg = "-no_raw" | command_arg = "-nraw" then raw_data_fmt = "0"b; else if command_arg = "-rest" then rest = "1"b; else if command_arg = "-interpreted" | command_arg = "-it" then interpreted_data_fmt = "1"b; else if command_arg = "-no_interpret" | command_arg = "-nit" then interpreted_data_fmt = "0"b; else if command_arg = "-character" | command_arg = "-ch" | command_arg = "-ascii" then do; char_fmt, interpreted_data_fmt = "1"b; bit4_fmt, ebcdic8_fmt, ebcdic9_fmt, bcd_fmt = "0"b; if active_func then raw_data_fmt = "0"b; end; else if command_arg = "-bcd" then do; bcd_fmt, interpreted_data_fmt = "1"b; char_fmt, bit4_fmt, ebcdic8_fmt, ebcdic9_fmt = "0"b; if active_func then raw_data_fmt = "0"b; end; else if command_arg = "-ebcdic9" then do; ebcdic9_fmt, interpreted_data_fmt = "1"b; char_fmt, bit4_fmt, ebcdic8_fmt = "0"b; if active_func then raw_data_fmt = "0"b; end; else if command_arg = "-ebcdic8" then do; ebcdic8_fmt, interpreted_data_fmt = "1"b; char_fmt, bit4_fmt, ebcdic9_fmt = "0"b; if active_func then raw_data_fmt = "0"b; end; else if command_arg = "-4bit" then do; bit4_fmt, interpreted_data_fmt = "1"b; char_fmt, ebcdic8_fmt, ebcdic9_fmt = "0"b; if active_func then raw_data_fmt = "0"b; end; else if command_arg = "-hex8" then do; hex8_fmt, raw_data_fmt = "1"b; hex9_fmt, octal_fmt = "0"b; if active_func then interpreted_data_fmt = "0"b; end; else if command_arg = "-hex9" then do; hex9_fmt, raw_data_fmt = "1"b; hex8_fmt, octal_fmt = "0"b; if active_func then interpreted_data_fmt = "0"b; end; else if command_arg = "-octal" | command_arg = "-oc" then do; octal_fmt, raw_data_fmt = "1"b; hex8_fmt, hex9_fmt = "0"b; if active_func then interpreted_data_fmt = "0"b; end; else if (command_arg = "-short" | command_arg = "-sh") & ^active_func then do; short_fmt = "1"b; long_fmt = "0"b; end; else if (command_arg = "-address" | command_arg = "-ad" | command_arg = "-addr") & ^active_func then address_fmt = "1"b; else if (command_arg = "-no_address" | command_arg = "-naddr" | command_arg = "-nad") & ^active_func then address_fmt = "0"b; else if (command_arg = "-offset" | command_arg = "-ofs") & ^active_func then do; offset_fmt = "1"b; if i < argc then do; call get_arg_ptr (i + 1); /* check next arg, if octal then use as offset */ rel_offset = cv_oct_check_ (command_arg, code); if code = 0 then i = i + 1;/* if octal, advance arg index past it */ else rel_offset = 0; /* else leave arg index alone and use default of zero */ end; end; else if (command_arg = "-no_offset" | command_arg = "-nofs") & ^active_func then offset_fmt = "0"b; else if (command_arg = "-header" | command_arg = "-he") & ^active_func then header = "1"b; else if (command_arg = "-no_header" | command_arg = "-nhe") & ^active_func then do; header = "0"b; arg_for_header_given = "1"b; end; else if (command_arg = "-block" | command_arg = "-bk") & ^active_func then do; if i < argc then do; /* next argument is the block size */ call get_arg_ptr (i + 1); block = cv_oct_check_ (command_arg, code); if code = 0 then i = i + 1; else call PRINT_ERROR (0, 4); /* block size is non-octal */ end; /* next argument is the block size */ else call PRINT_ERROR (error_table_$noarg, 7); /* no argument given for the block size */ end; else if command_arg = "-name" | command_arg = "-nm" then do; if i < argc then do; /* next argument is the segment name */ call get_arg_ptr (i + 1); tca = tc; /* remember name of segment */ tpa = tp; /* in seg_name */ have_name = "1"b; i = i + 1; end; /* next argument is the segment name */ else call PRINT_ERROR (error_table_$noarg, 7); /* no argument given with -name */ end; else if command_arg = "-entry_point" | command_arg = "-ep" then do; if i < argc then do; call get_arg_ptr (i + 1); have_entry_point = "1"b; entry_point_name = command_arg; i = i + 1; end; else call PRINT_ERROR (error_table_$noarg, 13); end; else if command_arg = "-as" then do; if i < argc then do; have_structure = "1"b; call get_arg_ptr (i + 1); structure_name = command_arg; i = i + 1; end; else call PRINT_ERROR (error_table_$noarg, 20); end; else if command_arg = "-in" then do; if i < argc then do; have_structure_path = "1"b; call get_arg_ptr (i + 1); structure_path = command_arg; i = i + 1; end; else call PRINT_ERROR (error_table_$noarg, 21); end; else do; if verify (command_arg, "-0123456789") = 0 then goto NON_CONTROL_ARG; else call PRINT_ERROR (error_table_$badopt, 2); /* bad control argument */ end; end; /* process control arguments */ else do; /* process non-control arguments */ NON_CONTROL_ARG: if ^have_name then do; /* segment name, number or virtual pointer is the first non-control argument */ segno = cv_oct_check_ (command_arg, code); if code = 0 then do; /* segment number given */ if segno < 0 then call PRINT_ERROR (0, 17); have_name = "1"b; tca = tc; tpa = tp; seg_num = "1"b; if segno < hcscnt then do; /* do check for a hc segment */ if rz_call then hc_seg = "1"b; else call PRINT_ERROR (0, 6); /* rzd must be used to dump a hc segment */ end; /* do check for hc segment */ end; /* segment number given */ else do; /* pathname or SLT name given */ have_name = "1"b; tca = tc; /* remember the segment name */ tpa = tp; /* in seg_name */ end; /* pathname or SLT name given */ end; /* segment name or number is the first non-control argument */ else if ^have_first then do; /* first word is the second non-control argument */ first = cv_oct_check_ (command_arg, code); if code ^= 0 then call PRINT_ERROR (0, 4); /* non-octal number for first */ have_first = "1"b; end; /* first word is the second non-control argument */ else if ^have_count then do; /* count is the third non-control argument */ count = cv_oct_check_ (command_arg, code); if code ^= 0 then call PRINT_ERROR (0, 4); /* non-octal number for count */ if count < 0 then call PRINT_ERROR (0, 17); have_count = "1"b; end; /* count is the third non-control argument */ else call PRINT_ERROR (error_table_$too_many_args, 2); /* four non-control arguments is an error */ end; /* process non-control arguments */ end; /* do loop thru command arguments */ /* Check for legal formats and finish setting variables */ if have_structure then raw_data_fmt = (octal_fmt | hex8_fmt | hex9_fmt); if ^raw_data_fmt & ^interpreted_data_fmt & ^have_structure then call PRINT_ERROR (0, 10); /* asked to do nothing */ if have_structure & active_func /* structures not allowed in AF output.*/ then call PRINT_ERROR (0, 22); if raw_data & interpreted_data_fmt & active_func then call PRINT_ERROR (0, 11); /* asked for both as an AF */ if rest & have_count then call PRINT_ERROR (error_table_$inconsistent, 19); if raw_data_fmt & (^hex8_fmt & ^hex9_fmt & ^octal_fmt) then octal_fmt = "1"b; /* default raw data */ if interpreted_data_fmt & (^bit4_fmt & ^bcd_fmt & ^char_fmt & ^ebcdic8_fmt & ^ebcdic9_fmt) then char_fmt = "1"b; /* default interpreted data */ if ^have_name then call PRINT_ERROR (error_table_$noarg, 5); /* segment must be specified */ else do; /* obtain information about specified segment */ if seg_num then do; /* segment was specified by number in segno */ p = baseptr (segno); if segno < hcscnt then do; /* this is a hc segment number */ if rz_call then do; /* rzd ok with hc segments */ call ring0_get_$name (dirname, ename, p, code); if code ^= 0 then call PRINT_ERROR (code, 1); call set_max_from_SDW; cur_length = max_length; end; /* rzd ok with hc segments */ else call PRINT_ERROR (0, 6); /* ds cannot be used with hc segments */ end; /* this is a hc segment number */ else if segno = active_all_rings_data_$stack_base_segno then do; /* special case stack_0 */ dirname = ""; ename = "stack_0"; call set_max_from_SDW; cur_length = max_length; end; else do; /* this is a user segment number */ call hcs_$fs_get_path_name (p, dirname, dir_len, ename, code); if code ^= 0 then do; /* bad number specified */ tp = tpa; tc = tca; call PRINT_ERROR (code, 2); end; /* bad number specified */ if dirname = " " then dirname = ">"; /* handle the root special case */ call set_curlng_and_rb; end; /* this is a user segment number */ end; /* segment was specified by number in segno */ else do; /* segment was specified by SLT or pathname in seg_name */ if rz_call then do; /* try SLT name first for rzd call */ call ring0_get_$segptr ("", seg_name, p, code); if p ^= null then do; /* SLT name, get length from SDW */ segno = fixed (baseno (p), 18); hc_seg = "1"b; call set_max_from_SDW; cur_length = max_length; ename = seg_name; end; /* SLT name, get length from SDW */ else call process_name; /* must be a pathname or a virtual pointer */ end; /* try SLT name first for rzd call */ else call process_name; /* must be a pathname or virtual pointer */ end; /* segment was specified by SLT or pathname in seg_name */ end; /* obtain information about the specified segment */ if have_entry_point then do; if hc_seg then do; call ring0_get_$definition (p, "", entry_point_name, entry_point_offset, entry_type, code); if code ^= 0 then call PRINT_ERROR (code, 14); end; else do; call hcs_$status_minf (dirname, ename, 1, 0, bit_count, code); if code ^= 0 then call PRINT_ERROR (code, 5); on not_in_read_bracket call PRINT_ERROR (error_table_$lower_ring, 15); call object_info_$brief (p, bit_count, addr (obj_info), code); revert not_in_read_bracket; if code ^= 0 then call PRINT_ERROR (code, 15); call get_definition_ (obj_info.defp, "", entry_point_name, defn_ptr, code); if code ^= 0 then call PRINT_ERROR (code, 15); entry_point_offset = binary (defn_ptr -> definition.value, 18); end; if ^have_count & ^have_structure then do; /* make it look like we did have a count of 1 word */ if ^have_first then do; first = 0; have_first = "1"b; end; count = 1; have_count = "1"b; end; end; if max_length = 0 then do; /* set max_length if it has'nt been done already */ max_length = cur_length; /* set highest dumped address to current length of */ /* segment as guarenteed to be highest used page. */ end; /* set max_length if it has'nt been done already */ if have_structure & ^have_first then do; first = 0; have_first = "1"b; end; if have_structure & ^have_count then do; count = cur_length - first; have_count = "1"b; end; if ^have_first then do; /* don't have first or count */ if ^arg_for_header_given then header = "1"b; /* include header when dumping the whole segment */ first = 0; count = max_length; /* default to seg length for command */ have_first = "1"b; end; /* don't have first or count */ else if ^have_count then do; /* have first but don't have count */ if rest then count = max_length; else count = 1; have_count = "1"b; end; /* have first but don't have count */ first = first + entry_point_offset; if first >= max_length then call PRINT_ERROR (0, 9); /* can't dump past the end of the segment */ else if first < 0 then call PRINT_ERROR (0, 18); /* or before the beginning of the segment */ if first + count > max_length then do; /* only dump to max_length with no error indicated */ count = max_length - first; end; if block = 0 | block > count then block = count; /* set words per block if it has'nt been done yet */ if binary (rb2) < get_ring_ () then do; /* make a final access check */ if rz_call then hc_seg = "1"b; else call PRINT_ERROR (0, 6); /* error for ds call */ end; /* make a final access check */ /* Now print what we are told to */ if hc_seg then do; /* output for hc segment */ if count <= 64 then hcsp (1) = addr (buffer); else do; /* get a temp seg to copy the hc seg into */ call get_temp_segments_ (me (binary (rz_call)), hcsp, code); if code ^= 0 then call PRINT_ERROR (code, 1); /* no temp segments available */ end; /* get a temp seg to copy the hc seg into */ call ring_zero_peek_ (addrel (p, first), hcsp (1), count, code); if code ^= 0 then call PRINT_ERROR (code, 1); /* we failed */ if active_func then call return_dump (hcsp (1), first, count, cur_length, rel_offset); else call print_dump (hcsp (1), first, count, cur_length, block, rel_offset); end; /* output for hc segment */ else do; /* output for user segment */ if active_func then call return_dump (addrel (p, first), first, count, cur_length, rel_offset); else call print_dump (addrel (p, first), first, count, cur_length, block, rel_offset); /* output for user segment */ end; /* output for user segment */ if active_func then return_arg = requote_string_ (rtrim (return_arg)); /* fixed TR number 20051: want returned string without strailing spaces. */ CLEANUP: call cleaner_upper; return; %page; PRINT_ERROR: /* come here to print all com_err_ messages. */ proc (code, com_err_fmt_index); dcl code fixed bin (35) parameter; dcl com_err_fmt_index fixed bin parameter; if active_func then entry_var = active_fnc_err_; else entry_var = com_err_; if com_err_fmt_index = 3 then do; if code = error_table_$dirseg then do; bit_count = 0; call hcs_$status_minf (dirname, ename, 1, 0, bit_count, code); if code = 0 then if bit_count ^= 0 then code = error_table_$msf; else code = error_table_$dirseg; else code = error_table_$dirseg; /* couldn't get status on it, leave alone */ end; end; if dirname = ">" then dirname = ""; call entry_var (code, me (binary (rz_call)), com_err_fmt (com_err_fmt_index), command_arg, dirname, ename, entry_point_name, first, max_length, structure_name, have_structure_path, structure_path); goto CLEANUP; end PRINT_ERROR; %page; cleaner_upper: proc; if initsw & (^hc_seg) then call terminate_file_ (p, 0, TERM_FILE_TERM, code); if hcsp (1) ^= null then call release_temp_segments_ (me (binary (rz_call)), hcsp, code); end cleaner_upper; %page; process_name: proc; /* Global variables used: Input: seg_name char(tca) based(tpa) hcscnt fixed bin internal static Output: dirname char (168) ename char (32) p pointer segno fixed bin (18) initsw bit (1) hc_seg bit (1) */ tc = tca; /* initialize for error messages */ tp = tpa; call expand_pathname_ (seg_name, dirname, ename, code); if code = 0 then do; call initiate_file_ (dirname, ename, R_ACCESS, p, (0), code); if p ^= null then do; initsw = "1"b; segno = binary (baseno (p), 18); call set_curlng_and_rb; end; else goto TRY_SEGNAME_AS_VIRTUAL_POINTER; end; else do; TRY_SEGNAME_AS_VIRTUAL_POINTER: if rz_call /* try through phcs_ */ then do; on linkage_error call PRINT_ERROR (0, 2); /* in case no access to gate */ call phcs_$initiate (dirname, ename, "", 0, 0, p, code); revert linkage_error; if p = null then do; /* try it as a virtual pointer */ p = cv_ptr_ (seg_name, code); if code ^= 0 then call PRINT_ERROR (code, 2); end; segno = binary (baseno (p), 18); call set_max_from_SDW; cur_length = max_length; end; else do; p = cv_ptr_ (seg_name, code); if code ^= 0 then call PRINT_ERROR (code, 2); call hcs_$fs_get_path_name (p, dirname, dir_len, ename, code); if code ^= 0 then call PRINT_ERROR (code, 2); segno = binary (baseno (p), 18); call set_curlng_and_rb; end; end; if segno < hcscnt then hc_seg = "1"b; /* hardcore segment */ if have_first then first = first + wordno (p); else do; first = wordno (p); have_first = (first ^= 0); end; p = ptr (p, 0); /* point p to base of segment */ have_name, seg_num = "1"b; return; end process_name; %page; get_arg_ptr: proc (argno); /* This procedure MUST be quick internal */ /* Uses as input active_func bit (1) */ /* Sets tp pointer (command_arg) tc fixed bin (command_arg) code fixed bin (35) */ /* Entries */ dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); /* Automatic */ dcl argno fixed bin; if active_func then call cu_$af_arg_ptr (argno, tp, tc, code); else call cu_$arg_ptr (argno, tp, tc, code); end get_arg_ptr; %page; set_curlng_and_rb: proc; /* Uses as input dirname char (168) ename char (32) max_length fixed bin (19) */ /* Sets and uses code fixed bin (35) */ /* Sets rb2 bit (6) cur_length fixed bin (19) com_err_fmt_index fixed bin */ /* Automatic */ %include branch_status; /* External Variables */ dcl error_table_$root external; /* Entries */ dcl hcs_$status_long entry (char (*), char (*), fixed bin, ptr, ptr, fixed bin (35)); call hcs_$status_long (dirname, ename, 1, addr (branch_status), (null), code); if code = error_table_$root then do; /* set cur_length of root using SDW */ call set_max_from_SDW; /* this is required because of a bug in hcs_$status_long */ cur_length = max_length; end; /* set cur_length of root using SDW */ else if code = error_table_$no_s_permission | code = 0 /* normal segment */ then do; cur_length = fixed (branch_status.current_length, 12) * 1024; if cur_length = 0 then cur_length = 1; if type = directory_type then rb2 = "0"b; /* this is a dir so the rb given by status_ is a extended */ else rb2 = ring_brackets (1); /* other segment so ok */ /* ------------------------------------------------------------------------------------------------- */ /* The following must be eliminated when hcs_$status_ returns the ring brackets */ if code = error_table_$no_s_permission then do; if rz_call then rb2 = "0"b; /* assume ring_zero_peek must be used for rzd call */ else do; /* handle ds call */ if mode ^= "0"b then rb2 = "111"b; /* ds can look at it */ else rb2 = "0"b; /* ds cannot look at it */ end; /* handle ds call */ end; /* ------------------------------------------------------------------------------------------------- */ end; /* normal segment */ else call PRINT_ERROR (code, 3); /* status failed for some reason */ end set_curlng_and_rb; %page; set_max_from_SDW: proc; /* Uses as input segno fixed bin (18) */ /* Sets code fixed bin (35) max_length fixed bin (19) com_err_fmt_index fixed bin */ call ring_zero_peek_$get_max_length_ptr (baseptr (segno), max_length, code); if code ^= 0 then call PRINT_ERROR (code, 1); /* we failed */ return; end set_max_from_SDW; %page; print_header: proc; /* Uses as input header bit (1) segno fixed bin (18) hcscnt fixed bin static dirname char (168) ename char (32) p pointer */ /* Sets and uses code fixed bin (35) */ /* Automatic */ dcl date_time char (24); dcl name char (168); dcl dlen fixed bin; /* Entries */ dcl date_time_ entry (fixed bin (71), char (*)); dcl ring0_get_$name entry (char (*), char (*), ptr, fixed bin (35)); call date_time_ (clock (), date_time); if segno < hcscnt then do; /* header for hc seg */ call ring0_get_$name ("", name, p, code); dlen = index (name, " ") - 1; name = "HARDCORE SEG -- " || substr (name, 1, dlen); end; /* header for hc seg */ else if segno = active_all_rings_data_$stack_base_segno then do; /* special case stack_0 */ name = "stack_0"; end; else do; /* header for user seg */ dlen = index (dirname, " ") - 1; if dlen <= 1 then dlen = 0; /* to avoid >>foo */ if ename = "" & dirname = "" then name = ""; /* in case couldn't find the path out */ else name = substr (dirname, 1, dlen) || ">" || ename; end; /* header for user seg */ call ioa_$rs ("^/^2-^a^-^a^/", output_line, output_line_len, name, date_time); if active_func then return_arg = return_arg || substr (output_line, 1, output_line_len); else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code); /* If no header is printed, no white space will be inserted before the dump starts */ end print_header; %page; translate_line_to_dump: proc (wds_in_line, line_ptr, translation); /* Formal Parameters */ dcl wds_in_line fixed bin; dcl line_ptr ptr; dcl translation char (32) varying; /* Automatic, structures for accessing the input line and subrutine return args */ dcl ascii_chars char (wds_in_line * 4) based (line_ptr); dcl bcd_chars bit (wds_in_line * 36) based (line_ptr); dcl ebcdic9_chars char (wds_in_line * 4) based (line_ptr); dcl ebcdic8_chars bit (divide (wds_in_line * 9, 2, 17) * 36) based (line_ptr); dcl fourbit_chars bit (wds_in_line * 36) based (line_ptr); dcl overlay_return char (32); /* used to make this a quick block */ dcl bcd_return char (wds_in_line * 6) based (addr (overlay_return)); dcl ebcdic9_return char (wds_in_line * 4) based (addr (overlay_return)); dcl ebcdic8_return char (divide (wds_in_line * 9, 2, 17)) based (addr (overlay_return)); dcl comp_8_return char (wds_in_line * 8) based (addr (overlay_return)); dcl i fixed bin; /* character string index */ dcl temp_overlay char (32); /* used to make this a quick block */ dcl temp_ascii char (length (ascii_chars)) based (addr (temp_overlay)); dcl temp_ebcdic9 char (length (ebcdic9_chars)) based (addr (temp_overlay)); /* Constants */ dcl last_ascii char (1) aligned internal static options (constant) initial (""); /* last ascii char code */ dcl last_ebcdic char (1) aligned internal static options (constant) initial ("ÿ"); /* last ebcdic char code */ /* Entries */ dcl bcd_to_ascii_ entry (bit (*), char (*)); dcl ebcdic_to_ascii_ entry (char (*), char (*)); dcl comp_8_to_ascii_ entry (bit (*), char (*)); dcl ebcdic8_to_ascii_ entry (bit (*), char (*)); translation = ""; if char_fmt then do; temp_ascii = ascii_chars; do i = 1 to length (ascii_chars) by 1; /* set illegal characters to 0 */ if substr (ascii_chars, i, 1) > last_ascii then substr (temp_ascii, i, 1) = ""; end; /* set illegal characters to 0 */ translation = translate (temp_ascii, dots, nonprinting_chars); end; else if bcd_fmt then do; call bcd_to_ascii_ (bcd_chars, bcd_return); translation = bcd_return; end; else if ebcdic9_fmt then do; temp_ebcdic9 = ebcdic9_chars; do i = 1 to length (ebcdic9_chars) by 1;/* set illegal characters to 0 */ if substr (ebcdic9_chars, i, 1) > last_ebcdic then substr (temp_ebcdic9, i, 1) = ""; end; /* set illegal characters to 0 */ call ebcdic_to_ascii_ (temp_ebcdic9, ebcdic9_return); translation = translate (ebcdic9_return, dots, nonprinting_chars); end; else if ebcdic8_fmt then do; call ebcdic8_to_ascii_ (ebcdic8_chars, ebcdic8_return); translation = translate (ebcdic8_return, dots, nonprinting_chars); end; else if bit4_fmt then do; call comp_8_to_ascii_ (fourbit_chars, comp_8_return); translation = comp_8_return; end; end translate_line_to_dump; %page; return_dump: proc (seg_ptr, first, count, cur_length, rel_offset); /* Return the dump when used as an active function. The format of the returned ascii string is set such that if -ascii is used, then the ascii translation is returned, otherwise the returned string is the octal, hex, bcd or ebcdic form of the translation. */ /* Formal parameters */ dcl seg_ptr ptr; /* to segment to dump */ dcl first fixed bin (18); /* in words */ dcl count fixed bin (18); /* in words */ dcl cur_length fixed bin (18); /* in blocks of 1024 words */ dcl rel_offset fixed bin (18); /* in words */ /* Based */ dcl seg_wds (0:262143) bit (36) based (seg_ptr); dcl word_mask (1:1024) fixed bin (35) based (blockp); /* Automatic */ dcl tailx fixed bin; dcl block_addr fixed bin; dcl block_lng fixed bin; dcl last_block bit (1) aligned; dcl wds_in_line fixed bin; dcl blockp ptr; /* Static */ dcl af_format (0:7) char (15) var options (constant) static init ("^v(^.3b ^)", "^vs^a", "^v(^.4b ^)", "^vs^a", "^v(^a ^)", "^vs^a", "", "^vs^a"); wds_in_line = 8; /* dump 8 words at a time */ if interpreted_data_fmt then tailx = 1; else tailx = 0; if raw_data_fmt then if hex8_fmt then tailx = tailx + 2; else if hex9_fmt then tailx = tailx + 4; else if octal_fmt then ; /* default */ else ; else tailx = tailx + 6; line_format = af_format (tailx); block_lng = min (count, 1024); /* process by 1024 (or count if seg is less than 1024 long) */ /* words until last block */ last_block = "0"b; do block_addr = first to first + count - block_lng - 1 by block_lng; call return_block; end; last_block = "1"b; /* now do the last block in the segment */ if ^have_count then do; blockp = addrel (seg_ptr, block_addr); do block_lng = first + count - block_addr to 1 by -1 while (blockp -> word_mask (block_lng) = 0); /* look for last non_zero word */ end; if block_lng = 0 then return; /* was all zeros */ end; else block_lng = first + count - block_addr; call return_block; return; %page; return_block: proc; /* Automatic */ dcl line_addr fixed bin; dcl first_line bit (1) aligned; first_line = "0"b; do line_addr = block_addr to block_addr + block_lng - wds_in_line - 1 by wds_in_line; call return_line (wds_in_line, line_addr + wds_in_line - 1); end; /* Now handle the last line */ if last_block then call return_line (block_addr + block_lng - line_addr, block_addr + block_lng - 1); return; %page; return_line: proc (wds_in_line, line_addr_limit); /* Formal parameters */ dcl wds_in_line fixed bin parameter; dcl line_addr_limit fixed bin (18) parameter; /* Automatic */ dcl output_words (1:wds_in_line) bit (36) based (addr (line_to_dump)); dcl bits_to_dump bit (wds_in_line * 36) based (addr (line_to_dump)); dcl translation char (32) varying; dcl hex9_line char (64); dcl hex9_array (1:wds_in_line) char (8) based (addr (hex9_line)); dcl wrd_addr fixed bin (18); dcl line_to_dump (1:8) bit (36); do wrd_addr = line_addr to line_addr_limit by 1; if wrd_addr <= cur_length - 1 then line_to_dump (wrd_addr - line_addr + 1) = seg_wds (wrd_addr - first); else line_to_dump (wrd_addr - line_addr + 1) = (36)"0"b; end; if interpreted_data_fmt then call translate_line_to_dump (wds_in_line, addr (line_to_dump), translation); if hex9_fmt then do; call translate_bytes_to_hex9_ (bits_to_dump, hex9_line); call ioa_$rsnnl (line_format, output_line, output_line_len, wds_in_line, hex9_array, translation); end; else call ioa_$rsnnl (line_format, output_line, output_line_len, wds_in_line, output_words, translation); return_arg = return_arg || substr (output_line, 1, output_line_len); end return_line; end return_block; end return_dump; %page; print_dump: proc (seg_ptr, first, count, cur_length, block_lng, rel_offset); /* Note for future improvments that there is a complete symmetry between blocks and lines: duplicates must be found; the first duplicate must print a message and subsequent ones are suppressed; the last one must be handled separately and always printed. */ /* Formal parameters */ dcl seg_ptr ptr; dcl first fixed bin (18); dcl count fixed bin (18); dcl cur_length fixed bin (18); dcl block_lng fixed bin (18); dcl rel_offset fixed bin (18); /* Based */ dcl seg_wds (0:262143) bit (36) based (seg_ptr); /* Automatic */ dcl block_addr fixed bin (18); dcl dup_block bit (1); dcl first_block bit (1); dcl first_dup_block bit (1); dcl hfx fixed bin; dcl i fixed bin; dcl (j, k) fixed bin (18); dcl last_block bit (1); dcl shfx fixed bin; dcl length_of_digit_field fixed bin; dcl number_of_digit_fields fixed bin; dcl tailx fixed bin; dcl wds_in_line fixed bin; /* Static */ dcl short_format (0:3) char (8) static init ("^6w^s", "^s^6w", "^6w^s", "^6w ^6w"); dcl head_format (0:7) char (12) var static init ("^2s", /* ^addr, ^off, ^short */ "^2s", /* ^addr, ^off, short */ "^s^6w^x", /* ^addr, off, ^short */ "^s^2w^x", /* ^addr, off, short */ "^6w^x^s", /* addr, ^off, ^short */ "^2w^x^s", /* addr, ^off, short */ "^6w^x^6w^x", /* addr, off, ^short */ "^2w^x^s"); /* addr, off, short */ dcl tail_format (0:7) char (15) var options (constant) static init ("^v(^.3b ^)", "^v(^.3b ^)^vx^a", "^v(^.4b ^)", "^v(^.4b ^)^vx^a", "^v(^a ^)", "^v(^a ^)^vx^a", "", "^vs^s^a"); if header then call print_header; if long_fmt then wds_in_line = 8; else wds_in_line = 4; shfx = binary (substr (dump_segment_format, 1, 2), 2); hfx = binary (substr (dump_segment_format, 1, 3), 3); if interpreted_data_fmt then tailx = 1; else tailx = 0; if raw_data_fmt then if hex8_fmt then tailx = tailx + 2; else if hex9_fmt then tailx = tailx + 4; else if octal_fmt then ; /* default */ else ; else tailx = tailx + 6; line_format = head_format (hfx) || tail_format (tailx); /* Set the length of the field that is used for printing the octal or hex information according to what type of info we're displaying. */ if hex9_fmt then length_of_digit_field = 9; /* hex9 data */ else if hex8_fmt then length_of_digit_field = 10; /* hex8 data */ else length_of_digit_field = 13; /* octal data */ /* Set the number of digit fields on a COMPLETE output line so we can later calculate how many spaces to put on the last line if it is not filled. */ if long_fmt then number_of_digit_fields = 8; else number_of_digit_fields = 4; first_block = "1"b; first_dup_block = "1"b; last_block = "0"b; dup_block = "0"b; do block_addr = first to first + count - block_lng - 1 by block_lng; if first_block then do; /* always print the first block */ if have_structure then call print_structure; if raw_data_fmt | interpreted_data_fmt then call print_block; if active_func /* blank line between blocks */ then return_arg = return_arg || NL; else call ioa_$ioa_switch (iocbp, " "); first_block = "0"b; end; /* always print the first block */ else do; /* test subsequent blocks for duplicates */ if block_addr - block_lng <= cur_length - 1 then do; /* check for dup blocks */ dup_block = "1"b; do i = 0 to block_lng - 1; j = block_addr - block_lng + i; k = block_addr + i; if j <= cur_length - 1 then do; /* don't exceed the current length of old block */ if k <= cur_length - 1 then do; /* don't exceed the current length of new block */ if seg_wds (k - first) ^= seg_wds (j - first) then dup_block = "0"b; end; /* don't exceed the current length of new block */ else do; /* use 0 past current length of new block */ if "0"b ^= seg_wds (j - first) then dup_block = "0"b; end; /* use 0 past current length of new block */ end; /* don't exceed the current length of old block */ else ; end; end; /* check for dup blocks */ else dup_block = "1"b; /* must be duplicates */ if dup_block & first_dup_block then do; /* print message for first dup block */ if active_func then return_arg = return_arg || "duplicate blocks" || NL || NL; else call ioa_$ioa_switch (iocbp, "duplicate blocks^/"); first_dup_block = "0"b; if have_structure then call print_structure; if raw_data_fmt | interpreted_data_fmt then call print_block; end; /* print message for first dup block */ else do; /* check further before printing */ if ^dup_block then do; /* not a dup block, print it */ if have_structure then call print_structure; if raw_data_fmt | interpreted_data_fmt then call print_block; if active_func /* blank line between blocks */ then return_arg = return_arg || NL; else call ioa_$ioa_switch (iocbp, " "); first_dup_block = "1"b; end; /* not a dup block, print it */ else ; /* null because we don't print dup blocks */ end; /* check further before printing */ end; /* test subsequent blocks for duplicates */ end; /* Now handle the last block */ last_block = "1"b; block_lng = first + count - block_addr; if have_structure then call print_structure; if raw_data_fmt | interpreted_data_fmt then call print_block; /* always print the last block */ %page; print_block: proc; /* Automatic */ dcl cur_line char (wds_in_line * 4) based (addrel (seg_ptr, line_addr - first)); /* dcled char instead of bit since CMPC is faster than CMPB */ dcl dup_line bit (1); dcl first_dup_line bit (1); dcl first_line bit (1); dcl line_addr fixed bin (18); dcl offset_addr fixed bin (18); dcl prev_addr fixed bin (18); /* for use by print_line */ dcl prev_line char (wds_in_line * 4) based (addrel (seg_ptr, prev_line_addr - first)); /* dcled char instead of bit since CMPC is faster than CMPB */ dcl prev_line_addr fixed bin (18); dcl i fixed bin; dcl (j, k) fixed bin (18); first_line = "1"b; first_dup_line = "1"b; offset_addr = rel_offset; prev_addr = block_addr; prev_line_addr = block_addr; do line_addr = block_addr to block_addr + block_lng - wds_in_line - 1 by wds_in_line; if first_line then do; /* handle first line differently */ if last_block | ^dup_block then do; /* print first line unless a dup block */ call print_line (wds_in_line, line_addr + wds_in_line - 1); first_line = "0"b; end; /* print first line unless a dup block */ end; /* handle first line differently */ else do; /* handle subsequent lines */ if line_addr - wds_in_line <= cur_length - 1 then do; /* check for dup lines */ dup_line = "1"b; if line_addr + wds_in_line <= cur_length - 1 then do; /* everything less than cur_length */ if prev_line_addr ^= line_addr then do; if prev_line = cur_line then dup_line = "1"b; else dup_line = "0"b; end; end; /* everything less than cur_length */ else do; /* cross over cur_length */ do i = 0 to wds_in_line - 1; j = line_addr - wds_in_line + i; k = line_addr + i; if j <= cur_length - 1 & k <= cur_length - 1 then do; if seg_wds (j - first) ^= seg_wds (k - first) then dup_line = "0"b; end; else if j <= cur_length - 1 then do; if seg_wds (j - first) ^= "0"b then dup_line = "0"b; end; else ; /* both words must be 0 so equal */ end; end; /* cross over cur_length */ end; /* check for dup lines */ else dup_line = "1"b; /* must be duplicates */ if dup_line & first_dup_line & suppress_dup_fmt then do; /* print message for first dup line */ if active_func then return_arg = return_arg || "======" || NL; else call ioa_$ioa_switch (iocbp, "======"); first_dup_line = "0"b; end; /* print message for first dup line */ else if ^dup_line | ^suppress_dup_fmt then do; /* print this line */ call print_line (wds_in_line, line_addr + wds_in_line - 1); first_dup_line = "1"b; end; /* print this line */ else ; /* null because we don't print dup lines */ end; /* handle subsequent lines */ offset_addr = offset_addr + wds_in_line; /* keep offset_addr up with line_addr */ prev_line_addr = line_addr; end; /* Now handle the last line */ if last_block | ^dup_block then call print_line (block_addr + block_lng - line_addr, block_addr + block_lng - 1); return; %page; print_line: proc (wds_in_line, line_addr_limit); /* Formal parameters */ dcl wds_in_line fixed bin; dcl line_addr_limit fixed bin (18); /* Automatic */ dcl addr_col fixed bin (18); dcl line_to_dump (1:8) bit (36); dcl offset_col fixed bin (18); dcl wrd_addr fixed bin (18); dcl output_words (1:wds_in_line) bit (36) based (addr (line_to_dump)); dcl bits_to_dump bit (wds_in_line * 36) based (addr (line_to_dump)); dcl translation char (32) varying; dcl hex9_line char (64); dcl hex9_array (1:wds_in_line) char (8) based (addr (hex9_line)); addr_col = line_addr; offset_col = offset_addr; do wrd_addr = line_addr to line_addr_limit by 1; if wrd_addr <= cur_length - 1 then line_to_dump (wrd_addr - line_addr + 1) = seg_wds (wrd_addr - first); else line_to_dump (wrd_addr - line_addr + 1) = (36)"0"b; end; if short_fmt then do; /* print out addresses if short format */ addr_col = mod (line_addr, 64); offset_col = mod (offset_addr, 64); if line_addr >= prev_addr + (64 - mod (prev_addr, 64)) | line_addr = prev_addr then do; call ioa_$rs (short_format (shfx), output_line, output_line_len, line_addr, offset_addr); if active_func then return_arg = return_arg || substr (output_line, 1, output_line_len); else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code); end; prev_addr = line_addr; end; /* print out addresses if short format */ if interpreted_data_fmt then call translate_line_to_dump (wds_in_line, addr (line_to_dump), translation); if hex9_fmt then do; /* translate words to dump into hex9 format */ call translate_bytes_to_hex9_ (bits_to_dump, hex9_line); call ioa_$rs (line_format, output_line, output_line_len, addr_col, offset_col, wds_in_line, hex9_array, (number_of_digit_fields - wds_in_line) * length_of_digit_field, translation); if active_func then return_arg = return_arg || substr (output_line, 1, output_line_len); else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code); end; /* translate words to dump into hex9 format */ else do; call ioa_$rs (line_format, output_line, output_line_len, addr_col, offset_col, wds_in_line, output_words, (number_of_digit_fields - wds_in_line) * length_of_digit_field, translation); if active_func then return_arg = return_arg || substr (output_line, 1, output_line_len); else call iox_$put_chars (iocbp, addr (output_line), output_line_len, code); end; end print_line; end print_block; %page; print_structure: proc(); dcl code fixed bin(35); dcl full_name char(256); dcl match_names (10) char (32) varying; dcl n_match_names fixed bin; dcl n_subscripts fixed bin; dcl structure_ptr ptr; dcl subscripts (2, 16) fixed bin(24); dcl symbol_ptr ptr; dcl unsubscripted_name char (256); if address_fmt then call ioa_$ioa_switch (iocbp, "^6w", block_addr); structure_ptr = addr(seg_wds(block_addr-first)); call structure_ref_$parse ((structure_name), full_name, unsubscripted_name, subscripts, n_subscripts, match_names, n_match_names, code); if code ^= 0 then call PRINT_ERROR (code, 23); if have_structure_path then call structure_find_$pathname (structure_path, unsubscripted_name, symbol_ptr, code); else call structure_find_$search (unsubscripted_name, symbol_ptr, code); if code ^= 0 then call PRINT_ERROR (code, 24); call display_data_$for_azm (iocbp, ^long_fmt, match_names, n_match_names, null, structure_ptr, cur_length, structure_ptr, symbol_ptr, subscripts, n_subscripts, code); if code ^= 0 then call PRINT_ERROR (code, 25); end print_structure; end print_dump; %page; /* Parameters */ dcl a_old_format bit (6); dump_seg_: entry (a_iocbp, a_ptr, a_first, a_count, a_old_format); if first_time then do; nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1); first_time = "0"b; end; active_func, have_structure, have_structure_path = "0"b; iocbp = a_iocbp; unspec (dump_segment_format) = ""b; dump_segment_format = a_old_format; first = a_first; count = a_count; cur_length = first + count; block = count; rel_offset = 0; if (short_fmt & long_fmt) | (bcd_fmt & char_fmt) then do; string (dump_segment_format) = ""b; address_fmt = "1"b; end; /* set format to default */ else if bcd_fmt | char_fmt then interpreted_data_fmt = "1"b; raw_data_fmt, octal_fmt = "1"b; command_output_fmt = "0"b; call print_dump (a_ptr, first, count, cur_length, block, rel_offset); return; %page; /* The following entry can be called by programs that want output in the same format as dump_segment. The arguments are: a_iocbp a pointer to the I/O switch to use a_ptr a pointer to the first word of data to dump a_blk_size output dump in blocks of this number of words a_first the offset of the first word to dump a_count the number of words to dump a_format a format control string (bit string) indicating the output mode */ /* Parameters */ dcl a_count fixed bin (18); dcl a_first fixed bin (18); dcl a_blk_size fixed bin; dcl a_format bit (*); dcl a_iocbp ptr; dcl a_ptr ptr; dcl MR10_FORMAT_LENGTH fixed bin int static options (constant) init (11); dump_segment_: entry (a_iocbp, a_ptr, a_blk_size, a_first, a_count, a_format); if first_time then do; nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1); first_time = "0"b; end; active_func, have_structure, have_structure_path = "0"b; iocbp = a_iocbp; unspec (dump_segment_format) = ""b; dump_segment_format = a_format; first = fixed (rel (a_ptr), 18, 0); count = a_count; if count <= 0 then count = 1; cur_length = first + count; if a_blk_size <= 0 then block = count; else block = min (a_blk_size, count); rel_offset = a_first; if (short_fmt & long_fmt) | (hex8_fmt & hex9_fmt) | ((binary (bcd_fmt) + binary (char_fmt) + binary (ebcdic9_fmt) + binary (ebcdic8_fmt) + binary (bit4_fmt)) >= 2) then do; string (dump_segment_format) = ""b; address_fmt = "1"b; end; /* set format to default */ if length (a_format) <= MR10_FORMAT_LENGTH then do; raw_data_fmt, suppress_dup_fmt = "1"b; if bcd_fmt | char_fmt | ebcdic9_fmt | ebcdic8_fmt | bit4_fmt then interpreted_data_fmt = "1"b; if ^hex8_fmt & ^hex9_fmt then octal_fmt = "1"b; header, command_output_fmt = "0"b; end; call hcs_$fs_get_path_name (a_ptr, dirname, dir_len, ename, code); if code ^= 0 then do; /* bad number specified */ dirname = ""; ename = ""; end; call print_dump (a_ptr, first, count, cur_length, block, rel_offset); return; %page; /* The following entry can be called by programs that want output returned in the same format as dump_segment when used as an active function. The arguments are: a_string_ptr a pointer to a varying char string a_string_length maximum length of the char string a_ptr a pointer to the first word of data to dump a_blk_size output dump in blocks of this number of words a_first the offset of the first word to dump a_count the number of words to dump a_format a format control string (bit string) indicating the output mode */ /* Parameters */ dcl a_string_ptr ptr; dcl a_string_length fixed bin (21); dump_segment_$string: entry (a_string_ptr, a_string_length, a_ptr, a_blk_size, a_first, a_count, a_format); if first_time then do; nonprinting_chars = substr (collate (), 1, 32) || substr (collate (), 128, 1); first_time = "0"b; end; active_func = "1"b; ret_tc = a_string_length; ret_tp = a_string_ptr; if ret_tc <= 0 | ret_tp = null then return; return_arg = ""; dump_segment_format = a_format; first = fixed (rel (a_ptr), 18, 0); count = a_count; if count <= 0 then count = 1; cur_length = first + count; if a_blk_size <= 0 then block = count; else block = min (a_blk_size, count); rel_offset = a_first; if short_fmt & long_fmt | hex8_fmt & hex9_fmt | (binary (bcd_fmt) + binary (char_fmt) + binary (ebcdic9_fmt) + binary (ebcdic8_fmt) + binary (bit4_fmt)) >= 2 then do; string (dump_segment_format) = ""b; address_fmt = "1"b; end; /* set format to default */ call hcs_$fs_get_path_name (a_ptr, dirname, dir_len, ename, code); if code ^= 0 then do; /* bad number specified */ dirname = ""; ename = ""; end; if command_output_fmt then call print_dump (a_ptr, first, count, cur_length, block, rel_offset); else call return_dump (a_ptr, first, count, cur_length, rel_offset); return_arg = requote_string_ ((return_arg)); return; %page; /* This subroutine is really cv_ptr_, but we have to modify it to work on inner ring segments because cv_ptr_ doesn't do that. When it does, then we can remove this routine and call cv_ptr_ instead. */ cv_ptr_: procedure (string, Acode) returns (ptr); dcl /* Parameters */ string char (*), /* virtual pointer character string. (In) */ Acode fixed bin(35); /* status code. (Out) */ dcl /* Automatic Variables */ (Lbit_offset, Lsegment_id, Lword_offset) fixed bin, /* length of various parts of virtual pointer. */ (Pbit_offset, Psegment_id, Pword_offset, Pdelim) ptr, /* pointer to various parts of virtual pointer. */ P ptr, /* returned pointer. */ Pdef ptr, /* pointer to entry point definition structure. */ bc fixed bin(24), /* bit count of target segment. */ (bit, segno, word) fixed bin(35), /* numeric parts of virtual pointer. */ code fixed bin(35), dir char(168), /* dir part of segment's pathname. */ ent char(32), /* entry part of segment's pathname. */ entry_point_offset fixed bin (18), i fixed bin, id_case fixed bin, /* type of segment identifier in virtual pointer. */ /* 1 = PATHNAME, 2 = REF_NAME, 3 = SEGNO. */ inner_ring_segment bit (1) aligned, /* determines whether we can terminate the segment in the user ring */ offset_case fixed bin, /* type of offset value in virtual pointer. */ /* 5 = MISSING, 6 = WORD, 7 = WORD_AND_BIT, */ /* 8 = ENTRY_PT. */ 1 oi aligned like object_info, segp ptr; dcl /* Based Variables */ bit_offset char(Lbit_offset) based (Pbit_offset), bit_offset_array (Lbit_offset) char(1) based(Pbit_offset), bits (36) bit(1) unaligned based, delim char(1) based (Pdelim), segment_id char(Lsegment_id) based (Psegment_id), string_array (length(string)) char(1) based (addr (string)), word_offset char(Lword_offset) based (Pword_offset), word_offset_array (Lword_offset) char(1) based (Pword_offset); dcl /* Entries */ cv_dec_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)), cv_oct_check_ entry (char(*), fixed bin(35)) returns (fixed bin(35)), expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)), get_definition_ entry (ptr, char(*), char(*), ptr, fixed bin(35)), hcs_$fs_get_path_name entry (ptr, char(*), fixed bin, char(*), fixed bin(35)), hcs_$fs_get_seg_ptr entry (char(*), ptr, fixed bin(35)), hcs_$initiate_count entry (char(*), char(*), char(*), fixed bin(24), fixed bin(2), ptr, fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin(35)), object_info_$brief entry (ptr, fixed bin(24), ptr, fixed bin(35)); dcl length builtin; dcl /* Static Variables and Constants */ (PATHNAME init(1), /* acceptable values which id_case may take on. */ REF_NAME init(2), SEGNO init(3), MISSING init(5), /* acceptable values offset_case may take on. */ WORD init(6), WORD_AND_BIT init(7), ENTRY_PT init(8)) fixed bin int static options(constant), (TEXT init ("000"b), /* values which definition.class may take on. */ LINKAGE init ("001"b), SYMBOL init ("010"b), STATIC init ("100"b)) bit(3) int static options(constant), V_BAR char(1) int static options(constant) init("|"), (error_table_$bad_class_def, error_table_$bad_conversion, error_table_$bigarg, error_table_$entlong, error_table_$lower_ring, error_table_$improper_data_format, error_table_$out_of_bounds) fixed bin(35) ext static, sys_info$max_seg_size fixed bin(35) ext static; %include definition; %include object_info; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Acceptable virtual pointer strings have the following forms: */ /* */ /* CASES */ /* I O FORM COMMENT */ /* ----- ----------------------- ------------------------------------------ */ /* 1 5 path = path|0(0) */ /* 1 5 path| = path|0(0) */ /* 1 6 path|W = path|W(0) */ /* 1 7 path|W(B) octal word W, decimal bit B of path */ /* 1 8 path|entry_pt word identified by entry point entry_pt in path */ /* 1 8 path$entry_pt word identified by entry point entry_pt in seg */ /* with pathname pat */ /* */ /* 2 5 ref_name$ = ref_name$0(0) */ /* 2 6 ref_name$W = ref_name$W(0) */ /* 2 7 ref_name$W(B) octal word W, decimal bit B of seg with reference */ /* name ref_name. */ /* 2 8 ref_name$entry_pt word identified by entry point entry_pt in seg */ /* with reference name ref_name */ /* */ /* 3 5 segno = segno|0(0) */ /* 3 5 segno| = segno|0(0) */ /* 3 6 segno|W = segno|W(0) */ /* 3 7 segno|W(B) octal word W, decimal bit B of seg known by segno */ /* 3 8 segno|entry_pt word identified by entry point entry_pt in seg */ /* known by segno */ /* */ /* CASES: I = segment identifier case (id_case), O = offset value case (offset_case). */ /* I = 1 => PATHNAME O = 5 => MISSING (no offset given) */ /* = 2 => REF_NAME = 6 => WORD */ /* = 3 => SEGNO = 7 => WORD_AND_BIT */ /* = 8 => ENTRY_PT */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ Acode = 0; /* initialize return code. */ code = error_table_$improper_data_format; /* initialize format error code. */ id_case = PATHNAME; /* start by assuming we have a path segment */ offset_case = MISSING; /* identifier, and no offset value. */ Psegment_id = addr(string); /* Split identifier into seg_id, delim, & offset. */ i = search (reverse(string), "|$"); /* Look for the delimiter. */ if i > 0 then i = length(string) - (i-1); if i = 0 then do; /* CASE: No delimiter. */ Pdelim = addr(V_BAR); /* Assume |. */ Lsegment_id = length(rtrim(string)); /* Address seg_id. */ Pword_offset = addr(Pword_offset); /* Indicate no word offset. */ Lword_offset = 0; end; else do; /* CASE: Delimiter found. */ Pdelim = addr(string_array(i)); /* Remember delimiter. */ Lsegment_id = i-1; /* Address seg_id. */ Lsegment_id = length(rtrim(segment_id)); if i < length(string) then do; /* Look for word offset. */ Pword_offset = addr(string_array(i+1)); /* Remember where word offset is. */ Lword_offset = length(string) - i; Lword_offset = length(rtrim(word_offset)); i = verify(word_offset, " "); if i > 1 then do; Pword_offset = addr(word_offset_array(i)); Lword_offset = Lword_offset - (i-1); end; end; else do; /* No word offset. */ Pword_offset = addr(Pword_offset); Lword_offset = 0; end; end; if verify (segment_id, "01234567") = 0 then /* check for segno identifier. */ id_case = SEGNO; else if segment_id = "-1" then /* this includes null pointer segno. */ id_case = SEGNO; if (delim = "$") & (search (segment_id, "><") > 0) then do; if id_case ^= PATHNAME then call ERROR; /* CASE: seg_id is a pathname. */ if length(segment_id) > 168 then do; code = error_table_$bigarg; call ERROR; end; end; else if delim = "$" then do; /* CASE: seg_id is a ref_name. */ id_case = REF_NAME; if length(segment_id) > 32 then do; code = error_table_$entlong; call ERROR; end; end; else if delim = "|" then; /* CASE: seg_id is path or segno. */ else call ERROR; /* CASE: seg_id followed by bad delim. We should */ /* never get to this line. */ if length(word_offset) > 0 then do; /* Evaluate word offset. */ offset_case = WORD; /* Start by assuming word offset. */ i = verify (word_offset, "01234567"); /* Check for octal word offset. */ if i = 0 then; /* CASE: only word offset given. */ else if (word_offset_array(i) = "(") then do; code = error_table_$bad_conversion; offset_case = WORD_AND_BIT; if word_offset_array(Lword_offset) ^= ")" then call ERROR; Pbit_offset = addr(word_offset_array(i+1)); Lbit_offset = Lword_offset - i - 1; /* Overlay the bit offset. */ Lbit_offset = length(rtrim(bit_offset)); Lword_offset = i - 1; /* Exclude bit from word offset. */ Lword_offset = length(rtrim(word_offset)); i = verify(bit_offset, " "); if i > 1 then do; Pbit_offset = addr(bit_offset_array(i)); Lbit_offset = Lbit_offset - (i-1); end; if verify (bit_offset, "0123456789") ^= 0 then do; code = error_table_$bad_conversion; call ERROR; end; end; else do; /* CASE: no word offset, just entry_pt. */ offset_case = ENTRY_PT; if length(word_offset) > 256 then do; /* Validate entry point length. */ code = error_table_$entlong; call ERROR; end; end; end; if (delim = "$") & (id_case = PATHNAME) & (offset_case ^= ENTRY_PT) then do; code = error_table_$improper_data_format; call ERROR; end; if id_case = PATHNAME then do; /* id_case = PATHNAME */ call expand_pathname_ (segment_id, dir, ent, code); if code ^= 0 then call ERROR; /* Expand the pathname given in virtual ptr. */ end; else do; if id_case = REF_NAME then do; /* id_case = REF_NAME. */ call hcs_$fs_get_seg_ptr (segment_id, P, code); if code ^= 0 then do; /* Convert reference name to a pointer. */ call ring0_get_$segptr ("", segment_id, P, code); if code ^= 0 then call ERROR; end; end; else do; /* id_case = SEGNO */ segno = cv_oct_check_ (segment_id, code); if code ^= 0 then do; code = error_table_$bad_conversion; call ERROR; end; P = baseptr (segno); /* Convert segment number to a pointer. */ if (segment_id = "-1") | (segment_id = "77777") | (segment_id = "777777") then do; /* Special case null pointers. */ if offset_case = MISSING then return (null); if offset_case = ENTRY_PT then do; code = error_table_$improper_data_format; call ERROR; end; go to OFFSET; end; end; segp = P; call hcs_$fs_get_path_name (segp, dir, (0), ent, code); if code ^= 0 then do; /* try in inner ring */ segno = binary (baseno (P)); if segno < hcscnt then do; call ring0_get_$name (dir, ent, segp, code); if code ^= 0 then call ERROR; /* Convert pointer to a pathname. */ end; else if segno = active_all_rings_data_$stack_base_segno then do; code = 0; dir = ""; ent = "stack_0"; end; else call ERROR; goto OFFSET; end; end; call hcs_$initiate_count (dir, ent, "", bc, 0, segp, code); /* Initiate segment identified by pathname */ /* with a null reference name. */ if segp = null then do; /* try in an inner ring */ on linkage_error call ERROR; call phcs_$initiate (dir, ent, "", 0, 0, segp, code); revert linkage_error; if segp = null then call ERROR; P = segp; inner_ring_segment = "1"b; end; else inner_ring_segment = "0"b; OFFSET: if offset_case = MISSING then; /* No offset was given. */ else if offset_case = ENTRY_PT then do; /* An entry point was given. */ oi.version_number = object_info_version_2; /* Call object_info_ to get ptr to obj defs. */ call object_info_$brief (P, bc, addr(oi), code); if code = error_table_$lower_ring then do; /* try in a lower ring */ call ring0_get_$definition (P, ent, word_offset, entry_point_offset, (0), code); if code ^= 0 then call ERROR; P = ptr (P, entry_point_offset); end; else if code ^= 0 then call ERROR; else do; if id_case = REF_NAME then /* Get ptr to definition for entry point. */ call get_definition_ (oi.defp, segment_id, word_offset, Pdef, code); else call get_definition_ (oi.defp, ent, word_offset, Pdef, code); if code ^= 0 then call ERROR; if Pdef -> definition.class = TEXT then /* Apply definition to get word offset. */ P = addrel (oi.textp, Pdef -> definition.value); else if Pdef -> definition.class = LINKAGE then P = addrel (oi.linkp, Pdef -> definition.value); else if Pdef -> definition.class = SYMBOL then P = addrel (oi.symbp, Pdef -> definition.value); else if Pdef -> definition.class = STATIC then P = addrel (oi.statp, Pdef -> definition.value); else do; code = error_table_$bad_class_def; call ERROR; end; end; end; else do; /* A word, or word and bit offset was given. */ word = cv_oct_check_ (word_offset, code); /* Convert/validate word offset. */ if code ^= 0 then do; code = error_table_$bad_conversion; call ERROR; end; if (0 <= word) & (word <= sys_info$max_seg_size) then; else do; code = error_table_$out_of_bounds; call ERROR; end; P = ptr (P, word); /* Apply word offset to pointer. */ if offset_case = WORD_AND_BIT then do; /* A bit offset was also given. */ bit = cv_dec_check_ (bit_offset, code); /* Convert/validate bit offset. */ if code ^= 0 then do; code = error_table_$bad_conversion; call ERROR; end; if (0 <= bit) & (bit <= 35) then; else do; code = error_table_$out_of_bounds; call ERROR; end; P = addr (P -> bits (bit+1)); /* Apply the bit offset. */ end; end; RETURN_TO_CALLER: if ^inner_ring_segment then call hcs_$terminate_noname (segp, (0)); return (P); /* return the pointer. */ ERROR: proc; Acode = code; P = null; /* return a null pointer, with the error code. */ goto RETURN_TO_CALLER; end ERROR; end cv_ptr_; %page; %include definition; %page; %include object_info; %page; %include terminate_file; %page; %include access_mode_values; end dump_segment;  enter_retrieval_request.pl1 10/17/88 1532.7r w 10/17/88 1427.1 97443 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ enter_retrieval_request: err: proc; /* This command submits retrieval requests to the volume retriever. It queues these requests in one of three queues which the caller may specify(the default queue is 3) in a the directory >daemon_dir_dir>volume_backup(except in the test entry case). At some latter time operations will log in the retriever and process the requests. */ /* Modified by D. Vinograd to improve argument and access checks, use system msg header, and support msg ids. Modified: August 1983 by GA Texada to fix -to bug (phx13941 phx14299). */ dcl code fixed bin (35); dcl ms_count fixed bin; dcl long_id bit (1); dcl brief bit (1); dcl to_specified bit (1); dcl rqid char (19); dcl narg fixed bin; dcl type fixed bin (2); dcl (bmode, pmode) fixed bin (5); dcl i fixed bin; dcl ac fixed bin; dcl argp ptr; dcl argl fixed bin; dcl test_dir char (*); dcl arg char (argl) based (argp); dcl clock_value fixed bin (71); dcl prev_arg char (32); dcl queue_seg char (32) ; dcl q fixed bin; dcl dates_array (5) bit (36); dcl myname char (32) static int init ("enter_retrieval_request") options (constant); dcl retrieval fixed bin int static init (4) options (constant); dcl vdtd fixed bin static init (5); dcl dtm fixed bin static init (2); dcl 1 local_retv_request aligned like retv_request; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$nostars ext fixed bin (35); dcl message_segment_$get_message_count_file entry (char (*), char (*), fixed bin, fixed bin (35)); dcl request_id_ entry (fixed bin (71)) returns (char (19)); dcl get_ring_ entry returns (fixed bin); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$get_dates entry (char (*) aligned, char (*) aligned, (5) bit (36), fixed bin (35)); dcl com_err_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl ioa_ entry options (variable); dcl message_segment_$add_file entry (char (*), char (*), ptr, fixed bin, bit (36), fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl check_star_name_$entry entry (char (*) aligned, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl addr builtin; dcl fixed builtin; dcl clock builtin; dcl substr builtin; dcl size builtin; dcl bit builtin; %include queue_msg_hdr; %include retv_request; %include retv_data_; %include status_structures; requestp = addr (local_retv_request); /* initialize */ long_id = "0"b; brief = "0"b; to_specified = "0"b; retv_request.bits = "0"b; retv_request.fixed_bin = 0; retv_request.chars = ""; retv_request.version = retv_request_version_2; retv_request.msg_time = clock; retv_request.hdr_version = queue_msg_hdr_version_1; retv_request.message_type = retrieval; retv_request.std_length = size (retv_request); retv_request.bit_flags = "0"b; retv_request.orig_queue = 3; retv_request.state = STATE_UNPROCESSED; call cu_$arg_ptr (1, argp, argl, code); /* get pathname of object/node */ if code ^= 0 then do; argerr: call com_err_ (0, myname, " Usage is ^a pathname [-subtree] [-from time] [-to time] [-notify] [-queue q] [-new_path pathname] [-multi_segment_file]", myname); goto finish; end; if substr (arg, 1, 1) = "-" then goto argerr; call expand_pathname_ (arg, retv_request.dirname, retv_request.ename, code); if code ^= 0 then do; expand_err: call com_err_ (code, myname, "^a", arg); goto finish; end; call check_star_name_$entry (retv_request.ename, code); if code ^= 0 then do; call com_err_ (error_table_$nostars, myname, " Use -subtree."); goto finish; end; call check_access ((retv_request.dirname), (retv_request.ename)); ac = 1; call cu_$arg_count (narg); do while (ac < narg); ac = ac + 1; call cu_$arg_ptr (ac, argp, argl, code); if code ^= 0 then do; no_next_arg: call com_err_ (code, myname, "Unable to access argument after ^a", arg); return; end; if arg = "-previous" | arg = "-prev" then retv_request.previous = "1"b; else if arg = "-long_id" then long_id = "1"b; else if arg = "-brief" | arg = "-bf" then brief = "1"b; else if arg = "-subtree" | arg = "-subt" | arg = "-multi_segment_file" | arg = "-msf" then retv_request.subtree = "1"b; else if arg = "-notify" | arg = "-nt" then retv_request.notify = "1"b; else if arg = "-to" | arg = "-from" | arg = "-fm" then do; prev_arg = arg; ac = ac + 1; call cu_$arg_ptr (ac, argp, argl, code); if code ^= 0 then goto no_next_arg; call convert_date_to_binary_ (arg, clock_value, code); if code ^= 0 then do; call com_err_ (code, myname, "^a", arg); goto finish; end; if clock_value > clock then do; call com_err_ (0, myname, "Date ^a is in the future", arg); return; end; if prev_arg = "-to" then do; to_specified = "1"b; retv_request.to_time = clock_value; end; else retv_request.from_time = clock_value; end; else if arg = "-queue" | arg = "-q" then do; ac = ac + 1; call cu_$arg_ptr (ac, argp, argl, code); if code ^= 0 then goto no_next_arg; q = cv_oct_check_ (arg, code); if code ^= 0 | (q > 3 | q < 1) then do; call com_err_ (0, myname, "Invalid queue number ^a", arg); goto finish; end; retv_request.orig_queue = q; end; else if arg = "-new_path" then do; ac = ac + 1; call cu_$arg_ptr (ac, argp, argl, code); if code ^= 0 then goto no_next_arg; call expand_pathname_ (arg, retv_request.new_dirname, retv_request.new_ename, code); if code ^= 0 then goto expand_err; call hcs_$status_minf ((retv_request.dirname), (retv_request.ename), 1, type, 0, code); if code ^= 0 then do; call com_err_ (code, myname, "Unable to cross retrieve object."); goto finish; end; if type = Directory then do; call com_err_ (0, myname, "Directory cross retrieval not allowed."); goto finish; end; call hcs_$get_user_effmode ((retv_request.dirname), (retv_request.ename), "", get_ring_ (), bmode, code); if (bit (bmode) & "01010"b) ^= "01010"b then do; call com_err_ (0, myname, "Incorrect access to segment ^a>^a to cross retrieve.", retv_request.dirname, retv_request.ename); goto finish; end; call hcs_$get_user_effmode ((retv_request.new_dirname), "", "", get_ring_ (), pmode, code); if (bit (pmode) & "01010"b) ^= "01010"b then do; call com_err_ (0, myname, "Incorrect access to append to new path ^a.", retv_request.new_dirname); goto finish; end; end; else do; call com_err_ (error_table_$badopt, myname, "^a", arg); goto finish; end; end; if retv_request.previous & (to_specified | retv_request.from_time ^= 0) then do; call com_err_ (0, myname, "-previous control arg not allowed with -from and or -to"); goto finish; end; if to_specified then if retv_request.to_time < retv_request.from_time then do; call com_err_ (0, myname, "-to DATE preceeds -from DATE"); goto finish; end; dates_array (*) = "0"b; call hcs_$get_dates (retv_request.dirname, retv_request.ename, dates_array, code); if code ^= 0 then do; if retv_request.previous then do; call com_err_ (code, myname, "Unable to obtain data about ^a>^a for -previous control arg", retv_request.dirname, retv_request.ename); goto finish; end; end; else do; if (dates_array (dtm) >= dates_array (vdtd)) then do; if (retv_request.previous | retv_request.from_time ^= 0 | to_specified) then ; else do; call com_err_ (0, myname, "More recent copy online. Use -previous or -from or -to if you desire dump copy."); goto finish; end; if ^to_specified then retv_request.to_time = fixed (dates_array (dtm) || (16) "0"b, 71); end; else if dates_array (vdtd) >= dates_array (dtm) then do; if ^to_specified then if retv_request.previous then retv_request.to_time = fixed (dates_array (dtm) || (16) "0"b, 71); end; end; if ^retv_request.previous & ^to_specified then retv_request.to_time = clock; call ioa_$rsnnl ("volume_retriever_^d.ms", queue_seg, i, retv_request.orig_queue); /* select queue and put message in queue */ call message_segment_$add_file (queue_dir, queue_seg, requestp, size (retv_request) * 36, "0"b, code); if code ^= 0 then do; call com_err_ (code, myname, "Unable to queue retrieval request."); goto finish; end; if ^brief then do; rqid = request_id_ (retv_request.msg_time); if ^long_id then rqid = substr (rqid, 7, 8); call message_segment_$get_message_count_file (queue_dir, queue_seg, ms_count, code); ms_count = max (0, ms_count-1); call ioa_ ("ID: ^a^[;^x^d already requested.^]", rqid, (code = 0), ms_count); end; finish: return; test: entry (test_dir); queue_dir = test_dir; return; check_access: proc (dirname, ename); dcl (dirname, ename) char (*); dcl tdirname char (168) aligned; dcl tename char (32) aligned; call hcs_$status_minf (dirname, ename, 1, type, 0, code); if code ^= 0 then do; call expand_pathname_ (dirname, tdirname, tename, code); if code ^= 0 then do; call com_err_ (0, myname, "Unable to determine access to object."); goto finish; end; if tename = "" & tdirname = ">" then do; goto no_acc; end; call check_access ((tdirname), (tename)); end; call hcs_$get_user_effmode (dirname, ename, "", get_ring_ (), bmode, code); call hcs_$get_user_effmode (dirname, "", "", get_ring_ (), pmode, code); if (bit (bmode) & "01010"b) = "01010"b | (bit (pmode) & "01010"b) = "01010"b then return; else do; no_acc: call com_err_ (0, myname, "Incorrect access to retrieve object ^a^[>^]^a.", retv_request.dirname, retv_request.dirname ^= ">", retv_request.ename); goto finish; end; end check_access; end enter_retrieval_request;  exponent_control.pl1 11/04/82 1951.6rew 11/04/82 1627.8 60147 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* exponent_control Command interface for fim exponent flags */ exponent_control: procedure options (variable); /* Date Changed (and reason) */ /* Coded February 28 1980 Benson I. Margulies */ dcl hcs_$get_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned); dcl hcs_$set_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned, fixed bin (35)); dcl cu_$arg_count entry () returns (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl com_err_ entry options (variable); dcl ioa_ entry options (variable); dcl arg_ptr ptr; dcl arg_len fixed bin (21); dcl argument char (arg_len) based (arg_ptr); dcl nargs fixed bin; dcl current_argument fixed bin; dcl code fixed bin (35); dcl (looking_for, processing) fixed bin; dcl print_sw bit (1) aligned; dcl put_reqd bit (1) aligned; dcl happy bit (1) aligned; /* no further arguments required */ dcl (restart_underflow, restart_overflow) bit (1) aligned; dcl overflow_value float bin (63); dcl (error_table_$bad_conversion, error_table_$bad_arg, error_table_$inconsistent, error_table_$noarg) static external fixed bin (35); dcl conversion condition; dcl ((Control_argument init (1), Keyword init (2), Control_argument_or_keyword init (3), Value_or_control_argument init (4), Restart init (5), Fault init (6), Value init (7)) fixed bin, /* not really used at the moment */ Myname init ("exponent_control") character (16)) internal static options (constant); %include exponent_control_info; dcl (convert, unspec) builtin; /* */ call GET_CURRENT_VALUES; /* almost always the command needs them */ nargs = cu_$arg_count (); if nargs = 0 then do; call com_err_ (error_table_$noarg, Myname, "^/Usage: exponent_control {-pr}|{-rt|-flt overflow|underflow} {-ovfv value}"); return; end; happy = ""b; put_reqd, print_sw = ""b; looking_for = Control_argument; do current_argument = 1 to nargs; call get_argument; if /* case */ looking_for = Control_argument_or_keyword then if substr (argument, 1, 1) = "-" then goto CONTROL_ARG; else goto KEYWORD; else if looking_for = Value_or_control_argument then if substr (argument, 1, 1) = "-" then goto CONTROL_ARG; else goto VALUE; else if looking_for = Control_argument then do; if substr (argument, 1, 1) ^= "-" then do; call com_err_ (error_table_$bad_arg, Myname, "Unknown or misplaced keyword ^a.", argument); goto ERROR; end; CONTROL_ARG: if argument = "-restart" | argument = "-rt" then call process_restart; else if argument = "-fault" | argument = "-flt" then call process_fault; else if argument = "-overflow_value" | argument = "-ovfv" then call process_value; else if argument = "-print" | argument = "-pr" then call process_print; else do; call com_err_ (error_table_$bad_arg, Myname, "unrecognized control argument ^a.", argument); goto ERROR; end; end; else if looking_for = Keyword then do; KEYWORD: looking_for = Control_argument_or_keyword; happy = "1"b; /* having found a keyword nothing else required */ if argument = "overflow" then if processing = Restart then restart_overflow = "1"b; else restart_overflow = "0"b; else if argument = "underflow" then if processing = Restart then restart_underflow = "1"b; else restart_underflow = "0"b; else do; call com_err_ (error_table_$bad_arg, Myname, "Unrecognized keyword ^a.", argument); goto ERROR; end; end; else if looking_for = Value then do; VALUE: looking_for = Control_argument; happy = "1"b; on conversion begin; call com_err_ (error_table_$bad_conversion, Myname, "Could not convert ^a to a floating point value.", argument); goto ERROR; end; overflow_value = convert (overflow_value, argument); end; end; if ^happy then do; call com_err_ (error_table_$noarg, Myname, "The ^a control argument requires a value.", argument); goto ERROR; end; if print_sw & put_reqd then do; /* can't do both */ call com_err_ (error_table_$inconsistent, Myname, "Can't print while setting any value."); return; end; else if print_sw then call ioa_ ("Underflows are ^[restart^;fault^]ed;^/Overflows are ^[restart^;fault^]ed;^/Overflow value is ^f.", restart_underflow, restart_overflow, overflow_value); else call PUT_CURRENT_VALUES; return; GET_CURRENT_VALUES: procedure; dcl overflow_bits bit (72) aligned; call hcs_$get_exponent_control (restart_underflow, restart_overflow, overflow_bits); unspec (overflow_value) = overflow_bits; return; PUT_CURRENT_VALUES: entry; overflow_bits = unspec (overflow_value); call hcs_$set_exponent_control (restart_underflow, restart_overflow, overflow_bits, code); if code ^= 0 then do; call com_err_ (code, Myname, "When setting new values."); goto ERROR; end; return; end; /* */ process_restart: procedure; happy = ""b; looking_for = Keyword; processing = Restart; put_reqd = "1"b; return; end; process_fault: procedure; happy = ""b; looking_for = Keyword; processing = Fault; put_reqd = "1"b; return; end; process_value: procedure; happy = "1"b; /* we have a default */ overflow_value = Default_exponent_control_overflow_value; looking_for = Value_or_control_argument; put_reqd = "1"b; return; end; process_print: procedure; happy = "1"b; looking_for = Control_argument; print_sw = "1"b; return; end; get_argument: procedure; if current_argument > nargs then do; call com_err_ (error_table_$noarg, Myname, "following ^a.", argument); goto ERROR; end; call cu_$arg_ptr (current_argument, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (code, Myname, "Error on argument # ^d.", current_argument); goto ERROR; end; return; end; ERROR: return; /* regardless of where in the internal procs */ end;  exponent_control_.pl1 09/24/92 2252.7r w 09/24/92 2234.7 31725 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(91-10-25,Schroth), approve(91-11-28,MECR0015), audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001): Correct MR12.4 source code corruption. 2) change(92-05-14,Schroth), approve(91-11-25,MCR8251), audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016): Replace MECR0015: Correct MR12.4 source code corruption. END HISTORY COMMENTS */ /* exponent_control_ subroutine interface to exponent control flags */ exponent_control_: proc; return; /* Date Changed (and reason) */ /* Coded February 28 1980 Benson I. Margulies */ dcl hcs_$get_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned); dcl hcs_$set_exponent_control entry (bit (1) aligned, bit (1) aligned, bit (72) aligned, fixed bin (35)); dcl (restart_underflow, restart_overflow) bit (1) aligned; dcl overflow_value float bin (63); dcl (a_code, code) fixed bin (35); dcl bool_mask bit (3) aligned; dcl bool_op bit (4) aligned; %include exponent_control_info; /* */ fault_underflow: entry (a_code); bool_mask = "010"b; /* ^underflow, overflow, ^value */ goto FAULT_COMMON; fault_overflow: entry (a_code); bool_mask = "100"b; /* underflow, ^overflow, ^value */ FAULT_COMMON: bool_op = "1"b4; /* and */ goto COMMON; restart_underflow: entry (a_code); bool_mask = "100"b; /* underflow, ^overflow, ^value */ goto RESTART_COMMON; restart_overflow: entry (a_code); bool_mask = "010"b; /* ^underflow, overflow, ^value */ goto RESTART_COMMON; restart_overflow_value: entry (New_value, a_code); dcl New_value float bin (63) parameter; bool_mask = "011"b; /* ^underflow, overflow, value */ RESTART_COMMON: bool_op = "7"b4; /* or */ COMMON: call GET_CURRENT_VALUES; restart_underflow = bool (restart_underflow, substr (bool_mask, 1, 1), bool_op); restart_overflow = bool (restart_overflow, substr (bool_mask, 2, 1), bool_op); if bool_op = "7"b4 then /* setting restart flags */ if substr (bool_mask, 2, 1) then /* overflow flag */ if substr (bool_mask, 3, 1) then /* value flag */ overflow_value = New_value; else overflow_value = Default_exponent_control_overflow_value; call PUT_CURRENT_VALUES; a_code = 0; return; /* */ GET_CURRENT_VALUES: procedure; dcl overflow_bits bit (72) aligned; call hcs_$get_exponent_control (restart_underflow, restart_overflow, overflow_bits); unspec (overflow_value) = overflow_bits; return; PUT_CURRENT_VALUES: entry; overflow_bits = unspec (overflow_value); call hcs_$set_exponent_control (restart_underflow, restart_overflow, overflow_bits, code); if code ^= 0 then do; a_code = code; goto exit; end; return; end; exit: return; end;  fdoc_et_.alm 11/05/86 1236.3r w 11/04/86 1038.0 17361 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1983 * " * * " *********************************************************** " FDOC_ET_ - Status code table for format_document_ " Written 83-03-24 by Paul W. Benjamin " Modified 83-06-09 by PWB to add no_hyphenate_word. " Modified 83-11-22 by PWB to add no_sign_allowed. " maclist off macro maclist &end include et_macros et fdoc_et_ ec indent_too_far_left,indtflft, (Attempt to indent past left margin, resetting to left margin.) ec indent_too_far_right,indtfrgt, (Attempt to indent past right margin, resetting to right margin.) ec line_length_too_small,lnlntsml, (Effective line length less than 1, quitting.) ec line_too_long,lntoolng, (Located a string of more than 256 characters without blank or newline.) ec no_hyphenate_word,nohypwrd, (Hyphenation has been requested but no hyphenate_word_ found.) ec no_parameter_allowed,noparalw, (This control supports no parameters.) ec no_sign_allowed,nosngalw, (This control does not allow signed paramaters.) ec nonnumeric_parameter,nonumpar, (Non-numeric parameter.) ec page_length_lt_13,pglnlt13, (Given page length too small, resetting to current minimum of 13.) ec page_length_lt_14,pglnlt14, (Given page length too small, resetting to current minimum of 14.) ec page_width_exceeds_max,pgwdxmax, (Computed page width too large, resetting to specified maximum.) ec text_too_long_for_line,txttulng, (Text too long for output line.) ec undent_too_far_left,undtflft, (Attempt to undent past left margin, resetting to left margin.) ec undent_too_far_right,undtfrgt, (Attempt to undent past right margin, resetting to right margin.) ec unsupported_control,unsupctl, (Unsupported control.) end  format_document_.pl1 10/06/92 0049.2r w 10/06/92 0045.0 479691 /****^ *********************************************************** * * * Copyright, (C) BULL HN Information Systems Inc., 1990 * * * * Copyright, (C) Honeywell Information Systems Inc., 1981 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(90-03-14,Kallstrom), approve(90-03-27,MCR8150), audit(90-04-03,Zimmerman), install(90-04-11,MR12.4-1003): Added an rtrim after CRs and VTs are removed. 2) change(92-09-14,Vu), approve(92-09-14,MCR8260), audit(92-09-23,Zimmerman), install(92-10-06,MR12.5-1024): format_document_ looses characters and generates unwanted new paragraph. END HISTORY COMMENTS */ format_document_: proc (dnamin, enamin, dnamout, enamout, optptr, code); /* subroutine to format text a la compose and runoff. Used by format_document (fdoc) command. There are 3 entries: format_document_ takes input and output pathnames. format_document_$string takes input and output strings. format_document_$switch takes input pathname and writes to an i/o switch. Command written 79.01.12 by Paul W. Benjamin. Subroutine interface added 80.02.14 by PWB. Re-Written 81.02.10 by PWB. Modified 81.04.20 by PWB to supress compression of leading spaces. Modified 81.04.20 by PWB to fix bug where page numbers not centered properly. Modified 81.06.26 by PWB to fix 2 more bugs relating to leading spaces. Modified 81.08.14 by PWB to fix bug where extra NL written to end when store is empty. Modified 81.10.22 by PWB to avoid storage condition when compressing blanks in long (truncated to 508 chars) strings. Modified 81.10.22 by PWB to fix bug where lines beginning with ". " or ".." interpreted as undent controls (!) Modified 82.07.16 by PWB to initially null 3 pointers before checking version Modified 82.07.16 by PWB to remove nonlocal goto on cleanup. Modified 82.09.02 by PWB to prevent backing up into left margin when looking looking for a place to break an overlength line. Modified 82.10.18 by PWB to add support for dont_compress_sw. Modified 83.02.15 by PWB to add support for break_word_sw and max_line_length_sw. Modified 83.02.22 by PWB to stop truncating input lines at 508 chars. Modified 83.03.01 by PWB to implement dont_break_indented_lines_sw. Modified 83.03.03 by PWB to implement sub_err_sw. Modified 83.06.07 by PWB to implement dont_fill_sw. Modified 83.06.08 by PWB to implement hyphenation. Modified 83.08.30 by PWB to fix bug where words that were larger than the line length didn't get hyphenated. Modified 83.11.17 by PWB to have dont_break_indented_lines imply "don't do compression or sentence formatting on indented lines, either." Modified 83.11.23 by PWB to add the names: .inl to .in, .unl to .un and to add the .spf control. Modified 83.11.28 by PWB for various minor changes in response to audit. Modified 83.12.01 by PWB to add .brf and .brp. Modified 84.01.24 by PWB to fix bug introduced in MR10.2 that caused callers using version_1 to possibly have random values for the option switches that were new in that release. Modified 84.02.08 by PWB to apply defaults for dont_compress, break_word, dont_break_indented_lines, sub_err, dont_fill and hyphenation for version_1 callers. */ /* parameters */ dcl code fixed bin (35) parameter; /* output system status code */ dcl dnamin char (*) parameter; /* input file directory */ dcl dnamout char (*) parameter; /* output file directory */ dcl enamin char (*) parameter; /* input file name */ dcl enamout char (*) parameter; /* output file name */ dcl instring char (*) parameter; /* input string for string entry */ dcl iocbptr ptr parameter; /* output switch for switch entry */ dcl optptr ptr parameter; /* input ptr to options structure */ dcl outlen fixed bin (21) parameter; /* output string length for string entry */ dcl outstring char (*) parameter; /* output string for string entry */ /* entries */ dcl canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35)); dcl convert_status_code_ entry (fixed bin(35), char(8) aligned, char(100) aligned); dcl cv_dec_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35)); dcl hyphenate_word_ entry (char(*), fixed bin, fixed bin, fixed bin(35)); dcl ioa_$rs entry() options(variable); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl msf_manager_$close entry (ptr); dcl msf_manager_$get_ptr entry (ptr, fixed bin, bit(1), ptr, fixed bin(24), fixed bin(35)); dcl msf_manager_$open entry (char(*), char(*), ptr, fixed bin(35)); dcl sub_err_ entry() options(variable); dcl tssi_$finish_file entry (ptr, fixed bin, fixed bin(24), bit(36) aligned, ptr, fixed bin(35)); dcl tssi_$get_file entry (char(*), char(*), ptr, ptr, ptr, fixed bin(35)); /* external static */ dcl error_table_$smallarg fixed bin(35) ext static; dcl error_table_$fatal_error external static fixed bin (35); dcl error_table_$improper_data_format external static fixed bin(35); dcl error_table_$noentry fixed bin(35) ext static; dcl error_table_$recoverable_error fixed bin(35) ext static; dcl error_table_$unimplemented_version external static fixed bin(35); dcl error_table_$zero_length_seg fixed bin(35) ext static; dcl fdoc_et_$indent_too_far_left fixed bin(35) ext static; dcl fdoc_et_$indent_too_far_right fixed bin(35) ext static; dcl fdoc_et_$line_length_too_small fixed bin(35) ext static; dcl fdoc_et_$line_too_long fixed bin(35) ext static; dcl fdoc_et_$no_hyphenate_word fixed bin(35) ext static; dcl fdoc_et_$no_parameter_allowed fixed bin(35) ext static; dcl fdoc_et_$no_sign_allowed fixed bin(35) ext static; dcl fdoc_et_$nonnumeric_parameter fixed bin(35) ext static; dcl fdoc_et_$page_length_lt_13 fixed bin(35) ext static; dcl fdoc_et_$page_length_lt_14 fixed bin(35) ext static; dcl fdoc_et_$page_width_exceeds_max fixed bin(35) ext static; dcl fdoc_et_$text_too_long_for_line fixed bin(35) ext static; dcl fdoc_et_$undent_too_far_left fixed bin(35) ext static; dcl fdoc_et_$undent_too_far_right fixed bin(35) ext static; dcl fdoc_et_$unsupported_control fixed bin(35) ext static; dcl iox_$error_output ptr ext static; dcl sys_info$max_seg_size fixed bin (19) ext static; /* automatic */ dcl aclinfoptr ptr; /* required for tssi_$get_file */ dcl adj_line_out char (508) varying; /* temporary output line for adjust_line proc */ dcl adjust bit (1) aligned; /* ON = in adjust mode */ dcl bc fixed bin (24); /* required for various calls */ dcl blank_lines_to_be_written fixed bin; /* user used .spf N and this has value N */ dcl breaking_words bit (1) aligned; /* user specified break_word_sw */ dcl bsndx fixed bin; /* index of backspace in line */ dcl bsndx1 fixed bin; /* used when incrementing bsndx */ dcl bscnt fixed bin; /* number of backspaces in line */ dcl buf char (256) varying; /* input buffer */ dcl buf_len21 fixed bin (21); /* length of buf -- needed for call to canonicalize_ */ dcl char_cnt fixed bin (21); /* position of next char to be written */ dcl component_ends_wo_NL bit; /* ON = component ends without a newline */ dcl continued_line bit (1); dcl ctl char (5); /* user specified control */ dcl ctl_index fixed bin; /* index of ctl into ctl_list */ dcl current_syllable_size fixed bin; /* syllable size as currently adjusted */ dcl default_syllable_size fixed bin; /* syllable size as originally specified */ dcl dont_break_indented_lines bit (1) aligned; /* user specified dont_break_indented_lines_sw */ dcl dont_compress bit (1) aligned; /* user specified dont_compress_sw */ dcl elen fixed bin (21); /* length of error message */ dcl error bit (1) aligned; /* ON = an error has occurred */ dcl error_lines char (508); /* error message */ dcl errtxt char (100) aligned; /* output from convert_status_code_ */ dcl fill bit (1) aligned; /* ON = fill mode */ dcl filout bit (1) aligned; /* ON = main entry or string entry */ dcl fit bit (1) aligned; /* used in bs_rtn: can use portion of line as is */ dcl galley_mode bit (1) aligned; /* user specified galley_sw */ dcl h fixed bin; /* index for do-group */ dcl hyph_len fixed bin (21); /* length of based variable hyph_word */ dcl hyph_point fixed bin; /* where to hyphenate, output from hyphenate_word_ */ dcl hyph_ptr ptr; /* pointer to based variable hyph_word */ dcl hyph_space fixed bin; /* how much space in which to hyphenate */ dcl hyphenating bit (1) aligned; /* caller has requested hyphenation */ dcl hyphenation_routine_state fixed bin; /* = 0 hyphenate_word_ not looked for yet */ /* = 1 hyphenate_word_ found */ /* = 2 hyphenate_word_ not found */ dcl hyphenate_entry entry variable; /* dummy entry to test for linkage error */ dcl i fixed bin; /* index for do-group */ dcl in_comp_no fixed bin; /* current input component number */ dcl ind fixed bin; /* current indentation value */ dcl ind_minus_und fixed bin; /* current calculation of ind - und */ dcl indptr ptr; /* ptr to initial indentation string */ dcl infcbptr ptr; /* ptr to fcb for input file */ dcl initial_ind fixed bin; /* initial indentation value */ dcl initial_inlen fixed bin (21); /* length of input component */ dcl initial_inptr ptr; /* pointer to beginning of input component */ dcl initial_line_length fixed bin; /* user specified line_length */ dcl initial_outptr ptr; /* pointer to beginning of output component */ dcl inlen fixed bin (21); /* length of remainder of input component */ dcl inplnctr fixed; /* current line in input file */ dcl inptr ptr; /* current position in input file */ dcl ioxbuf char (508); /* output buffer for switch entry */ dcl j fixed bin; /* index for do-group */ dcl k fixed bin; /* index for do-group */ dcl last_blank fixed bin; /* position of blank in line for bs_rtn */ dcl left bit (1) aligned; /* ON = start adjusting from left side */ dcl line_began_with_blank bit (1) aligned; /* exactly what it says */ dcl literal_mode bit (1) aligned; /* user specified literal_sw */ dcl ll fixed bin; /* current linelength */ dcl lnctr fixed bin; /* output line counter */ dcl long_line_and_no_blank bit (1) aligned; /* used in bs_rtn when having problems breaking line */ dcl maxcnt fixed bin (21); /* position of first character past end of segment */ dcl maximum_line_length bit (1) aligned; /* user specified max_line_length_sw */ dcl new_adjust bit (1) aligned; /* new value for adjust */ dcl new_fill bit (1) aligned; /* new value for fill */ dcl new_ind fixed bin; /* new value for ind */ dcl new_und fixed bin; /* new value for und */ dcl nlindex fixed bin; /* index of next newline in input component */ dcl out_comp_no fixed bin; /* current output component number */ dcl outline char (508) varying; /* line to be written out */ dcl outfcbptr ptr; /* ptr to fcb for output file */ dcl outptr ptr; /* ptr to next character position in output file */ dcl outstringlen fixed bin (21); /* length of output string for string entry */ dcl pads fixed; /* number of spaces for adjust_line to fill in */ dcl param char (100) varying; /* parameter to ctl */ dcl paramfb fixed bin; /* fixed bin version of param */ dcl pgctr fixed bin; /* last output page number */ dcl pgctra char (10) varying; /* ascii representation of pgctr */ dcl pgno bit; /* ON = end page with centered page number */ dcl pl fixed bin; /* current output page length */ dcl retval fixed bin (35); /* meaningless but required by sub_err_ */ dcl signed bit; /* ON = param has optional leading sign */ dcl space_available fixed bin; /* characters remaining in output string or component */ dcl space_pos (100) fixed; /* where adjust_line keeps track of spaces in line */ dcl spaces fixed; /* number of spaces in line found by adjust_line */ dcl spindex fixed bin; /* index of space in line */ dcl spindex1 fixed bin; /* used when incrementing spindex */ dcl store char (508) varying; /* characters read but not yet written */ dcl string_entry bit; /* ON = entry via format_document_$string */ dcl subcode fixed bin (35); /* used in call to sub_err_ */ dcl tabfill fixed bin; /* number of spaces needed to replace tab */ dcl tabndx fixed bin; /* index of first tab in line */ dcl temp_code fixed bin (35); /* temporary code used at cleanup time */ dcl tlen fixed bin; /* length of text in write_file */ dcl trash char (8) aligned; /* unused output from convert_status_code_ */ dcl und fixed bin; /* current undentation value */ dcl using_sub_err bit (1) aligned; /* user asked for the usage of sub_err_ */ dcl vlen fixed bin; /* virtual length (width) of line */ dcl vtabndx fixed bin; /* virtual position of tab in line */ dcl 1 error_info like format_document_error; /* based */ dcl hyph_word char (hyph_len) based (hyph_ptr); /* word passed to hyphenate_word_ */ dcl indstr char (initial_ind) based (indptr); /* initial indentation string */ dcl in_chars (inlen + 2) char (1) based (inptr); /* infile: one char at a time */ /* (the +2 is to avoid a subscriptrange) */ dcl infile char (inlen) based (inptr); /* remainder of input component */ dcl initial_in_chars (initial_inlen) char (1) based (initial_inptr); /* input component */ dcl out_chars (sys_info$max_seg_size * 4) char (1) based (initial_outptr); /* output component */ dcl outfile char ((sys_info$max_seg_size * 4) + 1 - char_cnt) based (outptr); /* remainder of output component */ dcl 1 buf_structure based (addr (buf)), /* to look at buf as non-varying */ 2 buf_len fixed bin (35), 2 buf_chars (256) char (1); dcl 1 store_structure based (addr (store)), /* to look at store one character at a time */ 2 store_len fixed bin (35), 2 store_char (508) char (1); /* internal static */ dcl BS char (1) internal static options (constant) init (""); dcl BS_or_HT char (2) internal static options (constant) init (" "); dcl BS_or_HT_or_SP char (3) internal static options (constant) init (" "); dcl BUFFER_SIZE fixed internal static options (constant) init (256); dcl BUFFER_SIZE_PLUS_ONE fixed internal static options (constant) init (257); dcl CR char (1) internal static options (constant) init (" "); dcl CR_or_VT char (2) internal static options (constant) init (" "); dcl DEFAULT_LINE_LENGTH fixed internal static options (constant) init (65); dcl DEFAULT_PAGE_LENGTH fixed internal static options (constant) init (66); dcl FF char (1) internal static options (constant) init (" "); dcl HT char (1) internal static options (constant) init (" "); dcl HT_or_SP char (2) internal static options (constant) init (" "); dcl HT_or_NL_or_SP char (3) internal static options (constant) init (" "); dcl HYPHEN char (1) internal static options (constant) init ("-"); dcl NL char (1) internal static options (constant) init (" "); dcl VT char (1) internal static options (constant) init (" "); dcl ctl_list char (83) internal static options (constant) init (" .un .in .alb.all.fin.fif.pdw.pdl.hy .hyf.hyn.inl.unl.spf. .. ... .....brf.brp"); /* builtins */ dcl (addr, after, before, char, copy, decat, divide, index, length, ltrim, mod, null, reverse, rtrim, search, substr, translate, verify) builtin; /* condition */ dcl (cleanup, linkage_error) condition; /* include file */ %include format_document_options; %include format_document_error; %include sub_err_flags; /* program */ /* main entry -- format_document_ */ error = "0"b; indptr = null (); infcbptr = null (); outfcbptr = null (); format_document_options_ptr = optptr; format_document_options.file_sw = "0"b; call check_version_and_set_options; if format_document_options.switches.mbz ^= "0"b then do; code = error_table_$improper_data_format; goto done; end; filout = "1"b; string_entry = "0"b; on cleanup call done_proc; call msf_manager_$open (dnamin, enamin, infcbptr, code); if code ^= 0 then goto done; call msf_manager_$get_ptr (infcbptr, 0, "0"b, inptr, bc, code); if inptr = null () then goto done; if bc = 0 then do; code = error_table_$zero_length_seg; goto done; end; inlen = divide (bc, 9, 21, 0); call tssi_$get_file (dnamout, enamout, outptr, aclinfoptr, outfcbptr, code); if code ^= 0 then do; format_document_options.file_sw = "1"b; goto done; end; out_comp_no = 0; initial_outptr = outptr; code = 0; goto process; string: entry (instring, outstring, outlen, optptr, code); error = "0"b; indptr = null (); infcbptr = null (); outfcbptr = null (); format_document_options_ptr = optptr; format_document_options.file_sw = "0"b; call check_version_and_set_options; if format_document_options.switches.mbz ^= "0"b then do; code = error_table_$improper_data_format; goto done; end; code = 0; filout = "1"b; inlen = length (instring); inptr = addr (instring); outptr, initial_outptr = addr (outstring); outstringlen = length (outstring); string_entry = "1"b; on cleanup call done_proc; goto process; switch: entry (dnamin, enamin, iocbptr, optptr, code); error = "0"b; indptr = null (); infcbptr = null (); outfcbptr = null (); format_document_options_ptr = optptr; format_document_options.file_sw = "0"b; call check_version_and_set_options; if format_document_options.switches.mbz ^= "0"b then do; code = error_table_$improper_data_format; goto done; end; filout = "0"b; string_entry = "0"b; on cleanup call done_proc; call msf_manager_$open (dnamin, enamin, infcbptr, code); if code ^= 0 then goto done; call msf_manager_$get_ptr (infcbptr, 0, "0"b, inptr, bc, code); if inptr = null () then goto done; if bc = 0 then do; code = error_table_$zero_length_seg; goto done; end; inlen = divide (bc, 9, 21, 0); code = 0; process: char_cnt = 1; component_ends_wo_NL = "0"b; continued_line = "0"b; current_syllable_size = default_syllable_size; hyphenation_routine_state = 0; in_comp_no = 0; ind = 0; ind_minus_und = 0; inplnctr = 0; left = "1"b; lnctr = 0; maxcnt = (sys_info$max_seg_size * 4) + 1; pgctr = 0; pl = DEFAULT_PAGE_LENGTH; store = ""; und = 0; if hyphenating then call look_for_hyphenation_routine; allocate indstr; indstr = copy (" ", initial_ind); process_one_component: initial_inlen = inlen; initial_inptr = inptr; do while (inlen > 0); /* while there is more input */ nlindex = index (infile, NL); inplnctr = inplnctr + 1; continued_line = "0"b; if nlindex = 0 then nlindex = inlen + 1; if nlindex > BUFFER_SIZE_PLUS_ONE /* line longer than internal buffer */ then do; /* find someplace to break it */ continued_line = "1"b; if length (rtrim (substr (infile, 1, nlindex - 1), HT_or_SP)) <= BUFFER_SIZE /* line merely had a lot of trailing blanks */ then buf = rtrim (substr (infile, 1, nlindex - 1), HT_or_SP); else do; spindex = BUFFER_SIZE_PLUS_ONE - index (reverse (substr (infile, 1, BUFFER_SIZE_PLUS_ONE)), " "); if spindex ^= BUFFER_SIZE_PLUS_ONE /* and break it there */ then do; buf = rtrim (substr (infile, 1, spindex), HT_or_SP); nlindex = spindex + 1; end; else if breaking_words then do; buf = substr (infile, 1, ll); nlindex = ll; end; else do; /* no place to break it */ if store_len ^= 0 /* write out store if not empty */ then do; store = copy (" ", ind_minus_und) || store; call write (store); store = ""; end; call err_reporter (fdoc_et_$line_too_long); /* report as (recoverable) error */ call write ((substr (infile, 1, nlindex - 1))); /* and write it as is */ goto continue; end; end; end; else buf = rtrim (substr (infile, 1, nlindex - 1), HT_or_SP); /* get the next line into buf */ if ^literal_mode & buf_len > 0 & ^continued_line /* literal_sw says ignore controls */ then if buf_chars (1) = "." then do; buf = translate (buf, " ", HT); /* quasi- */ do while (index (buf, " ") ^= 0); /* canonicalize */ buf = before (buf, " ") || " " || after (buf, " "); end; ctl = before (buf, " "); if index (ctl, " ") = 0 /* ctl is 1 char longer than the longest ctl */ then do; /* so it better end in a space or two */ call err_reporter (fdoc_et_$unsupported_control); goto continue; end; code = 0; param = (after (buf, " ")); if length (param) ^= 0 then do; signed = (verify (substr (param, 1, 1), "+-") = 0); paramfb = cv_dec_check_ ((param), code); end; ctl_index = divide (index (ctl_list, substr (ctl, 1, 4)), 4, 17, 0); if ctl_index = 0 then do; call err_reporter (fdoc_et_$unsupported_control); goto continue; end; goto process_ctl (ctl_index); process_ctl (1): /* undent */ process_ctl (13): if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) = 0 then new_und = ind; else do; new_und = paramfb; if new_und > ind then do; call err_reporter (fdoc_et_$undent_too_far_left); new_und = ind; end; else if (ll -ind) + new_und < 0 then do; call err_reporter (fdoc_et_$undent_too_far_right); new_und = ind - ll; end; end; goto process_break; process_ctl (2): /* indent */ process_ctl (12): if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) = 0 then new_ind = 0; else do; if signed then do; new_ind = paramfb + ind; if new_ind < 0 then do; call err_reporter (fdoc_et_$indent_too_far_left); new_ind = 0; end; end; else new_ind = paramfb; if new_ind > ll then do; call err_reporter (fdoc_et_$indent_too_far_right); new_ind = ll; end; end; goto process_break; process_ctl (3): /* allign both */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; new_adjust = "1"b; goto process_break; process_ctl (4): /* allign left */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; new_adjust = "0"b; goto process_break; process_ctl (5): /* fill on */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; new_fill = "1"b; goto process_break; process_ctl (6): /* fill off */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; new_fill = "0"b; goto process_break; process_ctl (7): /* page width */ if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) = 0 then ll = DEFAULT_LINE_LENGTH; else if signed then ll = ll + paramfb; else ll = paramfb; if maximum_line_length & ll > initial_line_length then do; ll = initial_line_length; call err_reporter (fdoc_et_$page_width_exceeds_max); end; goto continue; process_ctl (8): /* page length */ if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) = 0 then pl = DEFAULT_PAGE_LENGTH; else if signed then pl = pl + paramfb; else pl = paramfb; if ^pgno & pl < 13 then do; pl = 13; call err_reporter (fdoc_et_$page_length_lt_13); end; else if pgno & pl < 14 then do; pl = 14; call err_reporter (fdoc_et_$page_length_lt_14); end; goto continue; process_ctl (9): /* hyphenate default */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; hyphenating = format_document_options.hyphenation_sw; current_syllable_size = default_syllable_size; if hyphenating then if hyphenation_routine_state = 0 then call look_for_hyphenation_routine; else if hyphenation_routine_state = 2 then hyphenating = "0"b; goto continue; process_ctl (10): /* hyphenate off */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; hyphenating = "0"b; goto continue; process_ctl (11): /* hyphenate on */ if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) ^= 0 then if signed then do; call err_reporter (fdoc_et_$no_sign_allowed); goto continue; end; hyphenating = "1"b; if hyphenation_routine_state = 0 then call look_for_hyphenation_routine; else if hyphenation_routine_state = 2 then hyphenating = "0"b; if length (param) ^= 0 then current_syllable_size = paramfb; else current_syllable_size = default_syllable_size; goto continue; process_ctl (14): /* space-format */ if code ^= 0 then do; code = 0; call err_reporter (fdoc_et_$nonnumeric_parameter); goto continue; end; if length (param) ^= 0 then if signed then do; call err_reporter (fdoc_et_$no_sign_allowed); goto continue; end; if length (param) = 0 then blank_lines_to_be_written = 1; else blank_lines_to_be_written = paramfb; goto process_break; process_ctl (15): /* . */ process_ctl (16): /* .. */ process_ctl (17): /* ... */ process_ctl (18): /* .... */ goto process_text; /* these are text */ process_ctl (19): /* break-format */ process_ctl (20): /* break-page */ if length (param) ^= 0 then do; code = 0; call err_reporter (fdoc_et_$no_parameter_allowed); goto continue; end; goto process_break; /* which is currently the next statement */ process_break: /* We have hit a control break, must write out anything left */ if store_len ^= 0 then do; store = copy (" ", ind_minus_und) || store; /* indent */ call write (store); /* write it */ store = ""; /* clear out save area */ end; /* NOW apply specified control */ if ctl_index = 2 /* .in */ | ctl_index = 12 /* .inl */ then ind = new_ind; else if ctl_index = 1 /* .un */ | ctl_index = 13 /* .unl */ then und = new_und; else if ctl_index = 3 /* .alb */ | ctl_index = 4 /* .all */ then adjust = new_adjust; else if ctl_index = 5 /* .fin */ | ctl_index = 6 /* .fif */ then fill = new_fill; else if ctl_index = 14 /* .spf */ then do i = 1 to blank_lines_to_be_written; call write (""); end; else if ctl_index = 20 /* .brp */ then if ^galley_mode then do; if lnctr ^= 0 /* maybe the break caused a new page already */ then do; if pgno then do i = lnctr to pl - 8; call write (""); end; else if filout then do; lnctr = pl - 7; call write (""); end; else /* ^pgno & ^filout */ do i = lnctr to pl - 7; call write (""); end; end; end; ind_minus_und = ind - und; goto continue; /* go process another line */ end; process_text: if search (buf, CR_or_VT) ^= 0 then do; /* discard VT or CR */ do while (index (buf, VT) ^= 0); buf = decat (buf, VT, "101"b); end; do while (index (buf, CR) ^= 0); buf = decat (buf, CR, "101"b); end; buf = rtrim (buf, HT_or_SP); /* rtrim buf in case there are now blanks at the end */ end; if search (buf, BS_or_HT) ^= 0 then do; /* Input may not be canonical */ bsndx = index (buf, BS); /* Or may need tabs expanded */ if bsndx = 0 then goto tab_check; else if bsndx = 1 then goto call_canon; /* BS in pos 1 is uncanonical */ do while ("1"b); if bsndx = length (buf) then goto call_canon; /* As is BS in last pos */ if search (buf_chars (bsndx - 1), BS_or_HT_or_SP) ^= 0 then goto call_canon; if search (buf_chars (bsndx + 1), BS_or_HT_or_SP) ^= 0 then goto call_canon; bsndx1 = bsndx + index (substr (buf, bsndx + 1), BS); if bsndx = bsndx1 then goto tab_check; /* No more BSs */ bsndx = bsndx1; end; tab_check: tabndx = index (buf, HT); do while (tabndx ^= 0); /* While there are tabs */ vtabndx = tabndx; do i = 2 to tabndx; /* Determine virtual position of tab in line */ if buf_chars (i) = BS /* BS means line is virtually */ then do; /* 2 less characters wide than seems */ vtabndx = vtabndx - 2; i = i + 1; /* Next char is not BS */ end; end; tabfill = 11 - mod (vtabndx, 10); /* See how many spaces to fill in */ if tabfill = 11 then tabfill = 1; buf = substr (buf, 1, tabndx - 1) /* Fill 'em in */ || copy (" ", tabfill) || substr (buf, tabndx + 1); tabndx = index (buf, HT); end; goto dont_canon; call_canon: call canonicalize_ (addr (buf_chars (1)), (buf_len), addr (buf_chars (1)), buf_len21, code); if code ^= 0 then goto done; buf_len = buf_len21; dont_canon: end; line_began_with_blank = "0"b; if ^fill then do; /* No fill, just write it */ store = buf; store = copy (" ", ind_minus_und) || store; call write (store); store = ""; goto check_length; end; else if length (buf) = 0 then do; /* null line? */ if store_len ^= 0 then do; /* if there is something left */ store = copy (" ", ind_minus_und) || store; /* then indent */ call write (store); /* and write it */ end; call write (buf); /* now write out null line */ store = ""; /* clear out save area */ goto check_length; end; else if buf_chars (1) = " " then do; /* leading blank cause break */ line_began_with_blank = "1"b; if store_len ^= 0 then do; /* if save area not empty */ store = copy (" ", ind_minus_und) || store; /* indent it */ call write (store); /* and write it */ end; store = buf; /* move buffer to save area */ end; else do; if component_ends_wo_NL /* special handling */ then do; /* when spanning msf */ component_ends_wo_NL = "0"b; /* components */ store = store || buf; end; else do; /* concatenate buffer to end of save area */ if store_len > 0 then store = store || " "; store = store || buf; end; end; /* The following code enforces the convention of 2 spaces after certain punctuation. What appears to be a serious flirtation with stringrange is actually a firm knowledge that store has been rtrimmed of spaces. */ if ^dont_compress then do; if dont_break_indented_lines & line_began_with_blank then if nlindex >= inlen /* if next line blank or this is eof */ then goto check_length; /* don't do any compression */ else if search (in_chars (nlindex + 1), HT_or_NL_or_SP) ^= 0 then goto check_length; spindex = index (store, " "); if spindex = 1 /* Don't mess with leading spaces */ then do; /* Find first space after non-blank char */ spindex = verify (store, " "); spindex1 = index (substr (store, spindex), " "); if spindex1 = 0 then spindex = 0; else spindex = spindex + spindex1 - 1; end; if spindex ^= 0 then do while (index (substr (store, spindex), " ") ^= 0); if verify (store_char (spindex - 1), ":.!?)") = 0 then do; if store_char (spindex - 1) = ")" then do; if spindex < 3 then goto compress_blanks; if verify (store_char (spindex - 2), "!?.") ^= 0 then goto compress_blanks; end; if store_char (spindex + 1) ^= " " /* should be 2 spaces */ then store = substr (store, 1, spindex) || " " || substr (store, spindex + 1); else do while (store_char (spindex + 2) = " "); /* and only 2 */ store = substr (store, 1, spindex + 1) || substr (store, spindex + 3); end; spindex = spindex + 2; /* look at next char past spaces */ end; else do; compress_blanks: do while (store_char (spindex + 1) = " "); store = substr (store, 1, spindex) || substr (store, spindex + 2); end; spindex = spindex + 1; /* skip over space */ end; spindex1 = index (substr (store, spindex), " "); if spindex1 = 0 then goto check_length; else spindex = spindex + spindex1 - 1; end; end; check_length: if ll - ind_minus_und < 1 /* negative effective linelength */ then do; call err_reporter (fdoc_et_$line_length_too_small); code = error_table_$fatal_error; goto done; end; do while (length (rtrim (store)) + ind_minus_und > ll - 1); /* if line long enough, deal with it */ /* check for backspaces */ /* if there are backspaces in the line we got problems, and therefore branch to a special routine */ if index (store, BS) < ll - ind_minus_und + 2 & index (store, BS) ^= 0 then goto bs_rtn; store = copy (" ", ind_minus_und) || store; /* indent */ if line_began_with_blank & dont_break_indented_lines then do; /* called by Gary Palter */ if nlindex < inlen /* don't break the line if is followed by a blank line */ /* or an indented line or the end of the file */ then if search (in_chars (nlindex + 1), HT_or_NL_or_SP) = 0 then goto process_normally; call write (store); store = ""; goto continue; end; process_normally: if store_len = ll then do; /* line is exactly the right size */ outline = rtrim (store); /* put it in the output buffer */ store = ""; /* clear save area */ call write (outline); /* write it out */ end; else if store_char (ll + 1) = " " then do; /* blank at ll + 1 */ outline = rtrim (substr (store, 1, ll)); /* put first ll chars in out buffer */ store = ltrim (substr (store, ll + 2)); /* let save area have the rest */ if outline ^= "" then do; if adjust & length (outline) < ll /* needs adjusted */ then call adjust_line (outline, ll); call write (outline); /* and write */ end; end; else do; /* find first blank counting left from ll */ spindex = ll - index (reverse (substr (store, 1, ll)), " "); if spindex ^= ll & (spindex - ind) > 0 /* don't wanna go into the left margin */ then do; if hyphenating then if ll - spindex > current_syllable_size + 1 then do; hyph_ptr = addr (store_char (spindex + 2)); hyph_len = search (substr (store, spindex + 2), " ") - 1; if hyph_len = -1 /* no spaces */ then hyph_len = store_len - spindex - 1; hyph_space = ll - spindex - 1; call hyphenate_word_ (hyph_word, hyph_space, hyph_point, code); if code ^= 0 then goto done; if hyph_point > current_syllable_size - 1 then do; outline = rtrim (substr (store, 1, spindex + hyph_point + 1)); outline = outline || HYPHEN; store = ltrim (substr (store, spindex + hyph_point + 2)); goto adjust_check; end; end; outline = rtrim (substr (store, 1, spindex)); /* save off chars up to that blank */ store = ltrim (substr (store, spindex + 2)); /* put rest in save area */ adjust_check: if adjust then call adjust_line (outline, ll); /* call space filling rtn */ end; /* no blanks from 1 to ll */ else do; if hyphenating /* try hyphenating first */ then do; hyph_ptr = addr (store_char (1)); hyph_len = store_len; hyph_space = ll; call hyphenate_word_ (hyph_word, hyph_space, hyph_point, code); if code ^= 0 then goto done; if hyph_point >= current_syllable_size then do; outline = substr (store, 1, hyph_point); outline = outline || HYPHEN; store = substr (store, hyph_point + 1); goto write_here; end; end; if breaking_words then do; /* either cut it off in mid-word */ outline = substr (store, 1, ll); store = substr (store, ll + 1); end; else do; if index (substr (store, ind + 1), " ") ^= 0 /* or cut it off at first blank past ll */ then do; outline = substr (store, 1, index (store, " ") - 1); store = ltrim (substr (store, index (store, " ") + 1)); end; else do; /* no blanks anywhere in line */ outline = store; store = ""; end; call err_reporter (fdoc_et_$text_too_long_for_line); /* too much data for output line */ end; end; write_here: call write (outline); /* and finally write */ end; still_in_write_loop_with_more_to_process: /* come back here from bs_rtn */ end; goto continue; /* branch around backspace code */ bs_rtn: /* At this point we think we have more than ll characters, but we know we have backspaces. We have to find out how many print positions we actually have and if it's still more than ll, we have to locate where to break the line apart. vlen is the actual number of print positions. */ store = copy (" ", ind_minus_und) || store;/* indent */ last_blank = 0; vlen = 0; bscnt = 0; long_line_and_no_blank = "0"b; fit = "0"b; do k = 1 to store_len while (^fit); if store_char (k) = BS then do; k = k + 1; bscnt = bscnt + 1; end; else vlen = vlen + 1; if store_char (k) = " " then do; if long_line_and_no_blank then do; outline = substr (store, 1, k - 1); store = ltrim (substr (store, k)); call err_reporter (fdoc_et_$text_too_long_for_line); call write (outline); goto still_in_write_loop_with_more_to_process; end; last_blank = k; if vlen > ll then do; outline = substr (store, 1, k - 1); store = ltrim (substr (store, k)); call err_reporter (fdoc_et_$text_too_long_for_line); call write (outline); goto still_in_write_loop_with_more_to_process; end; end; if vlen = ll then do; if k < store_len then if store_char (k + 1) = BS then k = k + 2; if k = store_len then fit = "1"b; if k < store_len then if store_char (k + 1) = " " then fit = "1"b; else if last_blank ^= 0 then do; do h = last_blank + 1 to k - 1; if store_char (h) = BS then bscnt = bscnt - 1; end; k = store_len; end; else if breaking_words then do; outline = substr (store, 1, k); store = substr (store, k + 1); call write (outline); goto still_in_write_loop_with_more_to_process; end; else long_line_and_no_blank = "1"b; end; end; if long_line_and_no_blank then do; outline = store; store = ""; call err_reporter (fdoc_et_$text_too_long_for_line); call write (outline); goto continue; end; else if vlen < ll /* print position count < ll */ then do; store = substr (store, (ind + 1) - und);/* undo indentation */ goto continue; /* get another line */ end; else if fit then do; outline = substr (store, 1, k - 1); if k - 1 ^= store_len then store = ltrim (substr (store, k)); else store = ""; call write (outline); end; else do; if line_began_with_blank & dont_break_indented_lines then do; /* see the comments that proceed */ if nlindex < inlen /* the label "process_normally" */ then if search (in_chars (nlindex + 1), HT_or_NL_or_SP) = 0 then goto process_backspaces_normally; call write (store); store = ""; goto continue; end; process_backspaces_normally: outline = rtrim (substr (store, 1, last_blank - 1)); /* move printable portion to buffer */ store = ltrim (substr (store, last_blank + 1)); /* make rest contents of store */ if adjust then call adjust_line (outline, ll + bscnt * 2); /* call space fill rtn */ call write (outline); /* and write */ end; goto still_in_write_loop_with_more_to_process; continue: if nlindex ^= 0 /* if there is more data */ then do; inptr = addr (in_chars (nlindex + 1)); /* move input ptr past next NL */ inlen = inlen - nlindex; /* change length to reflect what is left */ if continued_line then do; spindex = verify (infile, " "); inptr = addr (in_chars (spindex)); inlen = inlen - spindex + 1; end; end; else goto no_more_data; /* end of component, maybe end of file */ end; /* Almost done, now clean up. */ no_more_data: if string_entry /* input string can't be MSF */ then goto no_more_components; in_comp_no = in_comp_no + 1; /* try next component */ call msf_manager_$get_ptr (infcbptr, in_comp_no, "0"b, inptr, bc, code); if inptr = null then if code = error_table_$noentry /* we have processed last component */ then do; code = 0; goto no_more_components; end; else goto done; /* msf_manager_ crapped out */ component_ends_wo_NL = (initial_in_chars (initial_inlen) ^= NL); inlen = divide (bc, 9, 21, 0); goto process_one_component; /* here we go again */ no_more_components: if store_len ^= 0 then do; store = copy (" ", ind_minus_und) || store;/* indent */ call write (store); /* write out last line */ end; if lnctr ^= 0 & ^galley_mode /* if a partial */ then do; /* page has been written */ if pgno then do; do k = 1 to ((pl - 5) - lnctr); if filout then call write_file (NL); /* add blank line */ else do; ioxbuf = NL; call iox_$put_chars (iocbptr, addr (ioxbuf), 1, code); if code ^= 0 then goto done; end; end; pgctr = pgctr + 1; /* bump page counter */ pgctra = ltrim (char (pgctr)); /* and write page number */ if filout then call write_file (indstr || copy (" ", divide (ll - length (pgctra), 2, 17, 0)) || pgctra || FF); else do; ioxbuf = indstr || copy (" ", divide (ll - length (pgctra), 2, 17, 0)) || pgctra || copy (NL, 5); call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code); if code ^= 0 then goto done; end; end; else do; if filout & char_cnt ^= 1 then do; outptr = addr (out_chars (char_cnt - 1)); /* back up outptr 1 position */ char_cnt = char_cnt - 1; call write_file (FF); /* replace trailing NL with FF */ end; else if ^filout then do k = 1 to (pl - lnctr); ioxbuf = NL; call iox_$put_chars (iocbptr, addr (ioxbuf), 1, code); if code ^= 0 then goto done; end; end; end; if string_entry then outlen = char_cnt - 1; check_version_and_set_options: proc; if format_document_options.version_number = format_document_version_1 then do; /* assign defaults */ dont_compress, breaking_words, maximum_line_length, dont_break_indented_lines, using_sub_err, hyphenating = "0"b; fill = "1"b; default_syllable_size = 2; /* old version has no syllable size, assign one */ end; else if format_document_options.version_number = format_document_version_2 then do; /* this guy knows what he is doing */ dont_compress = format_document_options.switches.dont_compress_sw; breaking_words = format_document_options.switches.break_word_sw; maximum_line_length = format_document_options.switches.max_line_length_sw; dont_break_indented_lines = format_document_options.switches.dont_break_indented_lines_sw; using_sub_err = format_document_options.switches.sub_err_sw; fill = ^format_document_options.switches.dont_fill_sw; hyphenating = format_document_options.switches.hyphenation_sw; default_syllable_size = format_document_options.syllable_size; end; else do; code = error_table_$unimplemented_version; goto done; end; adjust = format_document_options.switches.adj_sw; galley_mode = format_document_options.switches.galley_sw; initial_ind = format_document_options.indentation; initial_line_length = format_document_options.line_length; literal_mode = format_document_options.literal_sw; ll = format_document_options.line_length; pgno = format_document_options.switches.pgno_sw; end check_version_and_set_options; write: proc (line); dcl line char (*) varying parameter; und = 0; /* get rid of undent, it only applies to one line */ ind_minus_und = ind; if lnctr = 0 & ^galley_mode then do; /* BEGIN PAGE */ if filout then call write_file (copy (NL, 3)); else do; ioxbuf = copy (NL, 6); call iox_$put_chars (iocbptr, addr (ioxbuf), 6, code); if code ^= 0 then goto done; end; lnctr = 6; end; if filout /* WRITE LINE */ then call write_file (indstr||line||NL); /* add a newline */ else do; ioxbuf = indstr||line||NL; call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code); if code ^= 0 then goto done; end; if ^galley_mode /* END PAGE */ then do; lnctr = lnctr + 1; /* bump line counter */ if pgno then if lnctr = (pl - 7) then do; pgctr = pgctr + 1; /* bump page counter */ lnctr = 0; /* roll the line counter */ pgctra = ltrim (char (pgctr)); if filout /* write page number */ then call write_file (copy (NL, 2) || indstr || copy (" ", divide (ll - length (pgctra), 2, 17, 0)) || pgctra || FF); else do; ioxbuf = copy (NL, 2) || indstr || copy (" ", divide (ll - length (pgctra), 2, 17, 0)) || pgctra || copy (NL, 5); call iox_$put_chars (iocbptr, addr (ioxbuf), length (rtrim (ioxbuf)), code); if code ^= 0 then goto done; end; end; else; else if lnctr = (pl - 6) then do; lnctr = 0; if filout & char_cnt ^= 1 then out_chars (char_cnt - 1) = FF; /* overwrite LF with FF */ else if ^filout then do; ioxbuf = copy (NL, 6); call iox_$put_chars (iocbptr, addr (ioxbuf), 6, code); if code ^= 0 then goto done; end; end; end; end write; write_file: proc (text); dcl text char (*) parameter; tlen = length (text); char_cnt = char_cnt + tlen; if string_entry then do; if (char_cnt - 1) > outstringlen /* can't write past end of string */ then do; space_available = outstringlen + tlen + 1 - char_cnt; /* write what you can */ substr (outfile, 1, space_available) = substr (text, 1, space_available); outlen = outstringlen; code = error_table_$smallarg; /* and go boom */ goto done; end; else substr (outfile, 1, tlen) = text; /* normal write */ end; else if char_cnt > maxcnt /* can't write past end of component */ then do; space_available = tlen + maxcnt - char_cnt; /* write what you can */ substr (outfile, 1, space_available) = substr (text, 1, space_available); out_comp_no = out_comp_no + 1; /* get another component */ call msf_manager_$get_ptr (outfcbptr, out_comp_no, "1"b, outptr, bc, code); if outptr = null () /* msf_manager_ burped */ then do; format_document_options.file_sw = "1"b; goto done; end; initial_outptr = outptr; /* write rest to next component */ substr (outfile, 1, tlen - space_available) = substr (text, space_available + 1); char_cnt = (tlen - space_available) + 1; end; else substr (outfile, 1, tlen) = text; /* normal write */ outptr = addr (out_chars (char_cnt)); /* move output ptr to next available position */ end write_file; adjust_line: proc (adj_line, linelength); /* routine to fill spaces into line that is less than ll long */ dcl adj_line char (508) varying parameter; dcl linelength fixed parameter; spaces = 0; adj_line_out = adj_line; pads = linelength - length (adj_line); /* how many spaces to fill */ do i = verify (adj_line, " ") to length (adj_line); spindex = index (substr (adj_line, i), " "); if spindex = 0 then i = length (adj_line); else do; spaces = spaces + 1; /* add to count of spaces in line */ i = i + spindex - 1; space_pos (spaces) = i; /* mark position of space */ end; end; /* fill spaces in adjacent to existing spaces starting from left on first line (starting again on left if necessary) and then reverse the procedure to start from the right the next time */ if spaces ^= 0 then do; if left then do i = 1 to pads; /* adjust from left */ j = mod (i, spaces); if j = 0 then j = spaces; adj_line_out = substr (adj_line_out, 1, space_pos (j) + j - 1)||" "||substr (adj_line_out, space_pos (j) + j); space_pos (j) = space_pos (j) + j; left = "0"b; end; else do; /* adjust from right */ k = spaces; do i = pads to 1 by -1; if k = 0 then k = spaces; adj_line_out = substr (adj_line_out, 1, space_pos (k))||substr (adj_line_out, space_pos (k)); do j = k to spaces; space_pos (j) = space_pos (j) + 1; end; left = "1"b; k = k - 1; end; end; end; adj_line = adj_line_out; end adjust_line; look_for_hyphenation_routine: proc; on linkage_error begin; hyphenating = "0"b; hyphenation_routine_state = 2; /* not found */ call err_reporter (fdoc_et_$no_hyphenate_word); goto reversion; end; hyphenate_entry = hyphenate_word_; hyphenation_routine_state = 1; /* found */ reversion: revert linkage_error; end look_for_hyphenation_routine; err_reporter: proc (errcode); dcl errcode fixed bin (35) parameter; error = "1"b; errtxt = ""; if format_document_options.error_sw then do; call convert_status_code_ (errcode, trash, errtxt); call ioa_$rs ("line ^d^-^a^[^s^;^/^a^]", error_lines, elen, inplnctr, errtxt, ((^filout) & ((errcode = fdoc_et_$text_too_long_for_line)) | (errcode = fdoc_et_$line_too_long) | (errcode = fdoc_et_$no_hyphenate_word)), buf); call iox_$put_chars (iox_$error_output, addr (error_lines), elen, code); if code ^= 0 then goto done; end; if using_sub_err then do; if errtxt ^= "" then call convert_status_code_ (errcode, trash, errtxt); if errcode = fdoc_et_$line_length_too_small then subcode = error_table_$fatal_error; else subcode = error_table_$recoverable_error; error_info.version_number = format_document_error_version_1; error_info.error_code = errcode; error_info.line_number = inplnctr; if errcode = fdoc_et_$no_hyphenate_word then error_info.text_line = ""; else error_info.text_line = buf; call sub_err_ (subcode, "format_document_", (ACTION_CAN_RESTART | ACTION_DEFAULT_RESTART | ACTION_QUIET_RESTART), addr (error_info), retval, errtxt); end; end err_reporter; done_proc: proc; /* clean up time */ if indptr ^= null () then free indstr; if code = 0 & error then code = error_table_$recoverable_error; if infcbptr ^= null () then call msf_manager_$close (infcbptr); if outfcbptr ^= null () then do; call tssi_$finish_file (outfcbptr, out_comp_no, ((char_cnt - 1) * 9), "101"b, aclinfoptr, temp_code); if code = 0 /* don't want to clobber code so use a temporary */ then code = temp_code; /* and then assign it if code was zero */ end; end done_proc; done: call done_proc; end format_document_;  format_string.pl1 11/01/84 1411.7r w 11/01/84 1303.8 162936 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Name: format_string, fstr */ /* */ /* This command/af does fill and adjust processing for a string, using */ /* format_document_$string. */ /* */ /* History: */ /* 0) Created: December 1983 by G. C. Dixon */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ format_string: fstr: proc options(variable); dcl Ifirst_string_arg fixed bin, /* arg no of the first string argument. It and */ /* all remaining args are strings to be */ /* formatted. */ Presult ptr, /* ptr to resulting output from format_document_ */ Pstr ptr, /* ptr to input to format_document_$string. */ Pstr_nonvar ptr, /* ptr to nonvarying representation of input. */ Pundent_line ptr, /* ptr to portion of first line of result which */ /* must be indented or undented. */ Sadjust bit(1), /* On if output to be right-adjusted. */ Sbreak_word bit(1), /* On if over-length words can be broken across */ /* lines. */ Shyphenate bit(1), /* On if hyphenation should be performed. */ code fixed bin(35), (hyphenate_word_part, indent, line_length, starting_column, undent) fixed bin, /* Control argument operand values. */ (result_len, str_length) fixed bin(21); /* Length of input and output strings. */ dcl Lstr_nonvar fixed bin(21) based(Pstr), result char(result_len) based(Presult), result_array (result_len) char(1) based (Presult), str char(str_length) varying based (Pstr), str_nonvar char(Lstr_nonvar) based(Pstr_nonvar), undent_line char(line_length) varying based (Pundent_line); dcl (abs, addr, addrel, copy, currentsize, index, length, null, substr, wordno) builtin; dcl (cleanup, sub_error_) condition; dcl format_document_$string entry (char(*), char(*), fixed bin(21), ptr, fixed bin(35)), (get_temp_segment_, release_temp_segment_) entry (char(*), ptr, fixed bin(35)), ioa_$nnl entry() options(variable), requote_string_ entry (char(*)) returns(char(*)); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), NL char(1) int static options(constant) init(" "), SP char(1) int static options(constant) init(" "), (error_table_$badopt, error_table_$inconsistent, error_table_$noarg) fixed bin(35) ext static, ME char(13) int static options(constant) init("format_string"), sys_info$max_seg_size fixed bin(35) ext static; call get_invocation_type (Saf); /* Find out how we were invoked, get count of args*/ Sadjust = FALSE; /* Initialize control argument values. */ Sbreak_word = TRUE; Shyphenate = FALSE; hyphenate_word_part = 2; indent = 0; line_length = 65; starting_column = 1; str_length = 0; undent = 0; do while (get_arg()); /* Process control arguments, and figure length */ if index(arg, "-") = 1 then do; /* of text string. */ if arg = "-line_length" | arg = "-ll" then do; if get_op ("^a requires a line length operand.", arg) then do; line_length = cv_int$pos (op, "^a requires a positive line length operand.", arg); end; end; else if arg = "-indent" | arg = "-ind" | arg = "-in" then do; if get_op ("^a requires a line indentation operand.", arg) then do; indent = cv_int$nonneg (op, "^a requires a nonnegative indentation count.", arg); end; end; else if arg = "-undent" | arg = "-und" | arg = "-un" then do; if get_op ("^a requires a first line undentation operand.", arg) then do; undent = cv_int (op, "^a requires an integer undentation operand.", arg); end; end; else if arg = "-column" | arg = "-col" then do; if get_op ("^a requires a starting column position operand.", arg) then do; starting_column = cv_int$pos (op, "^a requires a positive column position.", arg); end; end; else if arg = "-adjust" | arg = "-adj" then Sadjust = TRUE; else if arg = "-no_adjust" | arg = "-nadj" then Sadjust = FALSE; else if arg = "-break_word" then Sbreak_word = TRUE; else if arg = "-no_break_word" then Sbreak_word = FALSE; else if arg = "-hyphenate" | arg = "-hph" then do; Shyphenate = TRUE; if get_op ("", arg) then do; hyphenate_word_part = cv_int$pos (op, "", arg); if hyphenate_word_part = -9999 then do; call put_op(); /* -9999 indicates conversion error occurred. */ hyphenate_word_part = 2; /* Assumed -hph operand is really another ctl arg.*/ end; end; end; else if arg = "-no_hyphenate" | arg = "-nhph" then Shyphenate = FALSE; else if arg = "-string" | arg = "-str" then do; if get_arg () then go to STRING_ARG; end; else call error (error_table_$badopt, ME, arg); end; else do; /* first text string argument. */ STRING_ARG: Ifirst_string_arg = Iarg; str_length = str_length + length(arg); do while (get_arg()); /* All remaining args are text strings. */ str_length = str_length + length(SP) + length(arg); end; end; end; if str_length = 0 then /* Check argument consistency. */ call error (error_table_$noarg, ME, "Need a string to be formatted."); if (indent > 0 & indent >= line_length) then call error (error_table_$inconsistent, ME, "^/-line_length ^d -indent ^d", line_length, indent); if (undent > 0 & undent > indent) then call error (error_table_$inconsistent, ME, "^/-indent ^d -undent ^d", indent, undent); if (undent < 0 & indent-undent > line_length) then call error (error_table_$inconsistent, ME, "^/-line_length ^d ^[-indent ^d ^;^s^]-undent ^d", line_length, indent > 0, indent, undent); if (starting_column > line_length) then call error (error_table_$inconsistent, ME, "^/-line_length ^d -column ^d", line_length, starting_column); if Serror then return; str_length = str_length + abs(undent) + starting_column; /* Add room to text string for undent space */ /* and starting column filler. */ Pstr = null; /* Get temp seg to hold string, undent_line and */ on cleanup begin; /* result. */ call release_temp_segment_ (ME, Pstr, code); end; call get_temp_segment_ (ME, Pstr, code); Serrors_are_fatal = TRUE; call error (code, ME, "Getting a temp segment."); Pstr_nonvar = addrel(Pstr, 1); /* Overlay str (which is a varying string) */ /* with its nonvarying representation. */ fdo.version_number = format_document_version_2; /* Fill in format_document_ info structure. */ fdo.indentation = indent; fdo.line_length = line_length - indent; fdo.switches = FALSE; fdo.adj_sw = Sadjust; fdo.galley_sw = TRUE; fdo.literal_sw = TRUE; fdo.break_word_sw = Sbreak_word; fdo.max_line_length_sw = TRUE; fdo.sub_err_sw = TRUE; fdo.hyphenation_sw = Shyphenate; fdo.syllable_size = hyphenate_word_part; str = ""; /* Prepare to fill in string from arguments. */ if undent < 0 then /* For indented first line, add a place holder. */ str = copy ("~", -undent); call reprocess_args(Ifirst_string_arg); /* Reprocess arguments to fill in text args into */ do while (get_arg()); /* string variable. */ str = str || arg; do while (get_arg()); str = str || SP; str = str || arg; end; end; Pundent_line = addrel (Pstr, currentsize(str)); if undent > 0 then do; /* For undented first line, save portion of string*/ undent_line = copy(SP, indent-undent); /* to be undented, removing it from input. */ if length(str) > undent then do; undent_line = undent_line || substr (str, 1, undent); str = substr(str, undent+1); end; else do; undent_line = undent_line || str; str = copy (SP, undent-length(str)+1); end; end; Presult = addrel (Pundent_line, currentsize(undent_line)); result_len = sys_info$max_seg_size*4 - wordno(Presult); on sub_error_ call sub_error_handler(); call format_document_$string (str_nonvar, result, result_len, addr(fdo), code); /* Call format_document_ to do the fill/adj work. */ revert sub_error_; if code ^= 0 then call error (code, ME, "While formatting the string."); else do; /* If no errors occurred: */ if undent < 0 then /* remove placeholder for indented first line. */ substr (result, indent+1, -undent) = ""; else if undent > 0 then /* or add undented part of first line to result.*/ substr (result, 1, indent) = undent_line; if starting_column > 1 then do; /* If other text already appears on first line: */ if starting_column-1 <= indent-undent then do; Presult = addr (result_array(starting_column)); result_len = result_len - (starting_column-1); end; /* remove indent spaces on first line to */ /* accommodate assumed text; or */ else do; /* force output to begin on a new line. */ result_len = result_len + length(NL); result = NL || substr(result, 1, result_len-length(NL)); end; end; if Saf then do; /* AF: return unquoted result, without final NL. */ result_len = result_len - length(NL); call set_return_arg (requote_string_(result)); end; else /* COMMAND: print final result. */ call ioa_$nnl ("^a", result); end; RETURN: if Pstr ^= null then /* Give back the temp segment. */ call release_temp_segment_ (ME, Pstr, code); return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* I N T E R N A L P R O C E D U R E S */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cv_int: proc (op, str, arg1) returns (fixed bin); /* Convert control arg operand to integer. */ dcl op char(*), str char(*), arg1 char(*); dcl Smust_be_nonnegative bit(1), Smust_be_positive bit(1), number fixed bin; dcl convert builtin; dcl (conversion, size) condition; dcl (error_table_$bad_conversion, error_table_$out_of_bounds) fixed bin(35) ext static; Smust_be_nonnegative = FALSE; Smust_be_positive = FALSE; CV_NUM: on conversion, size begin; code = error_table_$bad_conversion; if str = "" then go to BAD_NUM_OK; /* operand optional: no error message. */ go to BAD_NUM; end; number = convert (number, op); revert conversion, size; if (number < 0 & Smust_be_nonnegative) | (number < 1 & Smust_be_positive) then do; code = error_table_$out_of_bounds; BAD_NUM: call error (code, ME, "^a ^a^/" || str, arg1, op, arg1); return (1); end; return (number); BAD_NUM_OK: return (-9999); cv_int$nonneg: entry (op, str, arg1) returns(fixed bin); Smust_be_nonnegative = TRUE; Smust_be_positive = FALSE; go to CV_NUM; cv_int$pos: entry (op, str, arg1) returns(fixed bin); Smust_be_nonnegative = FALSE; Smust_be_positive = TRUE; go to CV_NUM; end cv_int; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl Serror bit(1), /* On if fatal error has occurred. */ Serrors_are_fatal bit(1); /* On if errors are fatal. */ error: proc options(variable); /* Procedure to report errors via com_err_ or */ /* active_fnc_err_, as appropriate. This proc */ /* has same calling sequence as com_err_. */ dcl code fixed bin(35) based (Pcode), Pcode ptr; dcl cu_$arg_list_ptr entry returns(ptr), cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$generate_call entry (entry, ptr); call cu_$arg_ptr (1, Pcode, 0, 0); /* Access error table code argument. */ if code = 0 then return; /* If non-zero, this ISN'T an error. */ Serror = TRUE; /* Record fact that an error occurred. */ call cu_$generate_call (err, cu_$arg_list_ptr()); /* Actually call com_err_ or active_fnc_err_. */ if Serrors_are_fatal then go to RETURN; end error; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl Iarg fixed bin, /* Current argument being processed. */ Larg fixed bin(21), /* Length of current argument. */ Lop fixed bin(21), /* Length of current ctl arg operand. */ Lret fixed bin(21), /* Max length of AF return value. */ Nargs fixed bin, /* Number of arguments. */ Parg ptr, /* Ptr to current argument. */ Parg_list ptr, /* Ptr to command/af's argument list. */ Pop ptr, /* Ptr to current operand. */ Pret ptr, /* Ptr to AF return value. */ Saf bit(1), /* On if invoked as an active function. */ arg char(Larg) based(Parg), op char(Lop) based(Pop), ret char(Lret) varying based(Pret), (arg_ptr variable, cu_$af_arg_ptr_rel, cu_$arg_ptr_rel) entry (fixed bin, ptr, fixed bin(21), fixed bin(35), ptr), cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$arg_list_ptr entry returns(ptr), (err variable, active_fnc_err_, com_err_) entry() options(variable); get_invocation_type: /* Were we invoked as command or af? Arg count? */ proc (Saf); dcl Saf bit(1); Serrors_are_fatal = FALSE; call cu_$af_return_arg (Nargs, Pret, Lret, code); if code = 0 then do; Saf = TRUE; arg_ptr = cu_$af_arg_ptr_rel; err = active_fnc_err_; ret = ""; end; else do; Saf = FALSE; arg_ptr = cu_$arg_ptr_rel; err = com_err_; end; Iarg = 0; /* No args processed so far. */ Serror = FALSE; /* No errors so far. */ Parg_list = cu_$arg_list_ptr(); /* Remember arg list ptr for subrs below. */ end get_invocation_type; get_arg: proc returns(bit(1)); /* Returns TRUE if another argument exists. */ /* Its value is accessible via arg variable. */ if Iarg+1 > Nargs then return(FALSE); Iarg = Iarg + 1; call arg_ptr (Iarg, Parg, Larg, code, Parg_list); return(TRUE); get_op: entry (str, arg1) returns(bit(1)); /* Returns TRUE if another argument exists. */ /* Its value is accessible via op variable. */ dcl str char(*), arg1 char(*); dcl error_table_$smallarg fixed bin(35) ext static; if Iarg+1 > Nargs then do; if str ^= "" then call error (error_table_$noarg, ME, str, arg1); return(FALSE); end; Iarg = Iarg + 1; call arg_ptr (Iarg, Pop, Lop, code, Parg_list); if op = "" then do; if str ^= "" then call error (error_table_$smallarg, ME, """^va""^/" || str, length(op), op, arg1); return(FALSE); end; return(TRUE); put_op: entry; /* Return operand to list of unprocessed args. */ Iarg = Iarg - 1; return; reprocess_args: /* Reprocess argument list again, starting with */ entry (Ith_arg); /* the Ith argument. */ dcl Ith_arg fixed bin; Iarg = Ith_arg - 1; /* get_arg adds 1 before reading an arg. */ return; set_return_arg: /* Set AF return value. */ entry (str); ret = str; return; end get_arg; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sub_error_handler: proc; dcl code fixed bin(35), continue_to_signal_ entry (fixed bin(35)), error_table_$unimplemented_version fixed bin(35) ext static, find_condition_info_ entry (ptr, ptr, fixed bin(35)); condition_info_ptr = addr (auto_condition_info); condition_info.version = condition_info_version_1; call find_condition_info_ (null(), addr(condition_info), code); if code ^= 0 then call error (code, ME, "Handling sub_error_ condition from format_document_$string."); sub_error_info_ptr = condition_info.info_ptr; if sub_error_info.version ^= sub_error_info_version_1 then call error (error_table_$unimplemented_version, ME, " Version ^d of sub_error_info structure isn't supported.", sub_error_info.version); if sub_error_info.name ^= "format_document_" then do; call continue_to_signal_ (code); return; end; format_document_error_ptr = sub_error_info.info_ptr; if format_document_error.version_number ^= format_document_error_version_1 then call error (error_table_$unimplemented_version, ME, " Version ^d of format_document_error structure isn't supported.", format_document_error.version_number); call error (format_document_error.error_code, ME); return; %include condition_info; dcl 1 auto_condition_info aligned like condition_info; %include condition_info_header; %include sub_error_info; %include format_document_error; end sub_error_handler; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ %include format_document_options; dcl 1 fdo aligned like format_document_options; end format_string;  indent.pl1 12/17/85 1305.1rew 12/16/85 1652.7 428265 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(69-06-01,VanVleck), approve(), audit(), install(): created from a MAD (Michigan Algorithmic Decode) Stan Dutton's CTSS program. 2) change(73-06-01,Morris), approve(), audit(), install(): modified to know about IF statements. 3) change(73-12-01,VanVleck), approve(), audit(), install(): heavily modified to take advantage of EIS instruction set. 4) change(74-08-01,Casey), approve(), audit(), install(): modified to - check for missing quotes and other errors that are really caused by missing quotes; and - refuse to replace the original segment when such errors are detected; - rewrite argument processing to use less code and allow control arguments anywhere on the line. 5) change(76-03-01,LJohnson), approve(), audit(), install(): modified to fix bugs in indenting multiple line strings, to improve character handling, and to support .cds suffix. 6) change(77-06-14,May), approve(), audit(), install(): modified to add processing of source for the reduction_compiler, to generalize somewhat for other possible dialects, and to fix a bug indenting factored structure entries. 7) change(85-08-02,GDixon), approve(85-09-27,MCR7261), audit(85-09-27,GWMay), install(85-12-16,MR12.0-1001): support format_pl1's unchangeable comment syntax, which is a comment beginning with /****^. This is needed to prevent indent from messing up history comments. END HISTORY COMMENTS */ indent: ind: proc; /* The INDENT command indents PL1 programs to make them more readable. Each DO, BEGIN, or PROCEDURE statement causes an additional level of indentation until a corresponding END is encountered. (Multiple closure is not permitted.) An IF statement or ELSE statement which is continued over multiple lines will also indent its subsequent lines. Comments are lined up in a standard column. A comment will be placed in column 1 if it is the first thing on the line and if the preceding line was blank or another such comment. Declaration statements are indented in a standard form, so that factoring and structure nesting are exhibited. Multiple spaces or tabs are replaced by a single space, except for the content of strings and for non-leading spaces and tabs in comments. Spaces are inserted around the operators = -> ^= >= and <=, after commas, and before left parentheses and after right parentheses. Spaces are removed if found before a comma or right paren, or after a left paren. Tabs are used wherever possible to conserve space in the segment. Parentheses are counted, and must balance at every semicolon. A warning will be printed. Lines longer than 350 characters will be split with a warning message. Illegal characters or non-pl1 characters not contained in a string will be commented upon. Some uses of the identifiers begin, end, proc, procedure, do, if, then, and else as variable names may cause the command to become confused. This is bad programming anyway. The command knows when a new statement may begin and can complain about some obvious syntax errors. */ dcl suffixes (3) char (4) init (".pl1", ".cds", ".rd"), /* all the known dialects */ suffix_lengths (3) fixed bin init (4, 4, 3), /* and their lengths */ suffix_len fixed bin; /* one of the preceding */ dcl rd_source_sw bit (1), /* flag for source to the reduction_compiler */ copy_this_comment_unchanged bit (1); /* flag to copy current comment without change */ dcl (n1, n2) char (168) aligned, /* input and output segment pathnames */ dn char (168) aligned, /* directory name */ en char (32) aligned, /* entry name */ temp_en char (32) aligned, /* entry name of temp seg. */ ap ptr, /* ptr to argument */ al fixed bin, /* lth of argument */ an fixed bin, /* current arg number */ nargs fixed bin, /* number of arguments */ expecting fixed bin init (0), /* ^=0 if expecting a numeric arg following a control arg */ bchr char (al) based (ap) unaligned, /* based char string */ (linno, indent, ntab) fixed bin, /* misc counters */ ec fixed bin (35) init (0), /* error code */ offset fixed bin (24), /* char offset in input */ (string_offset, line_offset) fixed bin (24), /* offsets where current string and line started */ string_len fixed bin, /* length of current string, for error checking */ (p, p1) ptr, /* pointers to input, output */ (icb, ice, icol) fixed bin, /* indices in line */ (chars, temchars) char (400), /* Working storage */ char char (1), /* temp */ n fixed bin, /* length of working line */ lth fixed bin (24), /* number of chars in input */ (lth1, lth2) fixed bin, /* length of args */ end_count fixed bin, /* number of END on this line */ if_count fixed bin, /* count of IF's encountered */ old_if_count fixed bin, /* previous value. */ (scolsw, /* TRUE if semicolon on line */ dclfnd, /* TRUE if DECLARE statement on line. */ dclsw, /* TRUE if in a declaration */ condsw, /* TRUE if now in if statement. */ ifsw, /* TRUE for if but not for else. */ begin_ok, /* TRUE if in an ON statement. */ else_ok, /* TRUE if else is now permitted. */ strut, /* TRUE if in structure */ sixty, /* TRUE if comment is to be pushed to col. 60 */ bos, /* TRUE if current char could be beginning of stmnt */ blsw, /* TRUE if preceding line blank */ comment, /* TRUE if currently in comment. */ newpage, /* TRUE if line contains newpage character */ string, /* TRUE if currently in string */ pstring) bit (1) aligned, /* TRUE if previous line ended in string */ bfsw bit (1) aligned init ("0"b), /* Brief mode switch */ string_error bit (1) aligned init ("0"b), (false init ("0"b), true init ("1"b)) int static options (constant) bit (1) aligned, /* named bit values */ (in, dent, dclind) fixed bin, /* indentation */ LMARGIN fixed bin init (11), /* left margin */ IN fixed bin init (5), /* subsequent indent */ CMC fixed bin init (61), /* comment column */ TABCOL fixed bin init (60), /* nearest mult of 10 < CMC */ NTAB fixed bin init (6), /* number of tabs to get to TABCOL */ nout fixed bin (24), /* number of chars in output */ colpos fixed bin, /* Column pointer in output line. (last filled col) */ parct fixed bin init (0), /* paren count. must be 0 at semicolon */ pdlx fixed bin, ifdent fixed bin, suffix char (4), suffix_assumed bit (1) init ("0"b), /* set if indent is assuming the suffix */ (i, j, k, kk, m) fixed bin (24); dcl 1 pdl (1024) aligned, /* Pushdown list. */ 2 nif fixed bin (33) unal, /* IF count. */ 2 swc bit (1) unal, /* Conditional switch. IF and ELSE */ 2 sw bit (1) unal; /* IF switch. */ dcl NP_NL_SP char (3) init static init (" "); dcl SP char (1) int static init (" "); /* Single space. */ dcl SP_TAB char (2) int static init (" "); /* Tab and space, for verify etc. */ dcl SP_LP_NOT char (3) int static init (" (^"); dcl NOT_LES_GRT char (3) int static init ("^<>"); dcl SP_TAB_COM_SEMI char (4) int static init (" ,; "); dcl SP_TAB_SEMI_NL char (4) int static init (" ; "); dcl SP_TAB_SEMI_LP_NL char (5) int static init (" ; ( "); dcl NL char (1) int static init (" "); dcl TABS char (40) int static init ((40)" "); dcl bcs char (lth) based (p) aligned; dcl bcso char (1048576) based (p1) aligned; dcl cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin), ioa_ entry options (variable), com_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), cu_$arg_count entry (fixed bin), expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)), hcs_$delentry_seg entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin (35)), hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (24), fixed bin (2), ptr, fixed bin (35)), get_pdir_ entry () returns (char (168) aligned), hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl (output_path_given, error_occurred) bit (1) aligned init ("0"b); dcl moveseg char (nout) based aligned; /* For copy of whole segment. */ dcl err_msg char (100) varying; dcl error_table_$bad_arg fixed bin (35) ext; /* Illegal command argument */ dcl error_table_$badopt fixed bin (35) ext; /* Specified control arg not implemented by this command */ dcl error_table_$noarg fixed bin (35) ext; /* Expected argument missing */ dcl error_table_$noentry fixed bin (35) ext; dcl (addr, divide, fixed, length, mod, min, null, substr, index, reverse, search, verify, unspec) builtin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call cu_$arg_count (nargs); /* get number of args */ if nargs = 0 then do; /* gripe if no args */ call com_err_ (0, "indent", "Usage: indent n1 -n2- -lm nn -in mm -cm kk -brief"); return; end; lth1, lth2 = 0; /* so we can tell if we have the pathnames yet */ arg_loop: do an = 1 to nargs; call cu_$arg_ptr (an, ap, al, ec); /* pick off next arg */ if ec ^= 0 then do; print_bad_arg: err_msg = "^a"; /* control string to just print argument */ arg_error: call com_err_ (ec, "indent", err_msg, bchr); return; end; if expecting ^= 0 then do; en = bchr; /* cv_dec_check_ needs aligned arg */ i = cv_dec_check_ (en, ec); if expecting = 1 then do; /* expecting left margin */ expecting = 0; if ec ^= 0 then do; blm: err_msg = "illegal left margin arg ^a"; cv_dec_error: ec = 0; /* cv_dec_check_ does not return an error_table_ code */ goto arg_error; /* go call com_err_ */ end; if i < 1 then goto blm; if i > 100 then goto blm; LMARGIN = i; end; else if expecting = 2 then do; /* expecting indent spaces */ expecting = 0; if ec ^= 0 then do; bint: err_msg = "illegal indent arg ^a"; goto cv_dec_error; end; if i < 0 then goto bint; if i > 100 then goto bint; IN = i; end; else do; /* must be expecting comment column */ expecting = 0; if ec ^= 0 then do; bcmc: err_msg = "illegal comment column arg ^a"; goto cv_dec_error; end; if i < 1 then goto bcmc; if i > 350 then goto bcmc; CMC = i; TABCOL = 10 * divide (CMC-1, 10, 17, 0); NTAB = divide (TABCOL, 10, 17, 0); end; end; /* end of expecting argument do group */ else do; /* not-expected-argument */ if substr (bchr, 1, 1) = "-" then do; /* Control argument? */ if bchr = "-brief" then bfsw = true; else if bchr = "-bf" then bfsw = true; else if bchr = "-lmargin" then expecting = 1; else if bchr = "-lm" then expecting = 1; else if bchr = "-indent" then expecting = 2; else if bchr = "-ind" then expecting = 2; else if bchr = "-in" then expecting = 2; else if bchr = "-comment" then expecting = 3; else if bchr = "-cm" then expecting = 3; else do; ec = error_table_$badopt; goto print_bad_arg; end; end; else do; /* Not control arg, must be filename */ if lth1 = 0 then do; /* if we don't have input filename then this is it */ n1 = bchr; /* Pick up arg 1, input name */ lth1 = al; /* Remember length for expand path */ end; else if lth2 = 0 then do; /* if we don't have output filename, this is it */ n2 = bchr; /* User gave second name. Set it up. */ lth2 = al; /* Set length of second arg. */ output_path_given = "1"b; end; else do; ec = error_table_$bad_arg; /* "Illegal command argument" */ goto print_bad_arg; /* go call com_err_ to print the bad arg */ end; end; end; /* end of not-expected-argument do group */ end arg_loop; /* end of argument processing do group */ if lth1 = 0 then do; /* if input filename not given */ err_msg = "pathname of input file"; noarg_err: ec = error_table_$noarg; goto arg_error; end; if expecting ^= 0 then do; err_msg = "after ^a"; goto noarg_err; end; if lth2 = 0 then do; /* if output path not given, use input path */ n2 = n1; lth2 = lth1; end; /* END OF ARGUMENT PROCESSING */ /* Initialization */ rd_source_sw, copy_this_comment_unchanged = false; /* flags for source to reduction_compiler */ /* and for unchangable comments. */ in, ifdent, if_count, old_if_count = 0; strut, dclsw, condsw, ifsw, begin_ok, else_ok, comment, sixty, string, pstring = false; bos, blsw = true; /* Pretend line zero was empty. */ pdlx = 1; /* Set pushdown list to empty. */ linno = 1; /* This is line 1. */ offset, nout = 1; /* read and write pointers */ i = index (reverse (substr (n1, 1, lth1)), "."); /* get last component */ if i = 0 | i > 4 then go to in_suffix; /* wrong size, don't bother */ suffix = substr (n1, lth1 - i + 1, i); /* includes "." */ do j = 1 to 3; /* .pl1, .cds, .rd */ if suffix = suffixes (j) then do; suffix_len = suffix_lengths (j); /* for later suffix processing */ go to good_suffix; end; end; /* Didn't match list of good suffices */ in_suffix: suffix = ".pl1"; /* a good guess */ suffix_len = 4; substr (n1, lth1+1, suffix_len) = suffix; /* add to name */ lth1 = lth1+suffix_len; /* adjust length */ suffix_assumed = "1"b; /* remember, this was only a guess */ good_suffix: if suffix = ".rd" then rd_source_sw = "1"b; /* remember to check for rd parse in comments */ call expand_path_ (addr (n1), lth1, addr (dn), addr (en), ec); if ec ^= 0 then go to error; call hcs_$initiate_count (dn, en, "", lth, 0, p, ec); if p = null then do; /* didn't find input seg */ if ^suffix_assumed then go to error; /* user gave suffix. Nothing more to try */ if ec ^= error_table_$noentry then go to error; /* foo.pl1 not found is the only reason to continue */ i = 34 - suffix_len - verify (reverse (en), " "); /* find suffix in entry name */ suffix = ".cds"; /* try new suffix */ suffix_len = 4; substr (en, i, suffix_len) = substr (suffix, 1, suffix_len); call hcs_$initiate_count (dn, en, "", lth, 0, p, ec); if p = null then do; /* trouble with foo.cds too */ if ec = error_table_$noentry then go to error; /* if foo.cds not found, print error about foo.pl1 */ substr (n1, lth1 - (suffix_len-1), suffix_len) = substr (suffix, 1, suffix_len); /* for other errors, print message aboout foo.cds */ go to error; end; end; if lth2 < 4 then go to out_suffix; /* out name shorter than x.rd, need suffix */ else if substr (n2, lth2 - (suffix_len-1), suffix_len) ^= substr (suffix, 1, suffix_len) then do; /* output suffix must match input */ out_suffix: substr (n2, lth2+1, suffix_len) = substr (suffix, 1, suffix_len); lth2 = lth2+suffix_len; end; lth = divide (lth+8, 9, 17, 0); /* compute bit count of input seg */ temp_en = en; /* Generate name of temp file. */ i = 34 -suffix_len - verify (reverse (temp_en), " "); /* Locate end. */ substr (temp_en, i, 4) = ".ind"; call hcs_$make_seg ((get_pdir_ ()), temp_en, "", 1010b, p1, ec); if p1 = null then go to error; call expand_path_ (addr (n2), lth2, addr (dn), addr (en), ec); if ec ^= 0 then go to error; /* This is the loop for each line in the input segment. Starting at "offset" a line of "n" chars is moved to the temporary buffer "chars". Trailing tabs and blanks are trimmed. */ loop: pstring = string; /* remember if previous line ended inside quotes */ if offset > lth then go to eof; i = index (substr (bcs, offset), NL); /* Find length of line. */ if i = 0 then i = lth - offset + 1; /* .. in case did not end in NL */ else if i = 1 then do; /* Check for empty line. */ substr (bcso, nout, 1) = NL; /* insert in output */ nout = nout + 1; linno = linno + 1; offset = offset + 1; blsw = true; go to loop; end; k = i - 1; if k > 385 then do; /* Line too big? */ k, i = 385; /* Take first 385 chars. */ call ioa_ ("indent: line ^d of ""^a"" was too long & has been split.", linno, en); error_occurred = "1"b; end; chars = substr (bcs, offset, k); /* Pick up line. */ substr (chars, k+1, 1) = NL; /* Put in NL */ line_offset = offset; /* remember where line started */ offset = offset + i; /* Increase index. */ n = k + 1; /* Set up length of line. */ if n = 1 then go to lemp; /* Empty line? */ if ^pstring then /* if not in string */ if substr (chars, 1, 1) = "%" then do; /* Is this an "include" line? */ lemp: blsw = true; /* Yes, set switch. */ go to cpy; /* And just copy line. */ end; icb, ice, icol, dent, end_count = 0; /* Set up for loop. */ scolsw, dclfnd, newpage = false; /* The following section examines each character in the current line in "chars". In this section, "i" is the character index which may be from 1 to "n". */ if pstring then do; /* If we are now in a string, */ kk = index (substr (chars, 1, n-1), """"); /* .. See if it ends on this line. */ if kk = 0 then go to cpy; /* Nope. Can't touch line at all. */ else i = kk; /* Yes. Skip string content. */ end; else i = 1; /* Examine each character in line. */ l2s: char = substr (chars, i, 1); /* Pick up a character. */ if string then do; /* Now in a string ? */ if char = """" then do; /* Watch for end */ string = false; /* not any more */ /* While this ignoring of possible double quotes within a string works ok for indenting, it throws off string length checking. However, since this checking is to help locate missing quotes, it is not really necessary to check for double quotes here. */ string_len = line_offset+i-string_offset-1; /* compute length, excluding the quotes */ if string_len > 254 then /* if string is too long, report line number to aid user in finding missing quote */ if ^bfsw then /* but only if user wants to be warned */ if ^string_error then do; /* report only the first one - if there is a missing quote, there are probably a lot more long strings */ call ioa_ ("indent: possible syntax error in line ^d of ^a: string length (^d) > pl1 max.", linno, en, string_len); string_error = "1"b; /* remember not to report any more of these */ error_occurred = "1"b; end; end; go to l2e; /* ... leaving all other chars */ end; if comment then do; /* are we now in a comment? */ if substr (chars, i, 2) = "*/" then do; /* Comment ends? */ comment = false; /* Turn off switch. */ if copy_this_comment_unchanged then /* Are we in rd reductions or in unchangable */ /* comment? Then we are done with the comment. */ copy_this_comment_unchanged = false; else do; /* Not in unchangable comment? */ if i > 1 then if index (SP_TAB, substr (chars, i-1, 1)) = 0 /* chars on line prior to comment end delimiter? */ then call inb (i); /* insert blank prior to comment end delimiter */ if i < n-2 then /* Chars on line after comment end delimiter? */ if index (SP_TAB_COM_SEMI, substr (chars, i+2, 1)) = 0 then call inb (i+2); /* Nice blank after comment */ end; ice = i; /* save index of end of comment. */ i = i + 1; /* Don't scan slash again. */ go to l2e; /* Comment leaves state unchanged. */ end; if i = 1 then do; /* Continue comment. Trim leading blanks and tabs. */ k = verify (substr (chars, 1, n-1), SP_TAB) - 1; if k = -1 then do; /* if line of just white space inside comment */ chars = ""; /* replace it wich just a newline */ substr (chars, 1, 1) = NL; n = 1; go to cpy; end; if ^copy_this_comment_unchanged /* don't disturb rd parse controls */ then do; substr (temchars, 1, n-k) = substr (chars, k+1, n-k); substr (chars, 1, 3) = ""; /* Stick in three blanks. */ substr (chars, 4, n-k) = substr (temchars, 1, n-k); i = 4; n = n - k + 3; end; end; kk = index (substr (chars, i, n-i), "*/"); /* Character inside comment. Skip out to end. */ if kk = 0 then i = n-1; else i = i + kk - 2; /* Set so we scan the comment end next. */ go to l2e; end; k = fixed (unspec (char), 9); /* See if char is ASCII */ if k < 0 then go to ilchr; if k > 126 then go to ilchr; go to case (k); /* Dispatch on character. */ /* Handlers for each character. */ /* Punctuation. */ case (009): /* HT, octal 011 */ substr (chars, i, 1) = SP; case (032): /* blank, octal 040 */ if i = 1 then go to squidge; if substr (chars, i-1, 1) = SP then do; squidge: k = verify (substr (chars, i, n-i), SP_TAB) - 1; if k > 0 then call outb (i, k); /* Remove multiple blanks and tabs. */ end; go to l2e; /* Ignore blank */ case (034): /* quote, octal 042 */ string = true; /* now in string */ string_offset = line_offset+i; /* remember where it started, for length checking */ kk = index (substr (chars, i+1, n-i), """"); /* Does string end on this line? */ if kk > 0 then i = i + kk - 1; /* Yes. Skip string contents. */ else i = n-1; /* No. Skip rest of line. */ go to cbs; case (040): /* "(", octal 050 */ parct = parct + 1; /* Increase count. */ if i > 1 then if index (SP_LP_NOT, substr (chars, i-1, 1)) = 0 then call inb (i); if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) ^= 0 then call outb (i+1, 1); go to nxchr; /* Condition prefix begins with paren. */ case (041): /* ")", octal 051 */ if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1); parct = parct - 1; /* decrease parenthesis count. */ if parct < 0 then do; /* Check for more closes than opens. */ call ioa_ ("indent: line ^d of ""^a"" has an extra "")"".", linno, en); error_occurred = "1"b; parct = 0; end; go to cbs; case (044): /* ",", octal 054 */ if i > 1 then if substr (chars, i-1, 1) = SP then call outb (i-1, 1); if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1); go to cbs; case (045): /* "-", octal 055 */ if substr (chars, i+1, 1) = ">" then do; /* Is this a pointer digraph? */ if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i); if i < n-2 then if substr (chars, i+2, 1) ^= SP then call inb (i+2); end; go to cbs; case (047): /* "/", octal 057 */ if substr (chars, i+1, 1) = "*" then do; /* Comment begins? */ comment = true; /* Now in comment. */ if i - length ("/") + length ("/****^") + length (NL) <= n then if substr (chars, i, length ("/****^")) = "/****^" then copy_this_comment_unchanged = true; /* check for comments which cannot be changed. */ if ^copy_this_comment_unchanged then do; if i > 1 then if substr (chars, i-1, 1) ^= SP then call inb (i); if i < n - length ("/") - length (NL) then if index (SP_TAB, substr (chars, i+2, 1)) = 0 /* need a blank? */ then if ^rd_source_sw /* check first for rd parse control */ then call inb (i+2); else if substr (chars, i+2, 2) = "++" /* beginning of rd parse specification? */ then copy_this_comment_unchanged = true; /* yes. remember, and don't insert blank */ else call inb (i+2); /* just a normal comment */ end; icb = i; /* Remember where comment began. */ kk = index (substr (chars, i+2, n-i-2), "*/"); /* Search for end of comment. */ if kk = 0 then i = n-1; /* Not scanning content of comment. */ else i = i + kk; /* ... */ go to l2e; /* Leave "bos" as it was when comment began. */ end; go to cbs; /* Statement don't begin with slash */ case (058): /* ":", octal 072 */ if parct > 0 then go to nxchr; /* Label can't be in parentheses. */ if bos then go to cbs; /* Null label ? */ bos = true; /* This is label. keyword ok */ icol = i + 1; /* Save index. */ if i < n-1 then if index (SP_TAB, substr (chars, i+1, 1)) = 0 then call inb (i+1); go to l2e; case (059): /* ";", octal 073 */ scolsw, bos = true; /* Semicolon. End of statement. */ begin_ok = false; if condsw then do; /* Does this end an IF? */ old_if_count = if_count; /* Save proper indent level for ELSE */ if pdlx = 1 then if_count = 0; /* Reset if_count */ else if_count = pdl (pdlx-1).nif; /* Set back to base for this level. */ condsw = false; /* Not now in conditional */ else_ok = true; end; else old_if_count = 0; /* End of some other statement. */ ifsw = false; /* Not in IF now. */ if parct > 0 then do; /* Parenthesis count should be zero. */ call ioa_ ("indent: ^d extra ""(""s at line ^d of ""^a"".", parct, linno, en); /* Complain. */ error_occurred = "1"b; parct = 0; /* Start over on count. */ end; go to l2e; case (061): /* "=", octal 075 */ if i < n-1 then if substr (chars, i+1, 1) ^= SP then call inb (i+1); m = 1; if i > 1 then if index (NOT_LES_GRT, substr (chars, i-1, 1)) ^= 0 then m = 2; if i > m then if substr (chars, i-m, 1) ^= SP then call inb (i-m+1); go to cbs; /* This section checks for reserved words by looking at the first letter. */ case (098): /* letter "b", octal 142 */ if ^bos then if ^begin_ok then go to nxchr; /* Must be at begin of statement or in ON */ if parct > 0 then go to nxchr; /* ignore begins in parens */ if i <= n-5 then if substr (chars, i, 5) = "begin" then if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 6 then do; i = i + 4; /* Skip over rest of word. */ in_found: if ifsw then if_count = if_count - 1; /* Don't do extra indent. */ pdl (pdlx).sw = ifsw; /* Push down current if switch. */ pdl (pdlx).swc = condsw; /* .. and conditional switch. */ pdl (pdlx).nif = if_count; /* .. and if indentation. */ pdlx = pdlx + 1; /* .. */ if pdlx = 1024 then do; /* If nesting depth too great, die. */ call com_err_ (0, "indent", "FATAL ERROR. Line ^d of ""^a"" nesting depth > 1024", linno, en); return; end; condsw = false; /* Now not in IF */ ifsw = false; dent = dent + 1; /* Increase indentation level. */ end; go to nxchr; case (100): /* letter "d", octal 144 */ if parct > 0 then go to nxchr; /* reserved word not in parens */ if ^bos then go to nxchr; /* Must be at beginning of statement. */ kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL); if kk = 3 then if substr (chars, i, 2) = "do" then do; i = i + 1; /* Found DO statement. */ go to in_found; end; if condsw then go to nxchr; /* Declaration cannot be inside an IF */ if i = 1 then do; /* declare stm must start in col 1 ... */ if kk = 4 then if substr (chars, i, 3) = "dcl" then do; dclfnd = true; /* Found DCL statement. */ i = i + 2; dclind = 4; go to nxchr; end; if kk = 8 then if substr (chars, i, 7) = "declare" then do; dclfnd = true; /* Found DECLARE statement. */ i = i + 6; dclind = 8; go to nxchr; end; end; go to nxchr; case (101): /* letter "e", octal 145 */ if parct > 0 then go to nxchr; /* keyword not appear in parens. */ if ^bos then go to nxchr; /* Must be in beginning-of-statment state. */ kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL); if else_ok then if kk = 5 then if substr (chars, i, 4) = "else" then do; if_count = old_if_count - 1; /* Restore old IF indentation. */ ifdent = old_if_count - 1; /* Outdent the ELSE to the corresponding IF */ else_ok = false; /* ELSE may not follow ELSE. */ if if_count > 0 then condsw = true; /* But may follow after semi. */ bos = true; /* Statement may follow ELSE. */ i = i + 3; go to l2e; end; if condsw then go to nxchr; /* Cannot say "then end" */ if kk = 4 then if substr (chars, i, 3) = "end" then do; end_count = end_count + 1; /* Found END statement. */ if pdlx > 1 then do; /* Unstack IF state. */ pdlx = pdlx - 1; /* .. */ ifsw = pdl (pdlx).sw; /* .. */ condsw = pdl (pdlx).swc; /* ... */ if_count = pdl (pdlx).nif; /* .. */ if ifsw then if_count = if_count + 1; end; if (in - end_count + dent) < 0 then do; /* Too many END's? */ call ioa_ ("indent: line ^d of ""^a"" has an extra ""end"".", linno, en); dent, in, end_count = 0; /* Start over on indents */ error_occurred = "1"b; end; i = i + 2; end; go to nxchr; case (105): /* letter "i", octal 151 */ if parct > 0 then go to nxchr; if ^bos then go to nxchr; if i <= n-2 then if substr (chars, i, 2) = "if" then if search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL) = 3 then do; condsw = true; /* Set IF encountered flag. */ ifsw = true; i = i + 1; end; go to nxchr; case (116): /* letter "t", octal 164 */ if parct > 0 then go to nxchr; /* Look for THEN keyword. */ if bos then go to nxchr; /* THEN cannot begin a statement. */ if ^ifsw then go to nxchr; /* and some IF must have come up. */ if i ^= 1 then if substr (chars, i-1, 1) ^= SP then go to nxchr; if i <= n-4 then if substr (chars, i, 4) = "then" then if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 5 then do; bos = true; /* Found THEN. Statement may follow. */ i = i + 3; if_count = if_count + 1; go to l2e; end; go to nxchr; case (111): /* letter "o", octal 157 */ if ^bos then go to nxchr; /* Check for ON statement. */ if parct > 0 then go to nxchr; if i <= n-2 then if substr (chars, i, 2) = "on" then if search (substr (chars, i, n-i+1), SP_TAB_SEMI_NL) = 3 then do; begin_ok = true; /* ON statement may contain BEGIN */ i = i + 1; end; go to nxchr; case (112): /* letter "p", octal 160 */ if parct > 0 then go to nxchr; if ^bos then go to nxchr; if condsw then go to nxchr; /* Cannot say "then proc" */ k = 3; kk = search (substr (chars, i, n-i+1), SP_TAB_SEMI_LP_NL); if kk = 5 then if substr (chars, i, 4) = "proc" then go to procfnd; k = 8; if kk = 10 then if substr (chars, i, 9) = "procedure" then do; procfnd: i = i + k; /* Skip scan of keyword. */ go to in_found; /* Increase indentation level */ end; go to nxchr; /* Illegal characters. Squawk and continue. */ case (000): /* NUL, octal 000 */ case (001): /* undefined, octal 001 */ case (002): /* undefined, octal 002 */ case (003): /* undefined, octal 003 */ case (004): /* undefined, octal 004 */ case (005): /* undefined, octal 005 */ case (006): /* undefined, octal 006 */ case (007): /* BEL, octal 007 */ case (008): /* BS, octal 010 */ case (013): /* CR, octal 015 */ case (014): /* RRS, octal 016 */ case (015): /* BRS, octal 017 */ case (016): /* undefined, octal 020 */ case (017): /* undefined, octal 021 */ case (018): /* undefined, octal 022 */ case (019): /* undefined, octal 023 */ case (020): /* undefined, octal 024 */ case (021): /* undefined, octal 025 */ case (022): /* undefined, octal 026 */ case (023): /* undefined, octal 027 */ case (024): /* undefined, octal 030 */ case (025): /* undefined, octal 031 */ case (026): /* undefined, octal 032 */ case (027): /* undefined, octal 033 */ case (028): /* undefined, octal 034 */ case (029): /* undefined, octal 035 */ case (030): /* undefined, octal 036 */ case (031): /* EGM, octal 037 */ ilchr: call ioa_ ("indent: warning: illegal character (octal ^3.3b) in line ^d of ""^a""", unspec (substr (chars, i, 1)), linno, en); error_occurred = "1"b; go to l2e; case (033): /* "!", octal 041 */ case (035): /* sharp, octal 043 */ case (039): /* "'", octal 047 */ case (063): /* "?", octal 077 */ case (064): /* at-sign, octal 100 */ case (091): /* "[", octal 133 */ case (092): /* escape (backslash), octal 134 */ case (093): /* "]", octal 135 */ case (096): /* "`", octal 140 */ case (123): /* "{", octal 173 */ case (125): /* "}", octal 175 */ case (126): /* tilde, octal 176 */ if ^bfsw then do; /* Unless brief mode, gripe */ call ioa_ ("indent: warning: non-pl1 char ""^a"" outside string in line ^d of ""^a""", substr (chars, i, 1), linno, en); error_occurred = "1"b; end; go to l2e; /* Chars which are legal but cannot begin a statement. */ case (036): /* "$", octal 044 */ case (038): /* "&", octal 046 */ case (042): /* "*", octal 052 */ case (043): /* "+", octal 053 */ case (046): /* ".", octal 056 */ case (048): /* digit "0", octal 060 */ case (049): /* digit "1", octal 061 */ case (050): /* digit "2", octal 062 */ case (051): /* digit "3", octal 063 */ case (052): /* digit "4", octal 064 */ case (053): /* digit "5", octal 065 */ case (054): /* digit "6", octal 066 */ case (055): /* digit "7", octal 067 */ case (056): /* digit "8", octal 070 */ case (057): /* digit "9", octal 071 */ case (060): /* "<", octal 074 */ case (062): /* ">", octal 076 */ case (094): /* circumflex, octal 136 */ case (095): /* underscore, octal 137 */ case (124): /* "|", octal 174 */ cbs: if bos then if ^bfsw then do; call ioa_ ("indent: possible syntax error in line ^d of ^a detected at char ""^a""", linno, en, substr (chars, i, 1)); error_occurred = "1"b; end; /* Chars which are legal beginnings of statement. */ case (037): /* "%", octal 045 */ case (065): /* letter "A", octal 101 */ case (066): /* letter "B", octal 102 */ case (067): /* letter "C", octal 103 */ case (068): /* letter "D", octal 104 */ case (069): /* letter "E", octal 105 */ case (070): /* letter "F", octal 106 */ case (071): /* letter "G", octal 107 */ case (072): /* letter "H", octal 110 */ case (073): /* letter "I", octal 111 */ case (074): /* letter "J", octal 112 */ case (075): /* letter "K", octal 113 */ case (076): /* letter "L", octal 114 */ case (077): /* letter "M", octal 115 */ case (078): /* letter "N", octal 116 */ case (079): /* letter "O", octal 117 */ case (080): /* letter "P", octal 120 */ case (081): /* letter "Q", octal 121 */ case (082): /* letter "R", octal 122 */ case (083): /* letter "S", octal 123 */ case (084): /* letter "T", octal 124 */ case (085): /* letter "U", octal 125 */ case (086): /* letter "V", octal 126 */ case (087): /* letter "W", octal 127 */ case (088): /* letter "X", octal 130 */ case (089): /* letter "Y", octal 131 */ case (090): /* letter "Z", octal 132 */ case (097): /* letter "a", octal 141 */ case (099): /* letter "c", octal 143 */ case (102): /* letter "f", octal 146 */ case (103): /* letter "g", octal 147 */ case (104): /* letter "h", octal 150 */ case (106): /* letter "j", octal 152 */ case (107): /* letter "k", octal 153 */ case (108): /* letter "l", octal 154 */ case (109): /* letter "m", octal 155 */ case (110): /* letter "n", octal 156 */ case (113): /* letter "q", octal 161 */ case (114): /* letter "r", octal 162 */ case (115): /* letter "s", octal 163 */ case (117): /* letter "u", octal 165 */ case (118): /* letter "v", octal 166 */ case (119): /* letter "w", octal 167 */ case (120): /* letter "x", octal 170 */ case (121): /* letter "y", octal 171 */ case (122): /* letter "z", octal 172 */ nxchr: bos = false; /* No longer at beginning of statement. */ else_ok = false; /* ELSE no longer legal. */ go to l2e; /* Chars which do not preclude beginning of statement. */ case (012): /* NP, octal 014 */ newpage = "1"b; /* remember line contained NP */ case (010): /* NL, octal 012 */ case (011): /* VT, octal 013 */ l2e: i = i + 1; /* Increase index in working array. */ if i < n then go to l2s; /* If any chars left, go thru again. */ /* come here when all characters in line examined */ i = 1; /* "i" will be the index in the "chars" buffer. */ if newpage then do; /* special test if newpage encountered */ if verify (substr (chars, 1, n), NP_NL_SP) = 0 then do; /* if line is all spaces, newpages, and newlines */ n = 2; /* make new short line */ chars = substr (NP_NL_SP, 1, 2); /* of newpage and newline */ blsw = true; /* this is a blank line */ go to cpy; end; end; if icb = 1 then do; /* Does line start with comment? */ if blsw then do; /* Yes. Previous line empty? */ sixty = false; /* Yes, start in column 1. */ go to cpy; /* Just copy line. */ end; push: sixty = true; /* Comment goes in column 60. */ ntab = NTAB; i = 1; go to nimcom; end; if icb = 0 then if (comment | ice > 0) then do; /* Continuation of comment? */ if sixty then go to push; /* Do we indent it? */ cpy: substr (bcso, nout, n) = substr (chars, 1, n); /* Copy whole line. */ nout = nout + n; go to finish_line; end; /* This section computes the left margin for each line. */ blsw = false; /* Not empty line. */ if pstring then do; indent = 0; /* don't indent inside quoted string */ icol = 0; end; else if dclfnd then do; /* Does line begin with DCL? */ dclfnd = false; /* Yes. */ dclsw = true; /* We are in a declaration now. */ if index ("0123456789", substr (chars, dclind+1, 1)) ^= 0 then strut = true; else strut = false; icol = dclind; /* Copy first dclind chars without indent. */ if strut then indent = dclind+1; /* Indent dclind+1 in structure */ else if substr (chars, dclind+1, 1) = "(" then indent = dclind+1; /* ... or in factored dcl, */ else indent = dclind+2; /* ... otherwise dclind+2. */ end; else if dclsw then do; /* Are we in old declaration? */ icol = 0; /* Yes. */ kk = index ("0123456789", substr (chars, 1, 1)) - 1; if strut & kk >= 0 then do; /* If structure, use level number. */ k = kk; /* Convert to number. */ kk = index ("0123456789", substr (chars, 2, 1)) - 1; if kk >= 0 then k = k*10 + kk; indent = dclind + k + k - 3; /* calculate proper indentation */ end; /* typically, this yields . dcl 1 s, . 2 l1, . 2 l2, . 3 l3; etc. */ else if substr (chars, 1, 1) = "(" then do; if strut then do; /* we have factored level declarations */ k = index ("0123456789", substr (chars, 2, 1)) - 1; if k > 0 /* better be */ then do; kk = index ("0123456789", substr (chars, 3, 1)) - 1; /* look for level > 9 */ if kk > 0 then k = 10 * k + kk; indent = dclind + k + k - 4; /* subtract 1 more to allow for paren */ end; /* should report the following, but can't tell the difference between missing level number and just initialize... else call ioa_ ("indent: No level number follows ""("" in structure. Line ^d in ""^a"". Continuing.", linno, en); */ end; else indent = dclind + 1; /* no structure */ end; else indent = dclind+2; /* No. */ end; else do; /* Normal statement. */ k = min (end_count, dent); /* May be both do and end on same line. */ end_count = end_count - k; /* If so, do not "outdent" */ dent = dent - k; /* ... */ indent = (in + ifdent - end_count - 1) * IN + LMARGIN; /* Compute indentation. */ if indent < 0 then indent = 0; /* No negative indent. */ end; /* This section copies the line into the output seg, inserting blanks and tabs. */ if icol >= n then go to cpy; /* If line is just a label, do it the easy way. */ colpos = 0; /* Remember where started. */ if icol ^= 0 then do; substr (bcso, nout, icol) = substr (chars, 1, icol); /* Copy label section if any. */ nout = nout + icol; /* Increase offset. */ colpos = colpos + icol; /* and column. */ end; i = icol + 1; if i ^= icb then /* Handle case of just label and comment. */ if indent > icol then do; /* Must insert blanks. */ if substr (chars, icol, 1) = SP then do; /* a blank was included in icol for labels */ icol = icol - 1; /* Back up by one char, to prevent space-tab. */ colpos = colpos - 1; nout = nout - 1; end; k = indent - icol - 1; /* Calculate number of blanks required. */ colpos = colpos + k; /* Calculate new column position in output. */ if colpos >= 10 then do; /* Replace blanks by tabs if possible. */ kk = divide (colpos, 10, 17, 0) - divide (icol, 10, 17, 0); if kk > 0 then do; substr (bcso, nout, kk) = substr (TABS, 1, kk); nout = nout + kk; k = mod (colpos, 10); /* Tab column might not be multiple of 10 */ end; end; if k ^= 0 then do; substr (bcso, nout, k) = ""; /* Run in blanks. */ nout = nout + k; end; end; if ice ^= 0 then if ice = n-2 then go to havcom; /* If comment is last thing on line, */ if ice ^= 0 then if ice = n-3 then if substr (chars, n-1, 1) = ";" then go to havcom; /* or if comment is last on line except end of statement, */ if ice = 0 then if icb > 0 then do; /* or if comment starts on this line and doesn't end.. */ havcom: sixty = true; /* Yes, move comment to column 60. */ k = icb-i; /* Copy statement part. */ if k ^= 0 then do; substr (bcso, nout, k) = substr (chars, i, k); nout = nout + k; colpos = colpos + k; /* Keep track of column. */ i = i + k; end; if colpos < TABCOL then do; /* If statement does not reach to col. 60, */ if substr (bcso, nout-1, 1) = SP then do; /* Avoid space-tab sequence. */ nout = nout - 1; colpos = colpos - 1; end; if substr (chars, i, 1) = SP then i = i + 1; /* ... */ ntab = divide (TABCOL-colpos-1, 10, 17, 0) + 1; /* Compute number of tabs to get there. */ nimcom: if ntab ^= 0 then do; substr (bcso, nout, ntab) = substr (TABS, 1, ntab); nout = nout + ntab; end; colpos = TABCOL; end; k = CMC - colpos - 1; /* In case tab column not 10 * x + 1 */ if k > 0 then do; substr (bcso, nout, k) = ""; /* Run in blanks */ nout = nout + k; end; end; k = n - i + 1; if k ^= 0 then do; substr (bcso, nout, k) = substr (chars, i, k); /* Copy remainder of line. */ nout = nout + k; end; in = in - end_count + dent; /* Adjust indentation base for next line. */ ifdent = if_count; /* Set IF's to indent. */ if ^bos then if ^ifsw then ifdent = ifdent + 1; /* .. if statement is continued, indent 5 more. */ dclsw = dclsw & ^ scolsw; /* In declaration if were in and no semicolon. */ /* Finished with the line. Go get another. */ finish_line: linno = linno + 1; /* Count line. */ if nout ^> 2 then go to loop; /* too short to check */ i = verify (reverse (substr (bcso, 1, nout-2)), SP_TAB); /* check for trailing white space in line copied */ if i = 1 then go to loop; /* there was none */ if i = 0 then i = nout - 2; /* there was a lot */ else i = i - 1; /* there was some */ if string then do; /* if in a string, bad news because its invisible */ if ^bfsw then call ioa_ ("indent: Line ^d of ""^a"" contains trailing white space that is part of a string.", linno - 1, en); go to loop; /* Don't change */ end; nout = nout - i; /* back up end over white space */ substr (bcso, nout-1, 1) = NL; /* put in a new newline */ unspec (substr (bcso, nout, i)) = "0"b; /* clean out the extra stuff that was moved in */ go to loop; /* Control comes here when the input segment is exhausted. */ eof: if in > 0 then if ^(rd_source_sw & in = 1) /* rd source should be missing one "end" */ then do; call ioa_ ("indent: ""^a"" has ^d too few ""end""s.", en, in); error_occurred = "1"b; end; else; else if rd_source_sw then do; call ioa_ ("indent: The reduction_compiler source ""^a"" has one too many ""end""s.", en); error_occurred = "1"b; end; if string then do; call ioa_ ("indent: ""^a"" ends in a string.", en); error_occurred = "1"b; end; if comment then do; call ioa_ ("indent: ""^a"" ends in a comment.", en); error_occurred = "1"b; end; if parct > 0 then do; call ioa_ ("indent: ""^a"" has ^d extra ""(""s.", en, parct); error_occurred = "1"b; end; call hcs_$terminate_noname (p, ec); /* Terminate input segment. */ lth = 9 * (nout-1); /* Compute bit count. */ call hcs_$set_bc_seg (p1, lth, ec); /* Set bit count on temp, in case of error. */ if error_occurred then if ^output_path_given then do; call com_err_ (0, "indent", "Input segment not replaced. Indented copy is in [pd]>^a", temp_en); return; end; call hcs_$make_seg (dn, en, "", 1011b, p, ec); /* Get ptr to final output. Make if necessary */ if p = null then go to error1; call hcs_$truncate_seg (p, 0, ec); /* Truncate target. */ if ec ^= 0 then do; error1: call com_err_ (ec, "indent", "Cannot copy ^a from [pd]>^a", en, temp_en); return; end; p -> moveseg = p1 -> moveseg; /* Zap. */ call hcs_$set_bc_seg (p, lth, ec); /* Set bit count. */ call hcs_$terminate_noname (p, ec); /* Terminate output. */ call hcs_$delentry_seg (p1, ec); /* Delete scratch segment. */ return; /* Happy return. */ error: call com_err_ (ec, "indent", n1); /* Here to gripe to user */ return; /* And give up */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* Insert a blank at "ix" */ inb: proc (ix); dcl ix fixed bin (24); /* Index in work array where blank goes. */ substr (temchars, 1, n-ix+1) = substr (chars, ix, n-ix+1); substr (chars, ix+1, n-ix+1) = substr (temchars, 1, n-ix+1); substr (chars, ix, 1) = SP; /* Insert blank. */ n = n + 1; /* Up the line length. */ if ix <= i then i = i + 1; /* did we change the character looked at? */ end inb; /* This procedure removes "nn" blanks starting at "ix" */ outb: proc (ix, nn); dcl ix fixed bin (24); dcl nn fixed bin (24); substr (temchars, 1, n-ix-nn+1) = substr (chars, ix+nn, n-ix-nn+1); substr (chars, ix, n-ix-nn+1) = substr (temchars, 1, n-ix-nn+1); n = n - nn; if ix = i then i = i - 1; /* Back up one if now looking at new char. */ else if ix < i then i = i - nn; end outb; end indent;  ma_analyze_.pl1 11/04/82 1951.6rew 11/04/82 1609.2 74970 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ma_analyze_: proc (a_maip); default (fixed&^precision&^constant) precision (21); /* DEFAULT */ default (constant&real&^decimal) binary; /* MA_ANALYZE_ prints divergent text, and call the editor if need be. */ /* Recoded Spring '77 RE Mullen */ /* Modified 11/10/80 Jay Pattin for cpa -output_file */ %include merge_ascii_info; /* */ dcl a_maip ptr; dcl nd bit (1) aligned; /* if ^nd then only print new, sans old, context, commentary */ dcl i fixed bin; dcl j fixed bin; dcl first_zero fixed bin; dcl autox fixed bin; dcl ch char (999) based; dcl varch char (100) varying; dcl context_type char (16); dcl Context_type char (16); dcl skipchars (0:1) char (1) unal based; dcl NL char (1) init (" "); dcl ma_edit_ entry (ptr); dcl (ioa_$ioa_switch, ioa_$ioa_switch_nnl) entry options (variable); /* */ /* If we are doing a merge, extra white space improves readability. */ /* This is because we enter the editor between sucessive sets of differences */ /* If we are doing a comparison, more white space is confusing. */ ma_info_ptr = a_maip; nd = ^print_new_lines; /* nd = non-discriminatory */ if synchlen = 0 then do; context_type = "at end."; Context_type = "At end"; end; else do; context_type = "preceding:"; Context_type = "Preceding:"; end; if have_orig then do; if have_output then do; autox = AUTOX (); if autox ^= 0 then do; call take_diff (autox); /* pick up the change */ return; /* all done */ end; end; if nd then call ioa_$ioa_switch (output_iocb_ptr, ""); if difflen (lo) > 0 then do; /* [a] non null */ if nd then call print_diff (lo); do i = lo + 1 to hi; if difflen (i) > 0 & same_as (i) = 0 then do; /* change */ if nd then do; varch = textid (i); call set_same_varch (i); if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr,"Changed by ^a to:", varch); end; call print_diff (i); end; end; if nd then do; varch = ""; /* note unchanged texts */ call set_same_varch (lo); if varch ^= "" then do; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr, "Unchanged by ^a", varch); end; call set_varch_zero; /* note deletes */ if varch ^= "" then do; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr, "Deleted by ^a, ^a", varch, context_type); call print_context (first_zero); end; end; end; else do; /* [a] null: inserts only */ do i = lo + 1 to hi; if difflen (i) > 0 & same_as (i) = 0 then do; /* insert */ if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); if nd then do; varch = textid (i); call set_same_varch (i); call ioa_$ioa_switch (output_iocb_ptr, "Inserted in ^a:", varch); end; call print_diff (i); end; end; if nd then do; call set_varch_zero; if varch ^= "" then do; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr, "Nothing inserted in ^a", varch); end; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr, "^a", Context_type); call print_context (lo); end; end; if nd then call ioa_$ioa_switch (output_iocb_ptr, ""); if have_output then call ma_edit_ (ma_info_ptr); return; end; else do; /* no original */ call ioa_$ioa_switch (output_iocb_ptr, ""); do i = lo to hi; if difflen (i) > 0 & same_as (i) = 0 then do; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); varch = textid (i); call set_same_varch (i); call ioa_$ioa_switch (output_iocb_ptr, "Present in ^a:", varch); call print_diff (i); end; end; varch = ""; call set_varch_zero; if varch ^= "" then do; if have_output then call ioa_$ioa_switch (output_iocb_ptr, ""); call ioa_$ioa_switch (output_iocb_ptr, "Nothing present in ^a, ^a", varch, context_type); call print_context (first_zero); end; call ioa_$ioa_switch (output_iocb_ptr, ""); if have_output then call ma_edit_ (ma_info_ptr); end; /* */ print_diff: proc (x); /* IP to print diff block if interesting */ dcl xp ptr; dcl x fixed bin; dcl sax fixed bin; dcl (i, j, k) fixed bin; xp = cp (x); k = 0; do i = 1 to difflines (x); j = index (substr (xp -> ch, k+1, difflen (x) - k), NL); if j = 0 then j = difflen (x) - k; if no_line_numbers then call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a", substr (xp -> ch, k+1, j)); else call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a^d^-^a", textid (x), line (x)+i-1, substr (xp -> ch, k+1, j)); k = k + j; end; if k ^= difflen (x) then call ioa_$ioa_switch (output_iocb_ptr, "print_diff: k ^= difflen"); end print_diff; /* */ print_context: proc (x); /* IP to print lines following insert|delete */ dcl x fixed bin; dcl (i, j, k) fixed bin; dcl restlen fixed bin; dcl restline fixed bin; dcl restp ptr; dcl restrel fixed bin; if synchlen = 0 then return; restlen = len (x) - difflen (x); restrel = 0; restline = line (x) + difflines (x); restp = addr (cp (x) -> skipchars (difflen (x))); do i = 1 to min (synchlines, 5); j = index (substr (restp -> ch, restrel+1, restlen), NL); if j = 0 then j = restlen; if no_line_numbers then call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a", substr (restp -> ch, restrel+1, j)); else call ioa_$ioa_switch_nnl (output_iocb_ptr, "^a^d^-^a", textid (x), restline, substr (restp -> ch, restrel+1, j)); if j > 1 then return; restline = restline + 1; restrel = restrel + j; restlen = restlen - j; end; end print_context; /* */ take_diff: proc (tdi); /* IP to pick up changed text */ dcl tdi fixed bin; if difflen (tdi) = 0 then return; /* evid was deletion */ substr (cp (1) -> ch, 1, difflen (tdi)) = substr (cp (tdi) -> ch, 1, difflen (tdi)); cp (1) = addr (cp (1) -> skipchars (difflen (tdi))); tchars (1) = tchars (1) + difflen (tdi); tlines (1) = tlines (1) + difflines (tdi); end take_diff; /* */ AUTOX: proc returns (fixed bin); dcl (ai, aj, ak) fixed bin; aj, ak = 0; do ai = lo + 1 to hi; /* set ai to first text that changed */ if same_as (ai) = 0 then do; aj = ai; go to a_other; end; end; call ioa_$ioa_switch (output_iocb_ptr, "ma_analyze_: called when blocks dont differ. Non-fatal."); return (lo); /* take any, eg orig */ a_other: do ai = aj+1 to hi; /* see if 2nd distinct change OR ident change to ai */ if same_as (ai) = 0 then return (0); /* 2nd distinct change, bomb */ else if same_as (ai) = aj then if ^convergence_ok then return (0); end; if edit (aj) then return (0); else return (aj); end AUTOX; /* */ set_varch_zero: proc; /* IP to set varch to zero_len B-G */ dcl szvi fixed bin; varch = ""; do szvi = 3 to hi; if difflen (szvi) = 0 then do; if varch = "" then do; varch = textid (szvi); first_zero = szvi; end; else varch = varch || ", " || textid (szvi); end; end; end set_varch_zero; set_same_varch: proc (ssvi); /* IP to set varch to B-G same as param */ dcl (ssvi, ssvj) fixed bin; do ssvj = ssvi + 1 to hi; if same_as (ssvj) = ssvi then do; if varch = "" then varch = textid (ssvj); else varch = varch || ", " || textid (ssvj); end; end; end set_same_varch; end ma_analyze_;  ma_edit_.pl1 11/04/82 1951.6rew 11/04/82 1627.5 101592 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ma_edit_: proc (a_info_ptr); default (fixed&^precision&^constant) precision (21); /* DEFAULT */ default (constant&real&^decimal) binary; /* MA_EDIT_ performs simple editing for merge_ascii subsystem */ /* Recoded RE Mullen Spring '77 */ /* Modified "x" request to print archive cpt THVV 1980 */ dcl a_info_ptr ptr; dcl (i, j, k) fixed bin; dcl code fixed bin (35); dcl (ioa_, ioa_$nnl) entry options (variable); dcl (iox_$user_input, iox_$user_output) ptr ext; dcl iox_$control entry (ptr, char (*) aligned, ptr, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35), fixed bin); dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); dcl skipchars (0:1) char (1) unal based; dcl ch char (999) based; dcl (start_line, end_line) fixed bin; dcl nl char (1) init (" "); dcl temp_ptr ptr; /* temps for dealing with block of text */ dcl dirn char (168); dcl en char (32); dcl cpt char (32); dcl temp_chars fixed bin; dcl temp_lines fixed bin; dcl (rbuff, buff) char (200); dcl (rnc, nc) fixed bin; dcl n fixed bin; dcl req char (n) based (addr (buff)); /* ENDCL */ /* */ %include merge_ascii_info; /* */ ma_info_ptr = a_info_ptr; difflen (1) = 0; difflines (1) = 0; line (1) = tlines (1) + 1; pedit: call ioa_ ("EDIT"); rnc = 0; read_loop: /* DEBUGGING */ /* call ioa_ (" i tp tl tc cp dl dc line"); do i = 1 to hi; call ioa_ ("^10d ^p^-^10d^10d ^p^-^10d^10d^10d", i, tptr (i), tlines (i), tchars (i), cp (i), difflines (i), difflen (i), line (i)); end; /* END DEBUGGING */ if rnc = 0 then do; call iox_$get_line (iox_$user_input, addr (rbuff), 200, rnc, code); end; if substr (rbuff, 1, 2) = "e " then do; /* EXECUTE --- call cp with rest of line */ substr (rbuff, 1, 1) = ""; call cu_$cp (addr (rbuff), rnc, code); rnc = 0; go to read_loop; end; nc = index (substr (rbuff, 1, rnc), " "); if nc = 0 then nc = rnc; substr (buff, 1, nc) = substr (rbuff, 1, nc); if nc ^= rnc then substr (rbuff, 1, rnc-nc) = substr (rbuff, nc + 1, rnc-nc); /* shift whats left */ rnc = rnc - nc; /* accout for what we took */ n = nc - 1; /* get real number of chars in req */ if req = "" then; /* ignore null req */ else if n = 1 then do; /* some one char req */ if req = "x" then do; /* STATUS --- relate texids to paths, etc. */ call ioa_ ("text line nos.^-path"); do i = 2 to ma_max_texts, 1; if tptr (i) ^= null () then do; if i = 1 then do; /* print true output path, not temp */ dirn = op_dirname; en = op_ename; cpt = ""; end; else do; dirn = dirname (i); en = ename (i); cpt = component (i); end; if difflines (i) = 0 then call ioa_ ("^a^-^-^a>^a^[::^a^;^s^]", textid (i), dirn, en, (cpt ^= ""), cpt); else if difflines (i) = 1 then call ioa_ ("^a^9d^-^a>^a^[::^a^;^s^]", textid (i), line (i), dirn, en, (cpt ^= ""), cpt); else call ioa_ ("^a^9d,^d^-^a>^a^[::^a^;^s^]", textid (i), line (i), line (i) + difflines (i) - 1, dirn, en, (cpt ^= ""), cpt); end; end; end; else go to UNREQ; /* no other single char is valid req */ end; else if req = "input" then do; /* INPUT --- accept "none of the above" */ if rnc > 0 then go to MB_LAST; call ioa_ ("INPUT"); i_loop: call iox_$get_line (iox_$user_input, addr (rbuff), 200, rnc, code); if rnc = 2 then if substr (rbuff, 1, 1) = "." then go to pedit; substr (cp (1) -> ch, difflen (1) + 1, rnc) = substr (rbuff, 1, rnc); tchars (1) = tchars (1) + rnc; tlines (1) = tlines (1) + 1; difflen (1) = difflen (1) + rnc; difflines (1) = difflines (1) + 1; go to i_loop; end; else if req = "go" then do; /* GO --- return from editor to compare loop */ if rnc > 0 then do; MB_LAST: call ioa_ ("^a must be the last request on a line.", req); go to RESET; end; cp (1) = addr (cp (1) -> skipchars (difflen (1))); return; end; else if req = "help" then do; /* HELP --- tell requests possible */ call ioa_ ("Edit requests:"); call ioa_ ("bk copy previously printed block from text b."); call ioa_ ("bx,yk copy lines x though y from segment b."); call ioa_ ("bx,yp print lines x through y from segment b."); call ioa_ ("md undo all edit requests since changes last displayed."); call ioa_ ("input enter input mode."); call ioa_ (". return from input mode to edit mode."); call ioa_ ("go exit editor and continue comparison."); call ioa_ ("quit abort merge."); call ioa_ ("e execute rest of line."); call ioa_ ("x provide text status."); call ioa_ ("help provide help to user."); end; else if req = "quit" then do; /* QUIT --- abort this merge */ if rnc > 0 then go to MB_LAST; go to abort_label; end; else if substr (req, n, 1) = "p" then do; /* PRINT --- display lines */ call GET_ADDR; call PRINTEMPS (i); end; else if substr (req, n, 1) = "k" then do; /* KOPY --- take specified lines */ call GET_ADDR; call TAKE_TEMPS; end; else if substr (req, n, 1) = "d" then do; /* DELETE --- undo recent choices */ if n ^= 2 then do; DELIMP: call ioa_ ("cannot ""^a"": the only delete request possible is ""md""", req); go to RESET; end; if substr (req, 1, 1) ^= "m" then go to DELIMP; tchars (1) = tchars (1) - difflen (1); tlines (1) = tlines (1) - difflines (1); difflen (1), difflines (1) = 0; end; else do; /* LOSE */ UNREQ: call ioa_ ("cannot ""^a"": unrecognized request", req); go to RESET; NO_BLOCK: call ioa_ ("cannot ""^a"": current block is empty", req); go to RESET; RESET: code = 0; rnc = 0; call iox_$control (iox_$user_input, "resetread", null (), 0); end; go to read_loop; /* */ GET_ADDR: proc; /* IP to determine addressed lines */ i = index (ma_text_ids, substr (req, 1, 1)); if i = 0 then do; BAD_TID: call ioa_ ("cannot ""^a"": invalid text identifier ""^a""", req, substr (req, 1, 1)); go to RESET; end; if tptr (i) = null () then go to BAD_TID; if n = 2 then do; /* entire block */ if difflen (i) = 0 then go to NO_BLOCK; /* null block */ temp_chars = difflen (i); temp_lines = difflines (i); temp_ptr = cp (i); start_line = line (i); end; else do; call READ_LINNOS (i, 1); call SET_TEMPS (i); end; end GET_ADDR; /* */ TAKE_TEMPS: proc ; /* IP to pick up changed text */ if temp_chars = 0 then return; /* evid was nothing there */ substr (cp (1) -> ch, difflen (1) + 1, temp_chars) = substr (temp_ptr -> ch, 1, temp_chars); tchars (1) = tchars (1) + temp_chars; tlines (1) = tlines (1) + temp_lines; difflen (1) = difflen (1) + temp_chars; difflines (1) = difflines (1) + temp_lines; end TAKE_TEMPS; /* */ READ_LINNOS: proc (segx, oplen); dcl segx fixed bin; /* segment index */ dcl oplen fixed bin; /* length of operator: eg "p" */ dcl LC fixed bin; dcl cv_dec_check_ entry (char (*) aligned, fixed bin (35)) returns (fixed bin); dcl x fixed bin; LC = n - oplen - 1; /* subtract oplen and textid from req len */ if difflen (segx) = 0 then do; /* "<" and ">" are undefined */ if index (substr (buff, 2, LC), "<") > 0 then go to NO_BLOCK; else if index (substr (buff, 2, LC), ">") > 0 then go to NO_BLOCK; end; x = index (substr (buff, 2, LC), ","); if x = 1 then do; call ioa_ ("cannot ""^a"": no numeral before comma", req); go to RESET; end; else if x = LC then do; call ioa_ ("cannot ""^a"": no numeral after comma", req); go to RESET; end; else if x = 0 then do; /* only one number given */ if substr (buff, 2, LC) = "<" then start_line = line (segx); else if substr (buff, 2, LC) = ">" then start_line = line (segx) + difflines (segx) -1; else do; start_line = cv_dec_check_ (substr (buff, 2, LC), code); if code ^= 0 then do; call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2, LC)); go to RESET; end; end; end_line = start_line; end; else do; /* comma and two numbers? */ if substr (buff, 2, x-1) = "<" then start_line = line (segx); else do; /* ">,N" not accepted */ start_line = cv_dec_check_ (substr (buff, 2, x-1), code); if code ^= 0 then do; call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2, x-1)); go to RESET; end; end; if substr (buff, 2+x, LC-x) = ">" then end_line = line (segx) + difflines (segx) - 1; else do; /* "N,<" not accepted */ end_line = cv_dec_check_ (substr (buff, 2+x, LC - x), code); if code ^= 0 then do; call ioa_ ("cannot ""^a"": bad line number ^a", req, substr (buff, 2+x, LC-x)); go to RESET; end; end; end; if start_line <= 0 then do; call ioa_ ("cannot ""^a"": neg line number ^d", req, start_line); go to RESET; end; if end_line - start_line < 0 then do; call ioa_ ("cannot ""^a"": start ^d > end ^d", req, start_line, end_line); go to RESET; end; end READ_LINNOS; /* */ SET_TEMPS: proc (x); /* IP to set (global) tp, tc, temp_lines */ dcl x fixed bin; dcl xptr ptr; dcl xchars fixed bin; /* total chars */ /* */ dcl tsc fixed bin; dcl N fixed bin; dcl (i, j, k) fixed bin; xptr = tptr (x); xchars = tchars (x); k = 0; do i = 1 to end_line; if k >= xchars then do; call ioa_ ("cannot ""^a"": seg ^a has ^d lines", req, textid (x), i - 1); go to RESET; end; if i = start_line then do; /* make temp_ptr point at start of this line */ temp_ptr = addr (xptr -> skipchars (k)); tsc = k; end; j = index (substr (xptr -> ch, k + 1, xchars - k), nl); if j = 0 then j = xchars - k; /* take all if no newline */ k = k + j; end; temp_chars = k - tsc; temp_lines = end_line - start_line + 1; end SET_TEMPS; /* */ PRINTEMPS: proc (x); /* IP to print (temp_ptr , temp_chars) */ dcl (i, j, k) fixed bin; dcl x fixed bin; k = 0; do i = 1 to temp_lines; j = index (substr (temp_ptr -> ch, k+1, temp_chars - k), nl); if j = 0 then j = temp_chars - k; call ioa_$nnl ("^a^d^-^a", textid (x), start_line + i - 1, substr (temp_ptr -> ch, k+1, j)); k = k + j; end; if k ^= temp_chars then call ioa_ ("PRINTEMPS: k ^= temp_chars"); /* DEBUG */ end PRINTEMPS; end ma_edit_;  ma_resynch_.pl1 11/04/82 1951.6rew 11/04/82 1627.6 100089 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ ma_resynch_: proc (a_info_ptr); default (fixed&^precision&^constant) precision (21); /* DEFAULT */ default (constant&real&^decimal) binary; /* This program is part of the merge_ascii/compare_ascii subsystem. */ /* It is called with a pointer to a control structure which */ /* describes a number of texts, and the place in each */ /* at which synchronization was lost. RESYNCH_ fills in information */ /* indicating where it found it possible to get back in synch. */ /* Coded by RE Mullen */ dcl a_info_ptr ptr; dcl i fixed bin; dcl EOF bit (1) aligned init (""b); dcl blocklen (8) fixed bin; dcl blocklines (8) fixed bin; dcl depth (8) fixed bin; /* chars past cp(i) where block(i) created */ dcl xiny (8, 8) fixed bin; /* xiny(i,j) is chars past cp(j) where block(i) found */ dcl votes (8) fixed bin; /* est value of synch on block (i) */ dcl cp_i ptr; /* for loops */ dcl len_i fixed bin; dcl depth_i fixed bin; dcl blocklen_i fixed bin; dcl blocklines_i fixed bin; dcl votes_i fixed bin; dcl i_in (8) fixed bin; dcl (best, best_votes) fixed bin; dcl n_blocks fixed bin; dcl NL char (1) aligned int static options (constant) init (" "); dcl ch char (999) based; dcl skipchars (0:1) char (1) unal based; dcl ioa_ entry options (variable); dcl synch bit (1) aligned; /* */ %include merge_ascii_info; /* */ /* this program finds the next point at which the text are back in synch. If no resynch point is found, we say that we are "in synch at the ends", and set the global switch ma_info.eof. It is the contract of this program to also set the following global variables: ma_info.difflen(i) is set to the number of chars which differ in each text. ma_info.difflines(i) is set to the number of lines which differ in each text. ma_info.synchlen is set to the number of characters which are in the resynched block. ma_info.synchlines is set to the number of lines which are in the resynched block. ma_info.same_as(i) is set to the seg_index of the lowest numbered segment with a difference matching that present in text(i). If no lower numbered text has a matching difference then same_as(i) is set to zero. Note that no variables in ma_info are set by any internal procedures. Note that this program does not modify any variables it uses to regain synch, it advances no pointers, it does not reduce the remaining lengths. */ ma_info_ptr = a_info_ptr; /* copy pointer at least, to automatic */ do i = lo to hi; depth (i) = 0; end; /* We start out not in synch. Each call to try_deeper_resynch defines a block of lines in each segment which begins one line deeper in the remaining text. The variable depth(i) is the number of characters between where synch was lost and the first character of the line starting the defined block. */ synch = ""b; do while (^synch); call try_deeper_resynch; end; /* Finally in SYNCH again. Got in synch at blocks: substr(cp(*)->ch, xiny(best,*)+1, synchlen) If EOF then we must setup a zero_length resynched block at the end of each text. We then strip matching lines off the tail of the alleged differences. Finally we determine difflines(*) and which differences match. */ ma_info.eof = EOF; /* Set synchlen, synchlines, difflen (*) */ do i = lo to hi; if EOF then do; /* at synch at ends */ difflen (i) = len (i); /* difference is entire rest */ synchlen, synchlines = 0; /* resynch block is empty */ end; else do; /* set lenght of differences */ /* synchlen, synchlines already set correctly by check_synch */ difflen (i) = xiny (best, i); end; end; call shrink_diff; /* strip matching chars */ do i = lo to hi; difflines (i) = DIFFLINES (i); same_as (i) = SAME_AS (i); /* seg index of lowest matching text, or zero */ end; /* */ try_deeper_resynch: proc; dcl (i, j, k) fixed bin; n_blocks = 0; do i = lo to hi; /* setup blocks in each text, scan others */ /* init useful vars */ cp_i = cp (i); depth_i = depth (i); len_i = len (i); votes_i = 1; /* go deeper */ k = index (substr (cp_i -> ch, depth_i+1, len_i-depth_i), NL); if k = 0 then depth_i = len_i; else depth_i = depth_i + k; /* setup block */ blocklen_i, blocklines_i = 0; /* block is null so far */ gb_small: k = index (substr (cp_i -> ch, (depth_i+blocklen_i)+1, len_i- (depth_i+blocklen_i)), NL); if k > 0 then do; /* was able to grow by another line */ blocklen_i = blocklen_i + k; blocklines_i = blocklines_i + 1; if blocklen_i < minchars | blocklines_i < minlines then go to gb_small; n_blocks = n_blocks + 1; /* one more defined */ end; else do; /* not able to define block */ blocklen_i, blocklines_i = 0; votes_i = 0; end; /* scan other texts for block(i) */ do j = lo to hi while (votes_i ^= 0); if i = j then i_in (j) = depth_i; else do; /* scan one */ if substr (cp (j) -> ch, 1, blocklen_i) = substr (cp_i -> ch, depth_i+1, blocklen_i) then do; i_in (j) = 0; /* found at top */ votes_i = votes_i + 1; /* favor inserts/deletes if tie */ end; else do; i_in (j) = index (substr (cp (j) -> ch, 1, depth (j)+blocklen_i), substr (cp_i -> ch, depth_i, blocklen_i+1)); if i_in (j) = 0 then votes_i = 0; /* not present */ end; end; end; /* scan for block (i) is done, nb. */ depth (i) = depth_i; votes (i) = votes_i; if votes (i) > 0 then do; /* worth remembering? */ blocklen (i) = blocklen_i; blocklines (i) = blocklines_i; do j = lo to hi; xiny (i, j) = i_in (j); end; end; end; if n_blocks = 0 then do; /* at EOF in all texts */ synch = "1"b; EOF = "1"b; return; end; synch = ""b; /* VALIDATE SYNCH */ do while (^synch); call get_best; if best = 0 then return; call check_synch; /* sets synch, synchlen, synchlines */ if ^synch then votes (best) = 0; end; end try_deeper_resynch; /* */ check_synch: proc; /* IP to see if block (best) is unique in each text */ dcl (i, j, k) fixed bin; dcl lo_ptr ptr; dcl restlen_all_same bit (1); dcl restlen fixed bin; lo_ptr = addr (cp (lo) -> skipchars (xiny (best, lo))); synchlen = blocklen (best); /* this many chars in synch block so far */ synchlines = blocklines (best); restlen_all_same = "1"b; i_in (lo) = xiny (best, lo); restlen = -i_in (lo) - synchlen + len (lo); do i = lo + 1 to hi; i_in (i) = xiny (best, i); if restlen > len (i) - i_in (i) - synchlen then do; restlen = len (i) - i_in (i) - synchlen; restlen_all_same = ""b; end; end; grow_loop: /* first make block as big as possible */ j = index (substr (lo_ptr -> ch, synchlen+1, restlen), NL); if j = 0 then do; if restlen_all_same then j = restlen; if j = 0 then go to grow_done; /* was not another NL in range */ end; do i = lo + 1 to hi; if substr (lo_ptr -> ch, synchlen+1, j) ^= substr (cp (i) -> ch, i_in (i)+synchlen+1, j) then go to grow_done; end; synchlen = synchlen + j; /* grow synched chars */ synchlines = synchlines + 1; /* grow synched lines */ restlen = restlen - j; if restlen > 0 then go to grow_loop; grow_done: /* here when can't grow synched block further */ if synchlen = 0 then go to real_synch; /* in "synch" at EOF (*) */ /* now see if stuff is unique */ do i = lo to hi; if index (substr (cp (i) -> ch, i_in (i)+synchlen, len (i)-i_in (i)-synchlen), substr (lo_ptr -> ch, 1, synchlen)) ^= 0 then go to pseudo_synch; end; real_synch: synch = "1"b; return; pseudo_synch: synch = ""b; return; end check_synch; /* */ DIFFLINES: proc (di) returns (fixed bin); /* IP to count lines in difflen(*) */ dcl dc fixed bin; /* chars left in diff */ dcl dl fixed bin; /* lines in diff counted */ dcl dj fixed bin; /* length of one line */ dcl di fixed bin; /* text seg in question */ dcl dp ptr; /* ptr to rest of diff */ dcl dch char (dc) based (dp); dc = difflen (di); dp = cp (di); dl = 0; do while (dc > 0); dj = index (dch, NL); if dj = 0 then dj = dc; dc = dc - dj; dp = addr (dp -> skipchars (dj)); dl = dl + 1; end; return (dl); end DIFFLINES; SAME_AS: proc (si) returns (fixed bin); /* IP to det if diff matches other diff */ dcl si fixed bin; /* text seg in question */ dcl sas fixed bin; /* one other diff, being compared */ dcl sap ptr; /* ptr to diff */ dcl sac fixed bin; /* chars in diff */ dcl sa_ch char (sac) based; /* handy template */ sap = cp (si); sac = difflen (si); do sas = lo to si - 1; /* loop over segs with lower indices */ if sac = difflen (sas) then if sap -> sa_ch = cp (sas) -> sa_ch then return (sas); end; return (0); /* evid not same as any other */ end SAME_AS; /* */ get_best: proc; /* IP to choose among synchs */ dcl gbi fixed bin; best, best_votes = 0; do gbi = lo to hi; if votes (gbi) > best_votes then do; best = gbi; best_votes = votes (best); end; end; end get_best; /* */ shrink_diff: proc; /* IP to avoid "abcdef" changed to "xyzef" foolishness */ dcl (shi, shj, shk) fixed bin; dcl max_same fixed bin; dcl chars_same fixed bin; dcl lines_same fixed bin; chars_same = 0; lines_same = 0; max_same = difflen (lo); do shi = lo + 1 to hi; if difflen (shi) < max_same then max_same = difflen (shi); end; if max_same = 0 then return; /* nothing to compress */ do while (chars_same < max_same); shj = index (reverse (substr (cp (lo) -> ch, difflen (lo)-max_same+1, max_same-chars_same-1)), NL); if shj = 0 then go to sh_done; do shi = lo + 1 to hi; /* compare complete lines bracketed by NL */ if substr (cp (lo) -> ch, difflen (lo)-chars_same-shj, shj+1) ^= substr (cp (shi) -> ch, difflen (shi)-chars_same-shj, shj+1) then go to sh_done; /* not the same */ end; chars_same = chars_same + shj; /* discovered more the same */ lines_same = lines_same + 1; end; sh_done: if chars_same ^= 0 then do; do shi = lo to hi; difflen (shi) = difflen (shi) - chars_same; end; synchlen = synchlen + chars_same; synchlines = synchlines + lines_same; end; end shrink_diff; end ma_resynch_;  manage_volume_pool.pl1 10/19/92 1601.6r w 10/19/92 1555.9 1479852 /****^ ********************************************************* * * * Copyright, (C) BULL HN Information Systems Inc., 1991 * * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * ********************************************************* */ manage_volume_pool: mvp: mvp_: manage_volume_pool_: proc; /* Written 02/18/76 by Richard Bratt Last Modified: 09/10/76 by R. Bratt to add use and print requests. 2/1/77 by D. Vinograd to lock data base, interface to volume dumper, and to be a bit more 9/79 by D. Vinograd to add entries list and check for consistences uses by volume dumper and to reformat volume pool. 11/81 by B. Braun to add subroutine move_to_head so volumes are kept in descending order. 08/03/82 by B. Braun to correct fatal error (phx13239 phx13215), to correct $set_pool_path entry (phx11528), correct $check_reserved (phx11548). 12/01/82 by B. Braun to extensively change the command interface as defined by MCRs 5898 and 6056. This includes new keys, new control arguments and support of volume sets. 10/31/83 by B. Braun to fix error in convert routine resulting in trashed volume pools. 11/22/83 by B. Braun to fix another error in convert routine resulting in the list key printing a garbage line (phx16394). 12/02/83 by B. Braun to fix the bit_count calculation and truncate the pool int finish procedure. 12/05/83 by B. Braun to change volume_pool structure to take up less room (version 3). Fix a SERIOUS bug in add_key where set secondary_idx and primary_idx to no_link. 12/21/83 by B. Braun to set variable retl to chars not words. 04/16/84 by B. Braun to improve list performance by not buffering to a temp seg first (phx17312). This also fixes a possible size condition bug as the temp seg is not used (mcr6783). 04/18/84 by B. Braun to add control args -allocate and -reserve to the list key. To complain about incompatable args with the "list -total". Fix bug so "[mvp ls -com -edt]" works. */ /****^ HISTORY COMMENTS: 1) change(88-07-02,GDixon), approve(88-07-25,MCR7937), audit(88-07-28,Lippard), install(88-08-01,MR12.2-1072): Change the set key to add -state_date, allowing the user to set the state_date field to an explicit value. This can be important to the reuse operation. 2) change(91-10-25,Schroth), approve(91-11-28,MECR0015), audit(91-11-25,WAAnderson), install(91-11-28,MR12.5-1001): Correct MR12.4 source code corruption. 3) change(92-05-14,Schroth), approve(91-11-25,MCR8251), audit(92-09-22,WAAnderson), install(92-09-24,MR12.5-1016): Replace MECR0015: Correct MR12.4 source code corruption. 4) change(92-09-16,WAAnderson), approve(92-09-16,MCR8262), audit(92-10-06,Vu), install(92-10-19,MR12.5-1028): The active function call [mvp l -tt] on very large volume pools failed due to insufficient stack space. This occurred due to a misplaced call to shorten_stack. Also checked to make sure request was made as an active function and the totals were not wanted before adding volume names into the return string. END HISTORY COMMENTS */ /* manage_volume_pool provides a simple librarian to keep track of a user's volumes. It uses a segment named .volumes in the user's home directory. as its data base. USAGE: manage_volume_pool {key} {-control_args} where key may be: "add" or "a" to add volumes to the library. "allocate" or "alloc" marks volumes as in use. "append_volume_set" or "appvs" to increase the size of a volume set. "delete" or "dl" to delete volumes from the library. "free" returns volumes to the free pool. "list" or "l" to list specific volumes in the library. If no arguments are given then all volumes owned by the user are listed. "print" or "pr" or "p" prints the pathname of the volume pool currently in use. "pv_expire" or "pvexp" marks volumes as physically expired in the pool. "remove_volume_set" or "rmvs" removes volumes from a volume set thereby shrinking the volume set. "reserve" or "rsv" marks a volume as reserved. A reserved volume is not free and can be allocated in the normal manner. "reuse" frees and re-allocates an allocated volume set. "set" is the means to set the expiration dates and comment fields of a volume set. "test" tests whether a volume is in a given state. "use" or "u" specifies that a different volume pool is to be used. The state of a volume is validated to be consistent with a request before the request is honored. To facilitate use of this proc, all the entries may be invoked as an active functions. USAGE: [manage_volume_pool alloc volume_requested] returns the volume assigned A volume may also be tested to see if it is free by using the test entry which returns "true" or "false". USAGE: [manage_volume_pool test volume_requested] returns "true" or "false" */ dcl Plisted ptr; dcl Pvolume ptr; dcl Ptvol ptr; dcl a_code fixed bin (35); dcl a_comment char (*); dcl a_match_str char (*) varying; dcl a_most_recent bit(1); dcl a_number fixed bin; dcl a_path char (*); dcl a_requested char (*); dcl a_state fixed bin; dcl a_time fixed bin (71); dcl a_volid bit (36); dcl a_volname char (*); dcl a_volumes char (*) var; dcl a_vpp ptr; dcl abort_sw bit(1); dcl ac fixed bin; dcl active_fnc bit (1); dcl al fixed bin(21); dcl ala fixed bin(21); dcl all_states bit (1); dcl all_sw bit(1); dcl alloc_sw bit (1); dcl alp ptr; dcl ap ptr; dcl apa ptr; dcl areap ptr; dcl arg char (al) based (ap); dcl arg2 char (ala) based (apa); dcl asterisk_cnt fixed bin; dcl asterisk_sw bit(1); dcl based_area area based (areap); dcl bit_count fixed bin(24); dcl brief_sw bit(1); dcl code fixed bin (35); dcl com_len fixed bin(21); dcl com_ptr ptr; dcl comment_str char(com_len) based (com_ptr); dcl comment_sw bit(1); dcl compare char (64); dcl dfmt_sw bit(1); dcl ecode fixed bin (35); dcl edt_sw bit(1); dcl expire_len fixed bin(21); dcl expire_ptr ptr; dcl expire_str char(expire_len) based (expire_ptr); dcl expire_sw bit(1); dcl first_sw bit(1); dcl first_last_sw bit(1); dcl fexp_sw bit(1); dcl force_sw bit(1); dcl free_sw bit (1); dcl header_output char (256) var; dcl header_len fixed bin; dcl header_to_be_printed bit(1); dcl header_sw bit (1); dcl ignore fixed bin (35); dcl last_sw bit(1); dcl listed_flag (1:volume_pool.n_vol) bit(1) based (Plisted); dcl lock bit (1); dcl match_string char (64) var; dcl match_sw bit (1); dcl most_recent bit(1); dcl myname char (32); dcl name_sw bit (1); dcl narg fixed bin init(-1); dcl new_vpp ptr; dcl noaction_msg char(256) var; dcl noaction_cnt fixed bin; dcl noaction_str bit(volume_cnt) based (addr(volume.noaction)); dcl none_sw bit(1); dcl output char (256) var; dcl output_len fixed bin; dcl pvedt_sw bit(1); dcl pvexp_str char(pvexp_len) based (pvexp_ptr); dcl pvexp_len fixed bin(21); dcl pvexp_ptr ptr; dcl pvexp_sw bit(1); dcl requoted_output char (512) var; dcl reserve_sw bit(1); dcl ret char (retl) var based (retp); dcl retl fixed bin(21); dcl retp ptr; dcl sdt_sw bit (1); dcl state_dt_clock fixed bin(71); dcl state_dt_str char(state_dt_len) based (state_dt_ptr); dcl state_dt_len fixed bin(21); dcl state_dt_ptr ptr; dcl state_dt_sw bit (1); dcl state_sw bit (1); dcl tcnt fixed bin; dcl total_cnt fixed bin; dcl totals_wanted bit(1); dcl vol_msg_list char(256) var; dcl vol_msg_cnt fixed bin; dcl volume_cnt fixed bin; dcl vs_sw bit(1); dcl vs_size fixed bin; dcl specified_states(4) bit(1) unal; dcl state_string bit(4) unal based (addr(specified_states)); dcl svol_sw bit(1); dcl subroutine bit (1); dcl tdir char (168); dcl tname char (32); dcl tvlx fixed bin; dcl vlx fixed bin (17); dcl vol_cnt fixed bin; dcl volume_sw bit(1); dcl volume_state fixed bin; dcl vp_bc fixed bin(24); dcl vpp ptr; dcl want_str bit(volume_cnt) based (addr(volume.want_it)); dcl word_count fixed bin(19); dcl yes_sw bit(1); dcl 1 vol_list(1:17) aligned, 2 name char(256) var, 2 cnt fixed bin; dcl 1 tvol aligned based (Ptvol), 2 name(tcnt) char(32), 2 indx(tcnt) fixed bin, 2 switches, 3 noaction(tcnt) bit(1) unal, 3 want_it(tcnt) bit(1)unal; dcl 1 volume aligned based (Pvolume), 2 name(volume_cnt) char(32), 2 indx(volume_cnt) fixed bin, 2 switches, 3 noaction(volume_cnt) bit(1) unal, 3 want_it(volume_cnt) bit(1)unal; dcl 1 volume_pool_header aligned, 2 version fixed bin, /* version 3 structure */ 2 lock bit (36), 2 n_vol fixed bin (17), /* number of volume slots in the pool, free and occupied */ 2 volume_count fixed bin(17), /* number of volumes in the pool */ 2 head fixed bin (17), /* index into first volume in pool */ 2 tail fixed bin (17), /* index to last volume in pool */ 2 free_head fixed bin (17), /* index to first empty slot in array */ 2 pad bit (36); dcl 1 volume_pool_entry aligned, /* volume pool entry. each volume has one assoc. with it */ 2 name char (32), /* name of volume set */ 2 id bit (36), /* used by volume dumper only */ 2 state fixed bin, /* state of the volume */ 2 state_date fixed bin (71), /* date the volume was last acted upon */ 2 pv_expire_date fixed bin(71), /* physical volume expiration date */ 2 expire_date fixed bin(71), /* allocated volume expiration date */ 2 processid bit (36), /* used when reserving volume */ 2 comment char (64), 2 switches unaligned, 3 secondary_vol bit(1), /* true if volume is a part of a multiple volume set */ 3 pv_expire bit(1), /* true if a physical volume expiration date is assoc. with the volume */ 3 expire bit(1), /* true if an expire date is associated with the volume */ 3 already_printed bit(1), /* used in listing purposes */ 3 pad1 bit(32), 2 vs_count fixed bin, /* volume set count, includes primary and secondary volumes */ 2 next fixed bin(17), /* index to next node or volume in the pool */ 2 previous fixed bin(17), /* index to previous volume in pool */ 2 primary_idx fixed bin(17), /* index of primary volume in a set */ 2 secondary_idx fixed bin(17), /* index to next secondary volume in a set */ 2 pad2 bit (36); dcl 1 volume_pool aligned based (vpp), /* This is the CURRENT volume pool structure */ 2 header like volume_pool_header, 2 vpe (divide(sys_info$max_seg_size - size(volume_pool_header), size(volume_pool_entry), 17) refer (volume_pool.header.n_vol)) like volume_pool_entry; /* internal static variables */ dcl vol_ename char (32) int static init (""); dcl vol_dir char (168) int static init (""); dcl (ascii_state (4) char (5) int init ("FREE", "ALOC", "RESV", "PVEXP"), blank_NL char (2) int init(" "), allocated_state fixed bin int init (2), free_state fixed bin int init (1), reserved_state fixed bin int init (3), pvexp_state fixed bin int init (4), no_link fixed bin int init (-1), paired_args bit (1) int init ("1"b), single_arg bit (1) int init ("0"b), volume_pool_version_3 fixed bin init (3), volume_pool_version_2 fixed bin init (2), volume_pool_version_1 fixed bin init (1), use char (3) init ("use"), truebits bit(4) int init ("1111"b) unal, True bit(1) int init ("1"b), False bit(1) int init ("0"b), lock_interval fixed bin int init (60)) static options (constant); dcl (already_alloc init("1000000000000000"b), already_free init("0100000000000000"b), already_reg init("0010000000000000"b), already_sec_vol init("0001000000000000"b), cant_delete init("0000100000000000"b), cant_pvexp init("0000010000000000"b), not_alloc init("0000001000000000"b), not_free init("0000000100000000"b), not_exp init("0000000010000000"b), not_reg init("0000000001000000"b), not_updated init("0000000000100000"b), rsv_by_another init("0000000000010000"b), sec_not_found init("0000000000001000"b), check_pvexp init("0000000000000100"b), vol_pvexp init("0000000000000010"b), sec_vol init("0000000000000001"b)) bit(16) unal int static options(constant); dcl (fb_already_alloc init(1), fb_already_free init(2), fb_already_reg init(3), fb_already_sec_vol init(4), fb_cant_delete init(5), fb_cant_pvexp init(6), fb_not_alloc init(7), fb_not_free init(8), fb_not_exp init(9), fb_not_reg init(10), fb_not_updated init(11), fb_rsv_by_another init(12), fb_sec_not_found init(13), fb_check_pvexp init(14), fb_vol_pvexp init(15), fb_prim_name init(17)) fixed bin unal int static options(constant); dcl err_msg(1:15) char(100)var int static options(constant) init( " Volume set^[s^] ^a ^[are^;is^] already allocated.", " Volume set^[s^] ^a ^[are^;is^] already free.", " Volume set^[s^] ^a ^[are^;is^] already registered in the pool.", " Volume^[s^] ^a ^[are^;is a^] secondary volume^[s^] of volume set ^a.", " Volume set^[s^] ^a ^[are^;is^] allocated and can not be deleted.", " Volume set^[s^] ^a ^[are^;is^] allocated and can not be physically expired.", " Volume set^[s^] ^a ^[are^;is^] not allocated.", " Volume set^[s^] ^a ^[are^;is^] not free.", " Allocated volume set^[s^] ^a ^[are^;is^] not expired.", " Volume^[s^] ^a ^[are^;is^] not registered.", " Volume set^[s^] ^a ^[are^;is^] not allocated. It has not been updated.", " Volume set^[s^] ^a ^[are^;is^] not reserved by your process.", " Secondary volume^[s^] ^a not found in set ^a.", " Physical volume^[s^] ^a ^[have^;has^] expired.", " Volume set^[s^] ^a ^[are^;is^] physically expired."); dcl cleanup condition; /* Entries */ dcl clock_ entry() returns(fixed bin(71)), command_query_$yes_no entry() options(variable), convert_date_to_binary_ entry (char(*), fixed bin(71), fixed bin(35)), cu_$af_arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr), cu_$af_return_arg entry (fixed bin, ptr, fixed bin(21), fixed bin(35)), cu_$arg_list_ptr entry (ptr), cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin(21), fixed bin (35), ptr), date_time_ entry (fixed bin (71), char (*) aligned), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), get_arg variable entry (fixed bin, ptr, fixed bin(21), fixed bin (35), ptr), get_process_id_ entry returns (bit (36) aligned), get_ring_ entry() returns(fixed bin(3)), get_system_free_area_ entry returns (ptr), get_temp_segment_ entry (char (*), ptr, fixed bin (35)), hcs_$fs_move_seg entry (ptr, ptr, fixed bin, fixed bin (35)), hcs_$fs_get_path_name entry (ptr, char (*), fixed bin, char (*), fixed bin (35)), hcs_$get_user_effmode entry (char(*), char(*), char(*), fixed bin, fixed bin(5), fixed bin(35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_file entry (char(*), char(*), fixed bin(19), fixed bin(35)), hcs_$validate_processid entry (bit (36) aligned, fixed bin (35)), initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)), ioa_$general_rs entry (ptr, fixed bin, fixed bin, char (*), fixed bin, bit (1), bit (1)), release_temp_segment_ entry (char (*), ptr, fixed bin (35)), requote_string_ entry (char (*)) returns (char (*)), set_lock_$lock entry (bit (36) aligned, fixed bin, fixed bin (35)), set_lock_$unlock entry (bit (36) aligned, fixed bin (35)), suffixed_name_$make entry (char (*), char (*), char (*), fixed bin (35)), user_info_$homedir entry (char (*)); dcl (active_fnc_err_, com_err_, ioa_, ioa_$nnl, ioa_$rsnnl, user_info_) entry options (variable); dcl (a_error_rnt, abort_proc, error_rnt, msg_proc) entry variable options (variable); dcl (error_table_$action_not_performed, error_table_$badopt, error_table_$boundviol, error_table_$inconsistent, error_table_$invalid_lock_reset, error_table_$locked_by_this_process, error_table_$lock_not_locked, error_table_$noarg, error_table_$process_unknown, error_table_$unimplemented_version) ext fixed bin (35); /* builtins */ dcl (addr, clock, convert, currentsize, hbound, index, length, max, mod, null, rtrim, substr, verify) builtin; subroutine = False; call setup; on cleanup call finish; call get_arg (1, ap, al, (0), alp); if arg = "l" | arg = "ls" | arg = "list" then call list_key(); else if arg = "al" | arg = "alloc" | arg = "allocate" then call determine_alloc_version(); else if arg = "f" | arg = "free" then call free_key(); else if arg = "a" | arg = "add" then call add_key(); else if arg = "d" | arg = "dl" | arg = "delete" then call delete_key(); else if arg = "r" | arg = "rsv" | arg = "reserve" then call reserve_key(); else if arg = "t" | arg = "test" then call test_key(); else if arg = "appvs" | arg = "append_volume_set" then call append_volume_set(); else if arg = "rmvs" | arg = "remove_volume_set" then call remove_volume_set(); else if arg = "reuse" then call reuse(); else if arg = "set" then call set_key(); else if arg = "pvexp" | arg = "pv_expire" then call pv_expire_key(); else if arg = "u" | arg = "use" then call use_key(); else if arg = "c" | arg = "change" /* obsolete key */ then call process (paired_args, change); else if arg = "cm" | arg = "comment" /* obsolete key */ then call process (single_arg, comment); else if arg = "p" | arg = "pr" | arg = "print" then do; if active_fnc then ret = path(vol_dir,vol_ename); else call msg_proc (-1, "^a", path (vol_dir, vol_ename)); end; else call abort_proc (error_table_$badopt, arg); return_to_caller: call finish; return; reserve: entry (a_vpp, a_error_rnt, a_requested, a_comment, a_volname, a_code); volume_state = reserved_state; goto alloc_common; allocate: entry (a_vpp, a_error_rnt, a_requested, a_comment, a_volname, a_code); volume_state = allocated_state; alloc_common: subroutine = True; call setup; on cleanup call finish; ap = addr (a_requested); al = length (rtrim (a_requested)); apa = addr (a_comment); ala = length (rtrim (a_comment)); call search (arg); if vlx = 0 then if arg ^= "*" then call add; else call abort_proc (0, "No free volumes."); call allocate; a_volname = vpe (vlx).name; goto return_to_caller; force_allocate: entry (a_vpp, a_error_rnt, a_number, a_most_recent, a_match_str, a_volumes, a_code); /* This entry point is to facilitate TR backup and retrievals of the Trouble Report system */ dcl volx fixed bin; subroutine = True; call setup; on cleanup call finish; if volume_pool.volume_count < a_number then do; /* asking for too many? */ a_code = error_table_$boundviol; goto return_to_caller; end; vol_cnt = 0; volume_cnt = a_number; if a_match_str = "" then match_sw = False; else match_sw = True; areap = get_system_free_area_(); allocate volume in (based_area) set (Pvolume); if a_most_recent then do; volx = volume_pool.head; do while ((volx ^= no_link) & (vol_cnt < volume_cnt)); /* like -first N means return the "latest" N */ if vpe(volx).state = allocated_state & vpe(volx).vs_count = 1 then do; if match_sw then do; if (index (vpe(volx).comment, a_match_str) > 0) then do; vol_cnt = vol_cnt + 1; volume(vol_cnt).indx = volx; volume(vol_cnt).name = vpe(volx).name; end; end; else do; /* no match str specified */ vol_cnt = vol_cnt + 1; volume(vol_cnt).indx = volx; volume(vol_cnt).name = vpe(volx).name; end; end; volx = vpe(volx).next; end; end; else do; volx = volume_pool.tail; do while ((volx ^= no_link) & (vol_cnt < volume_cnt)); /* got to be like -last reuse oldest N */ if vpe(volx).state = allocated_state & vpe(volx).vs_count = 1 then do; if match_sw then do; if (index (vpe(volx).comment, a_match_str) > 0) then do; vol_cnt = vol_cnt + 1; volume(vol_cnt).indx = volx; volume(vol_cnt).name = vpe(volx).name; end; end; else do; /* no match str specified */ vol_cnt = vol_cnt + 1; volume(vol_cnt).indx = volx; volume(vol_cnt).name = vpe(volx).name; end; end; volx = vpe(volx).previous; end; end; if (vol_cnt = 0) | (vol_cnt < volume_cnt) then do; a_code = error_table_$action_not_performed; goto return_to_caller; end; a_volumes = ""; do volx = 1 to vol_cnt; a_volumes = a_volumes || rtrim(volume(volx).name) || " "; call move_to_head(volume(volx).indx); end; goto return_to_caller; free: entry (a_vpp, a_error_rnt, a_requested, a_code); subroutine = True; call setup; on cleanup call finish; ap = addr (a_requested); al = length (rtrim (a_requested)); call search (arg); call free; goto return_to_caller; delete: entry (a_vpp, a_error_rnt, a_requested, a_code); subroutine = True; call setup; on cleanup call finish; ap = addr (a_requested); al = length (rtrim (a_requested)); call search (arg); call delete; goto return_to_caller; set_volid: entry (a_vpp, a_error_rnt, a_volname, a_volid, a_code); /* This entry point is used by Volume Dumper */ subroutine = True; call setup; on cleanup call finish; ap = addr (a_volname); al = length (rtrim (a_volname)); call search (arg); if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg); vpe (vlx).id = a_volid; goto return_to_caller; check_reserved: entry (a_vpp, a_error_rnt, a_code); subroutine = True; call setup; on cleanup call finish; vlx = volume_pool.head; do while (vlx ^= no_link); if vpe (vlx).state = reserved_state then do; if reserved_by_another_process(vlx) then; /* skip it */ else do; vpe (vlx).state = free_state; vpe (vlx).processid = "0"b; call move_to_head(vlx); end; end; vlx = vpe(vlx).next; end; goto return_to_caller; status: entry (a_vpp, a_error_rnt, a_requested, a_comment, a_time, a_state, a_code); subroutine = True; call setup; on cleanup call finish; ap = addr (a_requested); al = length (rtrim (a_requested)); call search (arg); if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg); a_comment = vpe (vlx).comment; a_time = vpe (vlx).state_date; a_state = vpe (vlx).state; goto return_to_caller; set_pool_path: entry (a_error_rnt, a_path, a_vpp, a_code); /* Returns a pointer to the volume pool specified by pathname. */ subroutine = True; a_vpp = null; ap = addr (use); al = length (use); call setup; on cleanup call finish; ap = addr (a_path); al = length (rtrim (a_path)); call setup_pool_path("1"b); goto return_to_caller; get_pool_path: entry (a_vpp, a_error_rnt, a_path, a_code); /* Returns the pathname of volume pool given a pointer */ subroutine = True; call setup; on cleanup call finish; call hcs_$fs_get_path_name (vpp, tdir, (0), tname, code); if code ^= 0 then call abort_proc (code, "Unable to deterime pool pathname."); else call ioa_$rsnnl ("^a", a_path, (0), path (tdir, tname)); goto return_to_caller; %page; abort: proc (err) ; dcl argp ptr; dcl err fixed bin (35); dcl str char (256); dcl str_len fixed bin; if subroutine then do; if err = 0 then a_code = error_table_$action_not_performed; else a_code = err; end; call cu_$arg_list_ptr (argp); /* convert args to message */ call ioa_$general_rs (argp, 2, 3, str, str_len, "0"b, "0"b); if lock then call set_lock_$unlock (volume_pool.lock, ignore); call error_rnt (err, myname, substr (str, 1, str_len)); goto return_to_caller; end abort; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ add: proc(); /* old add used for subroutines only */ if vlx ^= 0 then call abort_proc(0, "Volume ^a is already registered.", arg); vlx = get_node(); vpe (vlx).name = arg; vpe (vlx).state = free_state; vpe (vlx).comment = ""; vpe (vlx).switches = False; vpe (vlx).expire_date = 0; vpe (vlx).pv_expire_date = 0; vpe (vlx).secondary_idx, vpe (vlx).primary_idx = no_link; vpe (vlx).vs_count = 1; call insert_node(vlx); return; end add; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ add_key: proc(); /* Used by the command, add_key adds volumes to the pool */ dcl pv_clock fixed bin(71), (volx, vol_cnt, i) fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("1"b), 2 vs init ("0"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("1"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("1"b), /* requires a date after -pvexp */ 2 state_dt init ("0"b)) bit(1); if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: add volume_names {-control_arg}"); pv_clock = 0; call process_ctl_args(addr(args_allowed), 2, vol_cnt); if vol_cnt = 0 then call abort_proc(0, "No volume names specified."); if pvexp_sw then do; call convert_date_to_binary_(pvexp_str, pv_clock, code); if code ^= 0 then call abort_proc(code, pvexp_str); end; call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, already_reg); call evaluate_volumes_wanted("added", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw | abort_sw then do; if active_fnc then do; ret = "false"; return; end; if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); end; /* add volumes specified */ do i = 1 to vol_cnt; if volume(i).want_it then do; if volume(i).noaction then; /* skip */ else do; volx = get_node(); vpe (volx).name = volume(i).name; vpe (volx).state = free_state; vpe (volx).comment = ""; vpe (volx).switches = False; vpe (volx).pv_expire = pvexp_sw; vpe (volx).pv_expire_date = pv_clock; vpe (volx).expire_date = 0; vpe (volx).secondary_idx, vpe (volx).primary_idx = no_link; vpe (volx).vs_count = 1; call insert_node(volx); end; end; end; if active_fnc then ret = "true"; else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); return; end add_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ allocate: proc; /* old allocate used by subroutine allocate and "mvp al vol_name1 comment_1 vol_name2 comment_2 ... vol_nameN comment_N" command line */ if vlx = 0 then if arg = "*" then call abort_proc (0, "No free volumes."); else call abort_proc (0, "Volume ^a is not registered.", arg); if vpe (vlx).state = allocated_state then call abort_proc (0, "Volume ^a is already allocated.", arg); vpe (vlx).comment = arg2; if subroutine then do; vpe (vlx).state = volume_state; if volume_state = reserved_state then vpe (vlx).processid = get_process_id_ (); else vpe (vlx).processid = "0"b; end; else do; vpe (vlx).state = allocated_state; vpe (vlx).processid = "0"b; end; if active_fnc then ret = vpe (vlx).name; else if arg = "*" & ^subroutine then call msg_proc (0, "Volume ^a allocated", vpe (vlx).name); call move_to_head(vlx); return; end allocate; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ allocate_key: proc(); /* Used by the mvp command to allocate volume sets in the pool. */ dcl exp_clock fixed bin (71); dcl (i, vol_cnt, volx) fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("1"b), 2 last init ("1"b), 2 force init ("1"b), 2 vs init ("1"b), 2 com init ("1"b), 2 expire init ("1"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("1"b), /* requires a date after -exp */ 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); /* first process list control args */ exp_clock = 0; call process_ctl_args(addr(args_allowed), 2, vol_cnt); if volume_sw & (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "volume_names ^[-volume_size^;^]^[-first^;-last^]", vs_sw, most_recent); if expire_sw then do; call convert_date_to_binary_(expire_str, exp_clock, code); if code ^= 0 then call abort_proc(code, expire_str); end; if vol_cnt = 0 then vol_cnt = 1; /* vol_cnt hasn't been set yet. */ if ^(volume_sw) then do; /* structure needs to be allocated */ specified_states(free_state) = True; volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); volume.want_it = False; call get_volumes_specified ("allocated", specified_states, Pvolume, vol_cnt, vs_size, most_recent); end; else do; /* volume names were specified */ call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | rsv_by_another | already_alloc | vol_pvexp | sec_vol | check_pvexp); end; call evaluate_volumes_wanted("allocated", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* allocate volumes specified */ vol_msg_list = ""; do i = 1 to vol_cnt; if volume(i).want_it then do; /* else just skip over it */ if ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; if vpe(volx).state = reserved_state then vpe(volx).processid = "0"b; vpe (volx).state = allocated_state; if comment_sw then vpe (volx).comment = comment_str; else vpe (volx).comment = ""; vpe (volx).expire_date = exp_clock; vpe (volx).expire = expire_sw; if active_fnc then ret = ret || " " || rtrim(vpe(volx).name); else if (first_last_sw) then vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name); call move_to_head(volx); end; end; end; if ^active_fnc then do; if vol_msg_list ^= "" then call msg_proc(0, "Volume set^[s^] ^a ^[has^;have^] been allocated. ^[^a^;^s^]", (vol_cnt > 1), vol_msg_list, (vol_cnt = 1), noaction_msg ^= "", noaction_msg); else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); end; end allocate_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ append_secondary_volumes: proc(old_primary_idx, new_primary_idx, last_volume_idx); /* called by append_volume_set when appending a multiple volume set. old_primary_idx: references the volume set to be appended. (input) new_primary_idx: is the volume set to be appended to. (input) last_volume_idx: index to the last volume in the volume set after the set is appended on. (output) */ dcl (old_primary_idx, new_primary_idx, last_vol, next_vol, last_volume_idx) fixed bin; next_vol = vpe(old_primary_idx).secondary_idx; last_vol = old_primary_idx; do while (next_vol > 0); if active_fnc then ret = ret || " " || rtrim(vpe(next_vol).name); vpe(last_vol).secondary_idx = next_vol; vpe(last_vol).vs_count = 1; vpe(last_vol).previous, vpe(last_vol).next = no_link; vpe(next_vol).primary_idx = new_primary_idx; /* update volume set count of volume set appending to. */ vpe(new_primary_idx).vs_count = vpe(new_primary_idx).vs_count + 1; last_vol = next_vol; next_vol = vpe(next_vol).secondary_idx; end; vpe(last_vol).secondary_idx = no_link; vpe(last_vol).vs_count = 1; vpe(last_vol).previous, vpe(last_vol).next = no_link; last_volume_idx = last_vol; end append_secondary_volumes; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ append_volume_set: proc(); /* procedure called for key append_volume_set. Appends volume sets to the set designated by the primary volume name */ dcl i, vol_cnt, last_vol, next_vol, primary_idx fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("1"b), 2 last init ("1"b), 2 force init ("1"b), 2 vs init ("1"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); if narg < 3 then call abort_proc (error_table_$noarg, "^/Usage: mvp appvs primary_volume_name {secondary_volume_names} {-control_args} "); /* first get primary_volume_name */ ac = 2; call get_arg (ac, ap, al, (0), alp); if ^(volume_in_pool((arg), primary_idx)) then call abort_proc(error_table_$action_not_performed, "Specified primary volume is not in the pool. " || arg); else if vpe(primary_idx).secondary_vol then call abort_proc(error_table_$action_not_performed, "^/Specified primary volume ^a is a secondary volume of set ^a.", arg, vpe(vpe(primary_idx).primary_idx).name); /* now look at secondary volumes specified or control args */ call process_ctl_args(addr(args_allowed), 3, vol_cnt); if (vs_sw | first_last_sw) & volume_sw then call abort_proc(error_table_$inconsistent, "secondary_volumes and -control_args"); if vol_cnt = 0 then vol_cnt = 1; /* vol_cnt hasn't been set yet. */ if ^(volume_sw) then do; /* structure needs to be allocated */ specified_states(free_state) = True; volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); volume.want_it = False; call get_volumes_specified ("freed", specified_states, Pvolume, vol_cnt, vs_size, most_recent); end; else do; /* secondary volumes were specified */ /* validate volumes and label whether we want them or not */ call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_free | already_sec_vol | check_pvexp); end; call evaluate_volumes_wanted("appended", Pvolume, narg, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* append the volumes */ vol_msg_list = ""; last_vol = last_volume_in_set(primary_idx); do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; if active_fnc then ret = ret || " " || rtrim(volume(i).name); next_vol = volume(i).indx; vpe(last_vol).secondary_idx = next_vol; vpe(next_vol).primary_idx = primary_idx; vpe(next_vol).secondary_vol = True; if next_vol = volume_pool.head then volume_pool.head = vpe(next_vol).next; else if vpe(next_vol).previous ^= no_link then vpe(vpe(next_vol).previous).next = vpe(next_vol).next; if next_vol = volume_pool.tail then volume_pool.tail = vpe(next_vol).previous; else if vpe(next_vol).next ^= no_link then vpe(vpe(next_vol).next).previous = vpe(next_vol).previous; vpe(next_vol).next, vpe(next_vol).previous = no_link; if (first_last_sw) then do; vol_msg_list = vol_msg_list || " " || rtrim(vpe(next_vol).name); end; if vpe(next_vol).vs_count > 1 then call append_secondary_volumes(next_vol, primary_idx, last_vol); else last_vol = next_vol; vpe(primary_idx).vs_count = vpe(primary_idx).vs_count + 1; end; end; end; vpe(last_vol).secondary_idx = no_link; call move_to_head(primary_idx); if ^active_fnc then do; if vol_msg_list ^= "" then call msg_proc(0, "Volume^[s^] ^a ^[has^;have^] been appended.", (vol_cnt > 1), vol_msg_list, (vol_cnt = 1)); if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); end; end append_volume_set; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ bad_arg: proc (arg) returns (bit (1)); /* used in key verification */ dcl arg char (*); dcl keyx fixed bin; dcl keys (35) char (32) static options (constant) init ("a", "add", "l", "ls", "list", "p", "pr", "print", "al", "alloc", "allocate", "f", "free", "d", "dl", "delete", "c", "change", "r", "rsv", "reserve", "t", "test", "cm", "comment", "u", "use", "appvs", "append_volume_set", "reuse", "pv_expire", "pvexp", "remove_volume_set", "rmvs", "set"); do keyx = 1 to hbound (keys, 1); if arg = keys (keyx) then return (False); end; return (True); end bad_arg; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ change: proc; /* obselete key that must still be supported. change changes the comment of a volume specified by volume name */ if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg); if vpe (vlx).state = free_state then call abort_proc (0, "Volume ^a is free.", arg); vpe (vlx).comment = arg2; call move_to_head(vlx); return; end change; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_first_then_convert: proc(); dcl VERSION_MSG char(171) int init( "Most likely an older version of mvp is being used which doesn't recognize all mvp structure versions.^/Recommendation is to copy the pool before converting or answer 'no'.") static options(constant); if volume_pool.version = volume_pool_version_1 | volume_pool.version = volume_pool_version_2 then call convert_volume_pool(); else do; /* before assuming this is the original old volume_pool structure with no version associated with it, we will ask the user, and then go merrily along converting it */ /* but before we query the user, is this just a zero length seg? */ if vp_bc = 0 then do; /* must be zero seg */ call convert_volume_pool(); return; end; if subroutine then /* report problem, dont query */ call abort_proc(error_table_$action_not_performed, "Unrecognizable volume_pool version ^d.", volume_pool.version); call command_query_$yes_no (yes_sw, 0, "mvp", VERSION_MSG, "The volume pool ^a ^/has an unrecognizable mvp structure version ^d.^/Do you want to TRY converting to the current version ^d?", path(vol_dir, vol_ename), volume_pool.version, volume_pool_version_3 ); if yes_sw then call convert_volume_pool(); else call abort_proc(error_table_$unimplemented_version, "Unrecognizable volume_pool version ^d", volume_pool.version); end; end check_first_then_convert; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_for_errors: proc(aptr, asize, vol_cnt, primary_idx, check); /* checks for preliminary errors for various keys */ /* aptr: pointer to volume structure containing the volume names (input). asize: size of structure volume (input). vol_cnt: actual count of valid volume names in the structure (input). primary_idx: primary_idx of the set if its a secondary volume, else its just 0 (input). check: 16-bit code specifying which errors to check for. */ dcl check bit(16); dcl error_found bit(16); dcl 1 volume aligned based (aptr), 2 name(asize) char(32), 2 indx(asize) fixed bin, 2 switches, 3 noaction(asize) bit(1) unal, 3 want_it(asize) bit(1)unal; dcl (asize, vol_cnt, primary_idx, i, volx) fixed bin; dcl aptr ptr; dcl just_expired bit(1); error_found = "0000000000000000"b; just_expired = False; volume.want_it = True; volume.noaction = False; do i = 1 to vol_cnt by 1; if ^(volume_in_pool ((volume(i).name), volx)) then do; if check & not_reg then do; volume(i).noaction = True; substr(error_found, fb_not_reg, 1) = True; vol_list.name(fb_not_reg) = vol_list.name(fb_not_reg) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_reg) = vol_list.cnt(fb_not_reg) + 1; end; end; else do; volume(i).indx = volx; if (check & sec_not_found) then do; if ^(volume_in_volume_set((volume(i).name), primary_idx, volx)) then do; volume(i).noaction = True; substr(error_found, fb_sec_not_found, 1) = True; vol_list.name(fb_sec_not_found) = vol_list.name(fb_sec_not_found) || " " || rtrim(volume(i).name); vol_list.cnt(fb_sec_not_found) = vol_list.cnt(fb_sec_not_found) + 1; vol_list.name(fb_prim_name) = rtrim(vpe(primary_idx).name); goto END_CHECK; end; end; if check & already_reg then do; volume(i).noaction = True; substr(error_found, fb_already_reg, 1) = True; vol_list.name(fb_already_reg) = vol_list.name(fb_already_reg) || " " || rtrim(volume(i).name); vol_list.cnt(fb_already_reg) = vol_list.cnt(fb_already_reg) + 1; goto END_CHECK; end; if vpe(volx).secondary_vol then do; if (check & sec_vol) then volx = vpe(volx).primary_idx; else if (check & already_sec_vol)then do; volume(i).noaction = True; substr(error_found, fb_already_sec_vol, 1) = True; vol_list.name(fb_already_sec_vol) = vol_list.name(fb_already_sec_vol) || " " || rtrim(volume(i).name); vol_list.cnt(fb_already_sec_vol) = vol_list.cnt(fb_already_sec_vol) + 1; vol_list.name(fb_prim_name) = rtrim(vpe(vpe(volx).primary_idx).name); goto END_CHECK; end; end; if (check & rsv_by_another) then if vpe (volx).state = reserved_state then do; if reserved_by_another_process(volx) then do; volume(i).noaction = True; substr(error_found, fb_rsv_by_another, 1) = True; vol_list.name(fb_rsv_by_another) = vol_list.name(fb_rsv_by_another) || " " || rtrim(volume(i).name); vol_list.cnt(fb_rsv_by_another) = vol_list.cnt(fb_rsv_by_another) + 1; goto END_CHECK; end; end; if vpe (volx).state = allocated_state then do; if (check & already_alloc) then do; volume(i).noaction = True; substr(error_found, fb_already_alloc, 1) = True; vol_list.name(fb_already_alloc) = vol_list.name(fb_already_alloc) || " " || rtrim(volume(i).name); vol_list.cnt(fb_already_alloc) = vol_list.cnt(fb_already_alloc) + 1; goto END_CHECK; end; else if (check & cant_delete) then do; volume(i).noaction = True; substr(error_found, fb_cant_delete, 1) = True; vol_list.name(fb_cant_delete) = vol_list.name(fb_cant_delete) || " " || rtrim(volume(i).name); vol_list.cnt(fb_cant_delete) = vol_list.cnt(fb_cant_delete) + 1; goto END_CHECK; end; else if (check & cant_pvexp) then do; volume(i).noaction = True; substr(error_found, fb_cant_pvexp, 1) = True; vol_list.name(fb_cant_pvexp) = vol_list.name(fb_cant_pvexp) || " " || rtrim(volume(i).name); vol_list.cnt(fb_cant_pvexp) = vol_list.cnt(fb_cant_pvexp)+ 1; goto END_CHECK; end; if (check & not_exp) then if vpe(volx).expire then do; if vpe(volx).expire_date < clock() | fexp_sw then do; call check_for_pvexp(volx, brief_sw, just_expired); if just_expired then do; volume(i).noaction = True; goto END_CHECK; end; end; else do; /* allocated volume hasn't expired yet */ volume(i).noaction = True; if brief_sw then do; if active_fnc then do; substr(error_found, fb_not_exp, 1) = True; vol_list.name(fb_not_exp) = vol_list.name(fb_not_exp) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_exp) = vol_list.cnt(fb_not_exp)+ 1; goto END_CHECK; end; end; else do; substr(error_found, fb_not_exp, 1) = True; vol_list.name(fb_not_exp) = vol_list.name(fb_not_exp) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_exp) = vol_list.cnt(fb_not_exp)+ 1; goto END_CHECK; end; end; end; end; if (check & vol_pvexp) then if vpe(volx).state = pvexp_state then do; volume(i).noaction = True; substr(error_found, fb_vol_pvexp, 1) = True; vol_list.name(fb_vol_pvexp) = vol_list.name(fb_vol_pvexp) || " " || rtrim(volume(i).name); vol_list.cnt(fb_vol_pvexp) = vol_list.cnt(fb_vol_pvexp) + 1; goto END_CHECK; end; if (check & not_free) then if vpe(volx).state ^= free_state then do; volume(i).noaction = True; substr(error_found, fb_not_free, 1) = True; vol_list.name(fb_not_free) = vol_list.name(fb_not_free) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_free) = vol_list.cnt(fb_not_free) + 1; goto END_CHECK; end; if (check & not_alloc) then if vpe(volx).state ^= allocated_state then do; volume(i).noaction = True; substr(error_found, fb_not_alloc, 1) = True; vol_list.name(fb_not_alloc) = vol_list.name(fb_not_alloc) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_alloc) = vol_list.cnt(fb_not_alloc) + 1; goto END_CHECK; end; if (check & already_free) then if vpe(volx).state = free_state then do; volume(i).noaction = True; substr(error_found, fb_already_free, 1) = True; vol_list.name(fb_already_free) = vol_list.name(fb_already_free) || " " || rtrim(volume(i).name); vol_list.cnt(fb_already_free) = vol_list.cnt(fb_already_free) + 1; goto END_CHECK; end; if (check & not_updated) then if (expire_sw & vpe(volx).state ^= allocated_state) then do; volume(i).noaction = True; substr(error_found, fb_not_updated, 1) = True; vol_list.name(fb_not_updated) = vol_list.name(fb_not_updated) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_updated) = vol_list.cnt(fb_not_updated) + 1; goto END_CHECK; end; if (check & check_pvexp) then do; call check_for_pvexp(volx, False, just_expired); if just_expired then do; volume(i).noaction = True; substr(error_found, fb_check_pvexp, 1) = True; end; end; end; END_CHECK: end; /* end of do loop */ call construct_msg(error_found); end check_for_errors; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ check_for_pvexp: proc(vol_idx, no_print, just_expired); /* checks to see if a volume is physically expired. vol_idx: index of volume to be checked. (input) no_print: designates whether to report the expiration or not. (input) just_expired: set to true if the volume is physically expired, ie. the pv_expire date is less than the current date/time. (output) */ dcl vol_idx fixed bin; dcl (no_print, just_expired) bit(1); just_expired = False; /* assume not expired */ if vpe(vol_idx).pv_expire then do; if vpe(vol_idx).pv_expire_date < clock() | pvexp_secondary_vol_check(vol_idx) then do; if active_fnc then do; /* always want message flagged when AF whether no_print is specified or not */ vol_list.name(fb_check_pvexp) = vol_list.name(fb_check_pvexp) || " " || rtrim(vpe(vol_idx).name); vol_list.cnt(fb_check_pvexp) = vol_list.cnt(fb_check_pvexp) + 1; end; else if ^no_print then do; vol_list.name(fb_check_pvexp) = vol_list.name(fb_check_pvexp) || " " || rtrim(vpe(vol_idx).name); vol_list.cnt(fb_check_pvexp) = vol_list.cnt(fb_check_pvexp) + 1; end; call pvexp_volume(vol_idx); just_expired = True; end; end; end check_for_pvexp; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ comment: proc; /* obselete key that must still be supported. It prints the comment of a specified volume name. */ if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg); if active_fnc then ret = vpe (vlx).comment; else call msg_proc (0, "Volume ^a", vpe (vlx).comment); end comment; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ construct_msg: proc(a_check); /* called by check_for_errors. Constructs the actual error messages if errors were found. a_check: 16 bit code which maps to err_msg array and flags the errors found */ dcl position fixed bin; dcl a_check bit(16); dcl check bit(16); dcl output_msg char(256) var; dcl output_len fixed bin; check = a_check; position = index(check, "1"b); do while (position ^= 0); if position = fb_sec_not_found then call ioa_$rsnnl(err_msg(position), output_msg, output_len, (vol_list.cnt(position) > 1), vol_list.name(position), vol_list.name(fb_prim_name)); else if position = fb_already_sec_vol then call ioa_$rsnnl(err_msg(position), output_msg, output_len, (vol_list.cnt(position) > 1), vol_list.name(position), vol_list.cnt(position) > 1, vol_list.cnt(position) > 1, vol_list.name(fb_prim_name)); else if (position = fb_not_exp | position = fb_check_pvexp) & brief_sw then do; if active_fnc then /* print msg when its an active function regardless brief_sw specified */ call ioa_$rsnnl(err_msg(position), output_msg, output_len, vol_list.cnt(position) > 1, vol_list.name(position), vol_list.cnt(position) > 1); end; else call ioa_$rsnnl(err_msg(position), output_msg, output_len, vol_list.cnt(position) > 1, vol_list.name(position), vol_list.cnt(position) > 1); noaction_msg = noaction_msg || output_msg; substr(check, position, 1) = False; position = index(check, "1"b); end; end construct_msg; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ convert_volume_pool: proc; /* This procedure converts a volume pool to the new format */ dcl 1 volume_pool_old aligned based (vpp), 2 lock bit (36), 2 pad (7) bit (36), 2 n_vol fixed bin (17), 2 vpe_old (1:1 refer (volume_pool_old.n_vol)) aligned, 3 name char (32), 3 id bit (36), 3 state fixed bin (8) unaligned, 3 flags bit (27) unaligned, 3 time char (16) unaligned, 3 comment char (64); dcl 1 volume_pool_old_1 aligned based (vpp), 2 version fixed bin, 2 lock bit (36), 2 n_vol fixed bin (17), 2 pad (5) bit (36), 2 vpe_old_1 (1:1 refer (volume_pool_old_1.n_vol)) aligned, 3 name char (32), 3 id bit (36), 3 state fixed bin, 3 processid bit (36), 3 time fixed bin (71), 3 comment char (64), 3 pad1 (8) bit (36); dcl 1 volume_pool_header_2 aligned, 2 version fixed bin, /* version 2 structure */ 2 lock bit (36), 2 n_vol fixed bin (17), /* number of volume slots in the pool, free and occupied */ 2 volume_count fixed bin(17), /* number of volumes in the pool */ 2 head fixed bin (17), /* index into first volume in pool */ 2 tail fixed bin (17), /* index to last volume in pool */ 2 free_head fixed bin (17), /* index to first empty slot in array */ 2 pad (2) bit (36); dcl 1 volume_pool_entry_2 aligned, /* volume pool entry. each volume has one assoc. with it */ 2 name char (32), /* name of volume set */ 2 id bit (36), /* used by volume dumper only */ 2 state fixed bin, /* state of the volume */ 2 processid bit (36), /* used when reserving volume */ 2 state_date fixed bin (71), /* date the volume was last acted upon */ 2 comment char (64), 2 switches unaligned, 3 secondary_vol bit(1), /* true if volume is a part of a multiple volume set */ 3 pv_expire bit(1), /* true if a physical volume expiration date is assoc. with the volume */ 3 expire bit(1), /* true if an expire date is associated with the volume */ 3 already_printed bit(1), /* used in listing purposes */ 3 pad1 bit(31), 2 pv_expire_date fixed bin(71), /* physical volume expiration date */ 2 expire_date fixed bin(71), /* allocated volume expiration date */ 2 vs_count fixed bin, /* volume set count, includes primary and secondary volumes */ 2 next fixed bin(17), /* index to next node or volume in the pool */ 2 previous fixed bin(17), /* index to previous volume in pool */ 2 primary_idx fixed bin(17), /* index of primary volume in a set */ 2 secondary_idx fixed bin(17); /* index to next secondary volume in a set */ dcl 1 volume_pool_2 aligned based(vpp), /* This is the CURRENT volume pool structure */ 2 header like volume_pool_header_2, 2 vpe_2 (divide(sys_info$max_seg_size - size(volume_pool_header_2), size(volume_pool_entry_2), 17) refer (volume_pool_2.header.n_vol)) like volume_pool_entry_2; if volume_pool.version = volume_pool_version_2 then /* convert version_2 to version_3 */ call set_lock_$lock (volume_pool_2.lock, lock_interval, code); else if volume_pool.version = volume_pool_version_1 then /* convert version_1 to version_3 */ call set_lock_$lock (volume_pool_old_1.lock, lock_interval, code); else /* convert old version to version 3 */ call set_lock_$lock (volume_pool_old.lock, lock_interval, code); if code ^= 0 then do; if ^(code = error_table_$invalid_lock_reset | code = error_table_$locked_by_this_process) then call abort_proc (code, "Attempting to convert volume pool.^/Contact owner of pool ^a", path(vol_dir, vol_ename)); end; if ^(subroutine | active_fnc) then call ioa_("Converting volume pool ^a from version ^d to version ^d.", vol_ename, volume_pool.version, volume_pool_version_3 ); call get_temp_segment_ (myname, new_vpp, code); if code ^= 0 then call abort_proc (code, "Unable to get temp seg - volume pool conversion of ^a failed", path (vol_dir, vol_ename)); new_vpp -> volume_pool.version = volume_pool_version_3; new_vpp -> volume_pool.header.pad = "0"b; if volume_pool.version = volume_pool_version_2 then do; /* convert header stuff first */ new_vpp -> volume_pool.head = vpp -> volume_pool_2.head; new_vpp -> volume_pool.volume_count = vpp -> volume_pool_2.volume_count; new_vpp -> volume_pool.tail = vpp -> volume_pool_2.tail; new_vpp -> volume_pool.free_head = vpp -> volume_pool_2.free_head; new_vpp -> volume_pool.n_vol = vpp -> volume_pool_2.n_vol; /* now copy each entry */ do vlx = 1 to new_vpp -> volume_pool_2.n_vol; new_vpp -> vpe (vlx).name = vpp -> vpe_2(vlx).name; new_vpp -> vpe (vlx).id = vpp -> vpe_2(vlx).id; new_vpp -> vpe (vlx).state = vpp -> vpe_2(vlx).state; new_vpp -> vpe (vlx).state_date = vpp -> vpe_2(vlx).state_date; new_vpp -> vpe (vlx).comment = vpp -> vpe_2(vlx).comment; new_vpp -> vpe (vlx).vs_count = vpp -> vpe_2(vlx).vs_count; new_vpp -> vpe (vlx).pv_expire = vpp -> vpe_2(vlx).pv_expire; new_vpp -> vpe (vlx).expire = vpp -> vpe_2(vlx).expire; new_vpp -> vpe (vlx).pv_expire_date = vpp -> vpe_2(vlx).pv_expire_date; new_vpp -> vpe (vlx).expire_date = vpp -> vpe_2(vlx).expire_date; new_vpp -> vpe (vlx).secondary_idx = vpp -> vpe_2(vlx).secondary_idx; new_vpp -> vpe (vlx).primary_idx = vpp -> vpe_2(vlx).primary_idx; new_vpp -> vpe (vlx).next = vpp -> vpe_2(vlx).next; new_vpp -> vpe (vlx).previous = vpp -> vpe_2(vlx).previous; new_vpp -> vpe (vlx).secondary_vol = vpp -> vpe_2(vlx).secondary_vol; new_vpp -> vpe (vlx).pv_expire = vpp -> vpe_2(vlx).pv_expire; new_vpp -> vpe (vlx).expire = vpp -> vpe_2(vlx).expire; new_vpp -> vpe (vlx).already_printed = vpp -> vpe_2(vlx).already_printed; new_vpp -> vpe (vlx).pad2 = "0"b; end; goto CONVERT_FINISH; end; if volume_pool.version = volume_pool_version_1 then do; /* convert version_1 to version_3 */ new_vpp -> volume_pool.head = 1; new_vpp -> volume_pool.volume_count = volume_pool_old_1.n_vol; new_vpp -> volume_pool.tail = volume_pool_old_1.n_vol; new_vpp -> volume_pool.free_head, new_vpp -> volume_pool.n_vol = volume_pool_old_1.n_vol + 1; do vlx = 1 to new_vpp -> volume_pool.volume_count; new_vpp -> vpe (vlx).name = vpe_old_1 (vlx).name; new_vpp -> vpe (vlx).id = vpe_old_1 (vlx).id; new_vpp -> vpe (vlx).state = vpe_old_1 (vlx).state; new_vpp -> vpe (vlx).state_date = vpe_old_1 (vlx).time; new_vpp -> vpe (vlx).comment = vpe_old_1 (vlx).comment; new_vpp -> vpe (vlx).switches = False; new_vpp -> vpe (vlx).vs_count = 1; new_vpp -> vpe (vlx).pv_expire, new_vpp -> vpe (vlx).expire = False; new_vpp -> vpe (vlx).pv_expire_date, new_vpp -> vpe (vlx).expire_date = 0; new_vpp -> vpe (vlx).secondary_idx = no_link; new_vpp -> vpe (vlx).primary_idx = no_link; new_vpp -> vpe (vlx).next = vlx + 1; new_vpp -> vpe (vlx).previous = vlx - 1; new_vpp -> vpe (vlx).pad2 = "0"b; end; end; else do; /* converting from old version to version 3 */ new_vpp -> volume_pool.head = 1; new_vpp -> volume_pool.volume_count = volume_pool_old.n_vol; new_vpp -> volume_pool.tail = volume_pool_old.n_vol; new_vpp -> volume_pool.free_head, new_vpp -> volume_pool.n_vol = volume_pool_old.n_vol + 1; if volume_pool_old.n_vol = 0 then do; /* the volume pool is either empty or initially created via the create command, not by mvp use */ new_vpp -> volume_pool.n_vol = 1; new_vpp -> volume_pool.volume_count = 0; new_vpp -> volume_pool.tail = 1; new_vpp -> volume_pool.free_head = 1; new_vpp -> volume_pool.head = no_link; new_vpp -> vpe(new_vpp ->volume_pool.n_vol).next = no_link; new_vpp -> vpe(new_vpp ->volume_pool.n_vol).previous = no_link; goto CONVERT_FINISH; end; do vlx = 1 to new_vpp -> volume_pool.volume_count; new_vpp -> vpe (vlx).name = vpe_old (vlx).name; new_vpp -> vpe (vlx).id = vpe_old (vlx).id; new_vpp -> vpe (vlx).state = vpe_old (vlx).state; call convert_date_to_binary_ (vpe_old (vlx).time, new_vpp -> vpe (vlx).state_date, code); if code ^= 0 then do; new_vpp -> vpe (vlx).state_date = clock_(); if ^(subroutine | active_fnc) then call msg_proc (code, "Unable to convert state date of volume ^a. It will be set to the current date.", new_vpp -> vpe(vlx).name); end; new_vpp -> vpe (vlx).comment = vpe_old (vlx).comment; new_vpp -> vpe (vlx).switches = False; new_vpp -> vpe (vlx).vs_count = 1; new_vpp -> vpe (vlx).pv_expire, new_vpp -> vpe (vlx).expire = False; new_vpp -> vpe (vlx).pv_expire_date, new_vpp -> vpe (vlx).expire_date = 0; new_vpp -> vpe (vlx).secondary_idx = no_link; new_vpp -> vpe (vlx).primary_idx = no_link; new_vpp -> vpe (vlx).next = vlx + 1; /* need to link all the volumes together */ new_vpp -> vpe (vlx).previous = vlx - 1; new_vpp -> vpe (vlx).pad2 = "0"b; end; end; /* initialize the free (ie. next available) node in the volume_pool */ new_vpp -> vpe(new_vpp->volume_pool.n_vol).next = no_link; /* designates end of volume list */ new_vpp -> vpe(new_vpp->volume_pool.n_vol).previous = no_link; new_vpp -> vpe(new_vpp->volume_pool.n_vol).secondary_idx = no_link; new_vpp -> vpe(1).previous = no_link; /* start of volume list, no previous volume */ /* end of volume list, no next volume */ new_vpp -> vpe(new_vpp->volume_pool.volume_count).next = no_link; CONVERT_FINISH: call hcs_$fs_move_seg (new_vpp, vpp, 1, code); if code ^= 0 then call abort_proc (code, "Unable to move temp file.- volume pool conversion of ^a failed", path (vol_dir, vol_ename)); call release_temp_segment_ (myname, new_vpp, (0)); return; end convert_volume_pool; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ create_pool: proc(); call hcs_$make_seg (vol_dir, vol_ename, "", RW_ACCESS_BIN, vpp, code); if code = 0 then do; if subroutine then call ioa_ ("^a: Volume pool ^a created.", myname, path (vol_dir, vol_ename)); else call msg_proc (0, "Volume pool ^a created", path (vol_dir, vol_ename)); vpp -> volume_pool.version = volume_pool_version_3; vpp -> volume_pool.n_vol, vpp -> volume_pool.free_head = 1; vpp -> vpe(vpp ->volume_pool.n_vol).next = no_link; vpp -> vpe(vpp ->volume_pool.n_vol).previous = no_link; vpp -> volume_pool.head = no_link; vpp -> volume_pool.tail = 1; vpp -> volume_pool.volume_count = 0; end; else do; if vpp = null then call abort_proc (code, "Unable to create ^a", path (vol_dir, vol_ename)); end; end create_pool; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ delete: proc; /* used only for subroutine delete only */ if vlx = 0 then call abort_proc (0, "Volume ^a is not registered.", arg); if vpe (vlx).state = allocated_state then call abort_proc (0, "Volume ^a is in use and can not be deleted.", arg); call free_node(vlx); return; end delete; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ delete_key: proc(); /* Used by mvp command, it deletes the designated volumes from the pool. */ dcl (volx, i, vol_cnt) fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("1"b), 2 vs init ("0"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: delete volume_names {-control_arg}"); call process_ctl_args(addr(args_allowed), 2, vol_cnt); if vol_cnt = 0 & ^asterisk_sw then call abort_proc (0, "No volumes specified."); if asterisk_sw then do; call msg_proc(-1, "The asterisk '*' is obsolete."); specified_states(free_state) = True; specified_states(pvexp_state) = True; specified_states(reserved_state) = True; tcnt = asterisk_cnt; allocate tvol in (based_area) set (Ptvol); tvol.want_it = False; call get_volumes_specified ("deleted", specified_states, Ptvol, tcnt, vs_size, most_recent); end; if volume_sw then call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | cant_delete | sec_vol | check_pvexp); if asterisk_sw then do; if ^(volume_sw) then do; vol_cnt = 0; volume_cnt = tcnt; allocate volume in (based_area) set (Pvolume); end; do i = 1 to tcnt; volume(vol_cnt + 1).name = tvol(i).name; volume(vol_cnt + 1).indx = tvol(i).indx; volume(vol_cnt + 1).want_it = tvol(i).want_it; vol_cnt = vol_cnt + 1; end; end; call evaluate_volumes_wanted("deleted", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw | abort_sw then do; if active_fnc then do; ret = "false"; return; end; if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); end; /* delete volumes specified */ do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; call free_node(volx); end; end; end; if active_fnc then ret = "true"; else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); end delete_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ determine_alloc_version: proc(); /* as the old allocate format is supported but undocumented, this procedure determines whether we are dealing with the new or old format. This is determined by the following guidelines: (a) If first argument is an asterisk "*", assume old version. (b) Check for an odd or even number of arguments. If an odd number, then assume new version. (c) If control arguments -comment, -com, -volume_set, -vs, -first, -ft, -last, -lt are specified, assume new version. (d) If any even argument (the key "alloc" is not considered an arg) is a volume existing in the pool, assume new version. (e) If any argument is an asterisk (*), assume old version. */ dcl even_arg bit(1); if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp alloc {volume_names} {-control_args}"); /* first check for an asterisk '*' arg. If found then assume old version. */ call get_arg (2, ap, al, (0), alp); if arg = "*" then goto old_version; /* Do we have an odd number of args? Use narg - 1 as the key "alloc" isn't included as an argument */ if mod(narg-1, 2) = 1 then goto new_version; /* check further for which version */ even_arg = False; do ac=2 to narg; call get_arg (ac, ap, al, (0), alp); if arg = "-com" | arg = "-comment" | arg = "-vs" | arg = "-volume_size" | arg = "-ft" | arg = "-first" | arg = "-lt" | arg = "-last" then goto new_version; else if even_arg then do; if volume_in_pool(arg, 0) then goto new_version; end; else if arg = "*" then goto old_version; even_arg = ^(even_arg); end; /* if we get here it means we fell out of loop by default and it's most likely the old version */ /* ie. essentially the even args specified were not volumes known to the pool so we assume it's a comment */ old_version: call process (paired_args, allocate); return; new_version: call allocate_key(); return; end determine_alloc_version; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ evaluate_volumes_wanted: proc(action, aptr, asize, vol_cnt, none_sw, abort_sw); /* called by various keys to determine, out of the volumes specified, which ones are to be acted upon and whether to query the user or not . action: action requested in query message. (input) aptr: pointer to volume structure (input) asize: size of the volume array (input) vol_cnt: number of volumes to be considered. (input) none_sw: true when no volumes are found. (output) abort_sw: true when all volumes specified cannot be acted upon or when the response to the query is no . (output) */ dcl action char(*); dcl (abort_sw, none_sw) bit(1); dcl aptr ptr, (asize, i, vol_cnt, want_cnt, noaction_cnt) fixed bin; dcl 1 volume aligned based (aptr), 2 name(asize) char(32), 2 indx(asize) fixed bin, 2 switches, 3 noaction(asize) bit(1) unal, 3 want_it(asize) bit(1)unal; dcl continue bit(1); none_sw, abort_sw = False; if index(want_str, "1"b) = 0 then do; none_sw = True; return; end; if (index (want_str & noaction_str, "1"b) > 0) then do; /* only query when some of the volumes wanted, some have noaction bit True, and others have noaction bit false */ continue = False; if asize > 1 then do; want_cnt = 0; noaction_cnt = 0; do i = 1 to vol_cnt; if volume(i).want_it then do; want_cnt = want_cnt + 1; if volume(i).noaction then noaction_cnt = noaction_cnt + 1; end; end; if (want_cnt = noaction_cnt) then do; abort_sw = True; return; end; else call query_to_continue(action, "", force_sw, continue); end; if ^(continue) then abort_sw = True; end; end evaluate_volumes_wanted; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ finish: proc(); if lock then do; if vpp ^= null() then do; word_count = currentsize(volume_pool); bit_count = word_count*36; call hcs_$set_bc(vol_dir, vol_ename, bit_count, code); if code ^= 0 then call abort_proc (code, "Unable to set bit count of volume pool ^a", path (vol_dir, vol_ename)); call hcs_$truncate_file (vol_dir, vol_ename, word_count, code); if code ^= 0 then call abort_proc (code, "Unable to trucncate volume pool ^a", path (vol_dir, vol_ename)); end; call set_lock_$unlock (volume_pool.lock, ignore); end; if vpp ^= null & ^subroutine then call hcs_$terminate_noname (vpp, ignore); if Pvolume ^= null() then free volume in (based_area); if Ptvol ^= null() then free tvol in (based_area); end finish; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ format_print_output: proc(vol_idx, secondary_volume); /* formats all the many flavors of outputing the volume pool info via the list key. vol_idx: index to the volume to be listed. (input) secondary_volume: true when the volume is a secondary volume of a set. (input) */ dcl vol_idx fixed bin parameter; dcl (go_ahead, secondary_volume) bit(1); go_ahead = True; if secondary_volume then do; if pvedt_sw & vpe(vol_idx).pv_expire then; else do; /* secondary volumes are listed only when -dfmt, -nm are */ output = ""; /* specified, and when the volume has a pvexp date associated */ go_ahead = False; /* with it and -pvedt was specified. */ end; end; if dfmt_sw & ^(pvedt_sw | edt_sw) then do; if header_to_be_printed & ^active_fnc then do; call ioa_$rsnnl("^/Volume^1-^5xState Date^1-^5xState^3xComment", header_output, header_len); header_to_be_printed = False; end; if secondary_volume then call ioa_$rsnnl ("^1x^a", output, output_len, vpe(vol_idx).name); else call ioa_$rsnnl ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^;^36t^]^a^[^1x^;^44t^]^a", output, output_len, vpe (vol_idx).name, (index(vpe(vol_idx).name, " ") > 12) & ^active_fnc, active_fnc, time_string_ (vpe (vol_idx).state_date), active_fnc, ascii_state (vpe (vol_idx).state), active_fnc, vpe (vol_idx).comment); end; else if dfmt_sw & ((pvedt_sw | edt_sw ) & ^(pvedt_sw & edt_sw )) then do; /* one or the other.....but not both */ if header_to_be_printed & ^active_fnc then do; call ioa_$rsnnl ("^/Volume^1-^5xState Date^1-^5xState^7x^[Expires Date^;PV Expires ^]^6xComment", header_output, header_len, edt_sw); header_to_be_printed = False; end; if secondary_volume then call ioa_$rsnnl ("^1x^a^[^[^1x^;^13t^31x^]^a^;^2s^]", output, output_len, vpe(vol_idx).name, go_ahead, active_fnc, time_string_(vpe(vol_idx).pv_expire_date)); else call ioa_$rsnnl ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^;^36t^]^a^[^1x^;^44t^]^[^20a^;^s^]^[^1x^s^;^[^20x^]^]^[^20a^;^s^]^[^1x^s^;^[^20x^]^]^[^1x^;^2x^]^a", output, output_len, vpe (vol_idx).name, (index(vpe(vol_idx).name, " ") > 12) & ^active_fnc, active_fnc, time_string_ (vpe (vol_idx).state_date), active_fnc, ascii_state (vpe (vol_idx).state), active_fnc, ^(pvedt_sw) & (edt_sw & vpe (vol_idx).expire), (time_string_ (vpe (vol_idx).expire_date)), active_fnc, ^(pvedt_sw) & (edt_sw & ^(vpe (vol_idx).expire)), ^(edt_sw) & (pvedt_sw & vpe (vol_idx).pv_expire), (time_string_ (vpe (vol_idx).pv_expire_date)), active_fnc, ^(edt_sw) & (pvedt_sw & ^(vpe (vol_idx).pv_expire)), active_fnc, vpe (vol_idx).comment); end; else if dfmt_sw & pvedt_sw & edt_sw then do; if header_to_be_printed & ^active_fnc then do; call ioa_$rsnnl ("^/Volume^1-^5xState Date^1-^9xExpires Date^1-^1xPV Expires^/^13tState^34tComment", header_output, header_len); header_to_be_printed = False; end; if secondary_volume then call ioa_$rsnnl ("^1x^a^[^[^1x^;^59t^]^a^;^2s^]", output, output_len, vpe(vol_idx).name, go_ahead, active_fnc, time_string_(vpe(vol_idx).pv_expire_date)); else call ioa_$rsnnl ("^a^[^/^]^[^1x^;^13t^]^20a^[^1x^s^;^[^3x^]^]^[^20a^s^;^s^[^23x^]^]^[^1x^s^;^[^3x^]^]^[^20a^s^;^s^[^23x^]^]^[^1x^;^/^13t^]^a^[^1x^;^34t^]^a", output, output_len, vpe (vol_idx).name, (index(vpe(vol_idx).name, " ") > 12) & ^active_fnc, active_fnc, time_string_ (vpe (vol_idx).state_date), active_fnc, (vpe (vol_idx).expire), (vpe (vol_idx).expire), (time_string_ (vpe (vol_idx).expire_date)), ^active_fnc, active_fnc, (vpe (vol_idx).pv_expire), (vpe (vol_idx).pv_expire), (time_string_ (vpe (vol_idx).pv_expire_date)), ^active_fnc, active_fnc, ascii_state (vpe (vol_idx).state), active_fnc, vpe (vol_idx).comment); end; else if ^(dfmt_sw) then do; /* only individual output fields specified */ if header_to_be_printed & ^active_fnc then do; call ioa_$rsnnl ("^/^[Volume^1-^5x^]^[State Date^1-^5x^]^[State^3x^]^[Expires Date^1-^6x^]^[PV Expires ^9x^]^[Comment^]", header_output, header_len, name_sw, sdt_sw, state_sw, edt_sw, pvedt_sw, comment_sw); header_to_be_printed = False; end; if name_sw then do; call ioa_$rsnnl("^[^1x^]^a^[^/^]", output, output_len, secondary_volume, vpe(vol_idx).name, (index(vpe(vol_idx).name, " ") > 12) & (sdt_sw | comment_sw | pvedt_sw | edt_sw | state_sw) & (^active_fnc)); if sdt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^13t^]^20a^[^1x^;^3x^]", output, output_len, (output), active_fnc, time_string_ (vpe (vol_idx).state_date), active_fnc); if state_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^s^;^[^36t^;^16t^]^]^a", output, output_len, (output), active_fnc, sdt_sw, ascii_state (vpe (vol_idx).state)); if edt_sw & go_ahead then call ioa_$rsnnl ("^a^[^1x^s^;^[^43t^]^]^[^1x^s^;^[^35t^]^]^[^1x^s^;^[^22t^;^13t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", output, output_len, (output), active_fnc, sdt_sw & state_sw, active_fnc, sdt_sw & ^state_sw, active_fnc, state_sw & ^sdt_sw, vpe (vol_idx).expire, time_string_ (vpe (vol_idx).expire_date), active_fnc); if pvedt_sw & go_ahead then call ioa_$rsnnl ("^a^[^1x^s^;^[^22t^]^]^[^1x^s^;^[^43t^]^]^[^1x^s^;^[^58t^]^]^[^1x^s^;^[^36t^;^13t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", output, output_len, (output), active_fnc, state_sw & ^(sdt_sw & edt_sw), active_fnc, state_sw & sdt_sw & ^edt_sw, active_fnc, sdt_sw & edt_sw & ^state_sw, active_fnc, (sdt_sw | edt_sw) & ^state_sw, vpe (vol_idx).pv_expire, time_string_ (vpe (vol_idx).pv_expire_date), active_fnc); if comment_sw & go_ahead then call ioa_$rsnnl ("^a^[^1x^3s^;^[^66t^2s^;^[^58t^1s^;^[^37t^]^]^]^]^[^1x^2s^;^[^43t^1s^;^[^67t^]^]^]^[^1x^3s^;^[^24t^2s^;^[^45t^s^;^[^67t^;^16t^]^]^]^]^a", output, output_len, (output), active_fnc, ^state_sw & (sdt_sw & pvedt_sw & edt_sw), ^state_sw & ((sdt_sw & edt_sw) | (sdt_sw & pvedt_sw) | (pvedt_sw & edt_sw)), ^state_sw & (sdt_sw | pvedt_sw | edt_sw), active_fnc, sdt_sw & state_sw & ^(pvedt_sw | edt_sw), sdt_sw & state_sw & (pvedt_sw | edt_sw), active_fnc, state_sw & ^(sdt_sw | pvedt_sw | edt_sw), ^sdt_sw & state_sw & (pvedt_sw | edt_sw), ^sdt_sw & state_sw & (pvedt_sw & edt_sw), vpe(vol_idx).comment); end; /* end if name_sw */ else if sdt_sw then do; if go_ahead then call ioa_$rsnnl("^20a", output, output_len, time_string_ (vpe (vol_idx).state_date)); if state_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^26t^]^a", output, output_len, (output), active_fnc, ascii_state (vpe (vol_idx).state)); if edt_sw & go_ahead then call ioa_$rsnnl ("^a^[^1x^s^;^[^32t^;^24t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", output, output_len, (output), active_fnc, state_sw, vpe (vol_idx).expire, time_string_ (vpe (vol_idx).expire_date), active_fnc); if pvedt_sw & go_ahead then call ioa_$rsnnl ("^a^[^1x^s^;^[^32t^]^]^[^1x^s^;^[^55t^]^]^[^1x^s^;^[^46t^]^]^[^1x^s^;^[^24t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^29x^]^]", output, output_len, (output), active_fnc, state_sw & ^edt_sw, active_fnc, state_sw & edt_sw, active_fnc, ^state_sw & edt_sw, active_fnc, ^state_sw & ^edt_sw, vpe (vol_idx).pv_expire, time_string_ (vpe (vol_idx).pv_expire_date), active_fnc); if comment_sw & go_ahead then do; if active_fnc then call ioa_$rsnnl("^a^1x^a", output, output_len, (output), vpe(vol_idx).comment); else call ioa_$rsnnl("^a^[^34t^]^[^70t^]^[^70t^]^[^59t^]^[^57t^]^[^47t^]^[^26t^]^a", output, output_len, (output), state_sw & ^(pvedt_sw | edt_sw), state_sw & pvedt_sw & edt_sw, ^state_sw & (pvedt_sw & edt_sw), state_sw & edt_sw, state_sw & pvedt_sw, ^state_sw & (pvedt_sw | edt_sw), ^state_sw & ^pvedt_sw & ^edt_sw, vpe(vol_idx).comment); end; end; /* end if sdt_sw */ else if state_sw then do; if go_ahead then call ioa_$rsnnl("^[^1x^]^5a^[^1x^;^3x^]", output, output_len, active_fnc, ascii_state (vpe (vol_idx).state), active_fnc); if edt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^9t^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len, (output), active_fnc, vpe (vol_idx).expire, time_string_ (vpe (vol_idx).expire_date), active_fnc); if pvedt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^s^;^[^36t^;^9t^]^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len, (output), active_fnc, edt_sw, vpe (vol_idx).pv_expire, time_string_ (vpe (vol_idx).pv_expire_date), active_fnc); if comment_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^s^;^[^57t^]^]^[^1x^2s^;^[^37t^s^;^[^31t^;^9t^]^]^]^a", output, output_len, (output), active_fnc, edt_sw & pvedt_sw, active_fnc, edt_sw, pvedt_sw, vpe(vol_idx).comment); end; /* end if state_sw */ else if edt_sw then do; if go_ahead then call ioa_$rsnnl("^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len, vpe (vol_idx).expire, time_string_ (vpe (vol_idx).expire_date), active_fnc); if pvedt_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^24t^]^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len, (output), active_fnc, vpe (vol_idx).pv_expire, time_string_ (vpe (vol_idx).pv_expire_date), active_fnc); if comment_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^s^;^[^48t^;^27t^]^]^a", output, output_len, (output), active_fnc, pvedt_sw, vpe(vol_idx).comment); end; /* of edt_sw */ else if pvedt_sw & go_ahead then do; call ioa_$rsnnl("^[^20a^[^1x^;^3x^]^;^s^[^1x^;^23x^]^]", output, output_len, vpe (vol_idx).pv_expire, time_string_ (vpe (vol_idx).pv_expire_date), active_fnc); if comment_sw & go_ahead then call ioa_$rsnnl("^a^[^1x^;^22t^]^a", output, output_len, (output), active_fnc, vpe(vol_idx).comment); end; /* of if pvedt_sw */ else if comment_sw & go_ahead then do; call ioa_$rsnnl("^a^[^1x^]", output, output_len, vpe (vol_idx).comment, active_fnc); end; end; end format_print_output; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ free: proc(); /* called by free subroutine only */ if vlx = 0 then call abort_proc (0, "Volume ^a is not registered", arg); if vpe (vlx).state = free_state then call abort_proc (0, "Volume ^a is already free.", arg); vpe (vlx).state = free_state; vpe (vlx).expire = False; call move_to_head(vlx); return; end free; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ free_key: proc(); /* Used by the mvp command, it frees volumes by changing the state to free */ dcl (found, just_expired) bit(1); dcl (i, volx, vol_idx, vol_cnt) fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("1"b), 2 vs init ("0"b), 2 com init ("0"b), 2 expire init ("1"b), 2 brief init ("1"b), 2 fexp init ("1"b), 2 match init ("1"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp free {volume_names} {-control_args}"); /* process control arguments */ call process_ctl_args(addr(args_allowed), 2, vol_cnt); if volume_sw & (expire_sw | match_sw) then call abort_proc(error_table_$inconsistent, "volume names and ^[-expire^;^] ^[-match^;^]", expire_sw, match_sw); /* -expire control arg case */ if expire_sw then do; volume_cnt = volume_pool.n_vol; allocate volume in (based_area) set (Pvolume); volume.want_it, volume.noaction = False; do vol_idx = 1 to volume_pool.n_vol by 1; if vpe(vol_idx).state = allocated_state then do; /* check expires date */ if vpe(vol_idx).expire then do; if vpe(vol_idx).expire_date < clock() | fexp_sw then do; call check_for_pvexp(vol_idx, brief_sw, just_expired); if ^(just_expired) then do; vol_cnt = vol_cnt +1; volume(vol_cnt).name = vpe(vol_idx).name; volume(vol_cnt).indx = vol_idx; volume(vol_cnt).want_it =True; end; end; end; end; /* end if allocate state */ end; /* loop */ if vol_cnt = 0 then call abort_proc(error_table_$action_not_performed, "No allocated volume sets found with overdue expiration dates."); if just_expired then call construct_msg(check_pvexp); end; if match_sw then do; if vol_cnt = 0 then do; /* -expire wasn't specified */ volume_cnt = volume_pool.n_vol; allocate volume in (based_area) set (Pvolume); volume(*).want_it = False; do i = 1 to volume_pool.n_vol; if index (vpe(i).comment, match_string) > 0 then do; /* found a match */ call check_for_pvexp(i, brief_sw, just_expired); if ^(just_expired) then do; /* not expired? we want it */ vol_cnt = vol_cnt + 1; volume(vol_cnt).name = vpe(i).name; volume(vol_cnt).indx = i; volume(vol_cnt).want_it = True; end; end; end; /* do loop */ if vol_cnt = 0 then call abort_proc(error_table_$action_not_performed, "^/No volume sets found with comment string matching ^a.", match_string); if just_expired then call construct_msg(check_pvexp); end; else do; /* -expire was specified and -expire criteria has already been met successfully */ volume(*).want_it, found = False; do i = 1 to vol_cnt; if index (vpe(i).comment, match_string) > 0 then volume(i).want_it, found = True; end; if ^(found) then call abort_proc(error_table_$action_not_performed, "^/No expired volume sets found with comment string matching ^a.", match_string); end; end; /* if match_sw */ /* here's the case where volume names were specified */ else if volume_sw then call check_for_errors (Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | rsv_by_another | already_free | not_exp | check_pvexp); call evaluate_volumes_wanted("freed", Pvolume, narg, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* now free the volumes */ vol_msg_list = ""; do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; if active_fnc then ret = ret || " " || rtrim(vpe(volx).name); vpe(volx).state = free_state; vpe(volx).expire = False; if vpe(volx).state = pvexp_state then vpe(volx).pv_expire = False; if ((expire_sw | match_sw | first_last_sw) & ^brief_sw) then vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name); call move_to_head(volx); end; end; end; if ^active_fnc then do; if vol_msg_list ^= "" then call msg_proc(0, "Volume set^[s^] ^a ^[has^;have^] been freed. ^[^a^;^s^]", (vol_cnt > 1), vol_msg_list, (vol_cnt = 1), (noaction_msg ^= ""), noaction_msg ); else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); end; end free_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ free_node: proc(volx); /* free_node unlinks the volume_pool array entry specified by volx from the volume list and relinks it into the free list of array nodes available for reuse. This effectively deletes a volume from the pool. */ dcl volx fixed bin; if volume_pool.head = volume_pool.tail then do; /* freeing the last volume set in the pool, so set conditions as for an empty pool */ volume_pool.n_vol = 1; volume_pool.volume_count = 0; volume_pool.tail = 1; volume_pool.free_head = 1; volume_pool.head = no_link; vpe(volume_pool.n_vol).next = no_link; vpe(volume_pool.n_vol).previous = no_link; goto END_FREE_NODE; end; if volx = volume_pool.tail then do; volume_pool.tail = vpe(volx).previous; vpe(volume_pool.tail).next = vpe(volx).next; end; else if volx = volume_pool.head then do; volume_pool.head = vpe(volx).next; vpe(volume_pool.head).previous = vpe(volx).previous; end; else do; /* in middle of volume list chain, relink it to exclude volume specified by volx */ vpe(vpe(volx).previous).next = vpe(volx).next; vpe(vpe(volx).next).previous = vpe(volx).previous; end; /* now chain the just freed node into the free node list */ vpe(volx).next = volume_pool.free_head; vpe(volx).previous = no_link; /* backwards index references are not used in the free node linked list */ volume_pool.free_head = volx; volume_pool.volume_count = volume_pool.volume_count - 1; END_FREE_NODE: return; end free_node; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_list_names: proc(aptr, asize, vs_size, most_recent); /* Called by list_key procedure, get_list_names fills in the volume structure with the name and index of the desired volumes. aptr: Pointer to volume structure (input). asize: Size of structure (input). vs_size: Specifies what size of volume sets to look for (input). most_recent: true when the most recently updated volumes are wanted. */ dcl 1 volume aligned based (aptr), 2 name(asize) char(32), 2 indx(asize) fixed bin, 2 switches, 3 noaction(asize) bit(1) unal, 3 want_it(asize) bit(1)unal; dcl (asize, vs_size, volx, vol_idx) fixed bin; dcl aptr ptr; dcl most_recent bit(1); if most_recent then do; /* -first */ vol_idx = 0; volx = volume_pool.head; do while ((volx ^= no_link) & (vol_idx < asize)); if get_names_check_switches(volx, vs_size) then do; vol_idx = vol_idx + 1; volume(vol_idx).name = vpe(volx).name; volume(vol_idx).indx = volx; volume(vol_idx).want_it = True; end; volx = vpe(volx).next; end; end; else do; /* -last specified */ vol_idx = asize; volx = volume_pool.tail; do while ((volx ^= no_link) & (vol_idx > 0)); if get_names_check_switches(volx, vs_size) then do; volume(vol_idx).name = vpe(volx).name; volume(vol_idx).indx = volx; volume(vol_idx).want_it = True; vol_idx = vol_idx - 1; end; volx = vpe(volx).previous; end; end; end get_list_names; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_names_check_switches: proc(volx, vs_size) returns(bit(1)); /* Called by get_list_names, this procedure determines whether a volume meets the criteria specifed and returns true, else false. volx: Index of volume to look at. vs_size: Size of volume set to be considered. */ dcl (volx, vidx, vs_size) fixed bin; if listed_flag(volx) then return(False); /* did we already print this? */ vidx = volx; if vpe(vidx).secondary_vol then /* set vidx to primary volume as he has all the info. */ vidx = vpe(vidx).primary_idx; if ^(specified_states(vpe (vidx).state)) then return(False); if vs_size = -1 then; /* get volume_sets of any size */ else if (vpe(vidx).vs_count) ^= vs_size then return(False); if expire_sw then do; /* want only those whose expire_date is < clock */ if ^(vpe(vidx).expire) then return(False); if vpe(vidx).expire_date > clock() then return(False); end; if match_sw then do; compare = vpe (vidx).comment; if ((index (compare, match_string) = 0) | (index (compare, match_string) = 64)) then return(False); end; return(True); end get_names_check_switches; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_next_arg: proc(Arg_expected, ap1, al1); /* This guy gets the next argument from the argument string, complaining if it's not there */ dcl Arg_expected char(*); dcl (ap1 ptr, al1 fixed bin(21)); if (ac + 1) > narg then do; call abort_proc(error_table_$noarg, "A ^a expected after ^a.", Arg_expected, arg); return; end; ac = ac + 1; call get_arg (ac, ap1, al1, (0), alp); end get_next_arg; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_node: proc() returns (fixed bin); /* Called by add procedures, get_node looks for the next available, or empty node in the volume pool structure, and returns the index of this node to the caller. */ dcl volx fixed bin; volx = volume_pool.free_head; volume_pool.free_head = vpe(volume_pool.free_head).next; if volume_pool.free_head = no_link then do; volume_pool.free_head, volume_pool.n_vol = volume_pool.n_vol + 1; vpe(volume_pool.free_head).next = no_link; vpe(volume_pool.free_head).previous = no_link; vpe(volume_pool.free_head).secondary_idx = no_link; end; return(volx); end get_node; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_number: proc() returns(fixed bin); /* Called when processing arguments for various keys, get_number returns the number specified for control args -first, -last, -vs_size. */ dcl arg_fb fixed bin; if ac = narg then return(1); /* this is the default */ ac = ac + 1; call get_arg (ac, ap, al, (0), alp); if verify(arg, "0123456789") = 0 then do; arg_fb = convert(arg_fb, arg); if arg_fb = 0 then call abort_proc(error_table_$action_not_performed, " 0 volume set size specified."); return(arg_fb); end; else do; ac = ac - 1; /* reset arg pointer */ return(1); end; end get_number; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_volumes_specified: proc(requestor, a_states, aptr, asize, vs_size, most_recent); /* Called by the various key procedures, get_volumes_specified fills in the volume structure with volumes meeting specified criteria, querying the user and reporting errors when appropriate. requestor: The action required by the caller, used in querying (input). a_states: Defines the states possible for a volume to be considered (input). */ dcl requestor char(*); dcl a_states(4) bit(1) parameter; dcl 1 volume aligned based (aptr), 2 name(asize) char(32), 2 indx(asize) fixed bin, 2 switches, 3 noaction(asize) bit(1) unal, 3 want_it(asize) bit(1)unal; dcl (asize, vs_size, i, vol_idx) fixed bin; dcl aptr ptr; dcl (continue, most_recent, just_expired) bit(1); dcl msg char(256); dcl msg_len fixed bin; vol_idx = 0; if most_recent then do; i = volume_pool.head; do while ((i ^= no_link) & (vol_idx < asize)); call get_volumes_specified_loop(); i = vpe(i).next; end; end; else do; /* get the volumes with the oldest state_date */ i = volume_pool.tail; do while ((i ^= no_link) & (vol_idx < asize)); call get_volumes_specified_loop(); i = vpe(i).previous; end; end; if just_expired then call construct_msg(check_pvexp); if vol_idx = 0 then call abort_proc(0, "No ^[free^s^;^[allocated^]^] volume sets ^[of size ^d^;specified^] exist in the pool.^[ Allocate reserved volumes by name.^]", a_states(free_state), a_states(allocated_state), vs_size > 0, vs_size, requestor = "allocated" ); else if vol_idx < asize then do; /* query when some but not all volumes specified are found for -lt and -ft */ continue = False; call ioa_$rsnnl("Only ^d volume set^[s^] ^[of size ^d ^;^s^]can be ^a.", msg, msg_len, vol_idx, vol_idx > 1, vs_size > 0, vs_size, requestor); call query_to_continue("", msg, force_sw, continue); if ^(continue) then call abort_proc(0, "The ^d volume sets specified ^[of size ^d ^]are not in the pool. ", asize, vs_size > 0, vs_size); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ get_volumes_specified_loop: proc(); if a_states(vpe(i).state) then do; if (vpe(i).vs_count = vs_size) | vs_size = -1 then do; if vpe(i).state = free_state then do; call check_for_pvexp(i, brief_sw, just_expired); if ^just_expired then do; vol_idx = vol_idx + 1; volume(vol_idx).indx = i; volume(vol_idx).name = vpe(i).name; volume(vol_idx).want_it = True; end; end; else do; vol_idx = vol_idx + 1; volume(vol_idx).name = vpe(i).name; volume(vol_idx).indx = i; volume(vol_idx).want_it = True; end; end; end; end get_volumes_specified_loop; end get_volumes_specified; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ insert_node: proc(volx); /* Called by the add procedures, insert_node puts a new node into the linked volume list contained in volume_pool.vpe volx: index to the node to be linked (input). */ dcl volx fixed bin; vpe(volx).state_date = clock(); vpe(volx).next = volume_pool.head; if volume_pool.head ^= no_link then vpe(volume_pool.head).previous = volx; vpe(volx).previous = no_link; volume_pool.head = volx; volume_pool.volume_count = volume_pool.volume_count + 1; end insert_node; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ last_volume_in_set: proc(primary_idx) returns(fixed bin); /* Determines the last volume in a volume set and returns the index of this last volume primary_idx: index of the primary volume of the set (input). */ dcl (primary_idx, vol_idx) fixed bin; if vpe(primary_idx).vs_count = 1 then return(primary_idx); vol_idx = vpe(primary_idx).secondary_idx; do while (vpe(vol_idx).secondary_idx ^= no_link); vol_idx = vpe(vol_idx).secondary_idx; end; return (vol_idx); end last_volume_in_set; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ list_key: proc(); /* Lists volume sets in the pool. */ dcl (volx, i) fixed bin; dcl total_char char(256) var; dcl (get_area, not_in_pool) bit(1); if volume_pool.volume_count = 0 then call abort_proc (0, "Volume pool is empty."); vs_size = -1; most_recent = False; allocate listed_flag in (based_area) set (Plisted); listed_flag = False; if narg = 1 then do; /* No control args. Print the default. */ i = volume_pool.head; do while (i ^= no_link); if active_fnc then do; ret = ret || " " || rtrim(vpe(i).name); end; else do; dfmt_sw = True; specified_states = "1"b; call print (i, vs_size); end; i = vpe(i).next; end; goto END_LIST; end; /* first process list control args */ vol_cnt = 0; get_area = True; do ac = 2 to narg; call get_arg (ac, ap, al, (0), alp); if arg = "-match" then do; ac = ac + 1; call get_arg (ac, ap, al, code, alp); if code ^= 0 then call abort_proc (code, "Unable to get arg after ^a", arg); match_sw = True; match_string = arg; end; else if arg = "-free" then do; specified_states(free_state), free_sw = True; all_states = False; end; else if arg = "-alloc" | arg = "-allocate" | arg = "-allocated" then do; specified_states(allocated_state), alloc_sw = True; all_states = False; end; else if arg = "-pvexp" | arg = "-pv_expire" then do; specified_states(pvexp_state), pvexp_sw = True; all_states = False; end; else if arg = "-rsv" | arg = "-reserve" | arg = "-reserved" then do; specified_states(reserved_state), reserve_sw = True; all_states = False; end; else if arg = "-exp" | arg = "-expire" then expire_sw = True; else if arg = "-ft" | arg = "-first" then do; first_last_sw, first_sw, most_recent = True; vol_cnt = get_number(); end; else if arg = "-lt" | arg = "-last" then do; first_last_sw, last_sw = True; most_recent = False; vol_cnt = get_number(); end; else if arg = "-vs" | arg = "-volume_size" then do; vs_sw = True; vs_size = get_number(); end; else if arg = "-nm" | arg = "-name" then name_sw = True; else if arg = "-edt" | arg = "expire_date" then edt_sw = True; else if arg = "-pvedt" | arg = "pv_expire_date" then pvedt_sw = True; else if arg = "-com" | arg = "-comment" then comment_sw = True; else if arg = "-sdt" | arg = "state_date" | arg = "-time" then sdt_sw= True; else if arg = "-state" then state_sw = True; else if arg = "-nhe" | arg = "-no_header" then header_sw, header_to_be_printed = False; else if arg = "-ast" | arg = "-all_states" | arg = "-all" then all_states = True; else if arg = "-dfmt" | arg = "-default_format" then dfmt_sw = True; else if arg = "-he" | arg = "-header" then header_sw, header_to_be_printed = True; else if arg = "-tt" | arg = "-total" then do; totals_wanted = True; header_sw, header_to_be_printed = False; end; else do; /* assume a volume name */ if get_area then do; get_area = False; volume_cnt = narg; allocate volume in (based_area) set (Pvolume); end; volume_sw = True; vol_cnt = vol_cnt + 1; volume(vol_cnt).name = arg; end; end; if totals_wanted & (header_sw | state_sw | sdt_sw | name_sw | edt_sw | pvedt_sw | dfmt_sw | comment_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "-total^[ -header^;^]^[ -state^;^]^[ -state_date^;^]^[ -name^;^]^[ -edt^;^]^[ -pvedt^;^]^[ -dfmt^;^]^[ -first^;^]^[ -last^;^]", header_sw, state_sw, sdt_sw, name_sw, edt_sw, pvedt_sw, dfmt_sw, first_sw, last_sw); if volume_sw & (match_sw | vs_sw | expire_sw | reserve_sw | pvexp_sw | free_sw | alloc_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "volume_names ^[ -match^;^]^[ -volume_size^;^]^[ -expire^;^]^[ -rsv^;^]^[ -pvexp^;^]^[ -free^;^]^[ -alloc^;^]^[ -first^;^]^[ -last^;^]", match_sw, vs_sw, expire_sw, reserve_sw, pvexp_sw, free_sw, alloc_sw, first_sw, last_sw); if ^(name_sw | sdt_sw | state_sw | comment_sw | pvedt_sw | edt_sw) then dfmt_sw = True; if (name_sw & sdt_sw & state_sw & comment_sw) then dfmt_sw = True; if index(state_string, "1"b) = 0 then /* set the default to consider all states */ specified_states(*) = True; if volume_sw then do; not_in_pool = False; do i = 1 to vol_cnt; if volume_in_pool ((volume(i).name), volx) then call print(volx, vs_size); else do; not_in_pool = True; vol_list.name(fb_not_reg) = vol_list.name(fb_not_reg) || " " || rtrim(volume(i).name); vol_list.cnt(fb_not_reg) = vol_list.cnt(fb_not_reg) + 1; end; end; if not_in_pool then call construct_msg(not_reg); end; else if (vs_sw | first_last_sw) then do; if vol_cnt = 0 then vol_cnt = volume_pool.n_vol; /* -ft or -lt not specified, set default */ volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); volume(*).want_it = False; call get_list_names(Pvolume, vol_cnt, vs_size, most_recent); if vol_cnt = 0 then call abort_proc(0, "No volumes met the list criteria specified."); do i = 1 to vol_cnt; if volume(i).want_it then call print (volume(i).indx, vs_size); end; end; else do; i = volume_pool.head; do while (i ^= no_link); call print (i, vs_size); i = vpe(i).next; end; end; if totals_wanted then do; if active_fnc then ret = convert(total_char, total_cnt); else do; if total_cnt = 0 then call msg_proc(0, "No volume sets met the list criteria specified."); else call msg_proc(0, "A total of ^d volume set^[s^].", total_cnt, total_cnt > 1); end; goto END_LIST; end; if total_cnt = 0 then call msg_proc(0, "No volume sets met the list criteria specified."); else if ^active_fnc then if noaction_msg ^= "" then call ioa_$nnl("^/^a", noaction_msg); END_LIST: return; end list_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lock_required: proc() returns(bit(1)); /* lock_required determines whether the pool has to be locked or not, depending on the requested action and the effective access of the caller */ dcl code fixed bin(35); dcl mode fixed bin(5); code = 0; if arg = "l" | arg = "ls" | arg = "list" | arg = "p" | arg = "pr" | arg = "print" | arg = "t" | arg = "test" then do; call hcs_$get_user_effmode (vol_dir, vol_ename, "", (get_ring_()), mode, code); if code ^= 0 then call abort_proc(code, "^/Unable to determine access of ^a", path(vol_dir, vol_ename)); if mode = R_ACCESS_BIN | mode = RE_ACCESS_BIN then return(False); end; return(True); end lock_required; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ lock_volume_pool: proc; /* Locks the volume pool */ lock = False; call set_lock_$lock (volume_pool.lock, lock_interval, code); if code ^= 0 then do; if code = error_table_$invalid_lock_reset then code = 0; else if code = error_table_$locked_by_this_process then code = 0; else call abort_proc (code, " ^a", path (vol_dir, vol_ename)); end; lock = (code = 0); end lock_volume_pool; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ msg: proc (err); /* msg is a semi all-purpose message reporting facility. err = 0 means print the "manage_volume_pool:" header before the message. err = -1 says don't identify myself before the message. */ dcl err fixed bin (35); dcl str char (256); dcl argp ptr; dcl str_len fixed bin; if subroutine then do; if err = 0 | err = -1 then a_code = error_table_$action_not_performed; else a_code = err; if lock then call unlock_volume_pool; end; call cu_$arg_list_ptr (argp); /* convert args to message */ call ioa_$general_rs (argp, 2, 3, str, str_len, "0"b, "0"b); if (err = 0 | err = -1) & ^subroutine & ^active_fnc then call ioa_ ("^[^a: ^;^s^]^a", err = 0, myname, substr (str, 1, str_len)); else call error_rnt (err, myname, substr (str, 1, str_len)); if subroutine then goto return_to_caller; end msg; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_into_state_date_order: proc(volx); /* move_into_state_date_order moves the volume entry specified by volx to the appropriate location in the volume_pool list (based upon its state_date) by relinking the volume list. */ dcl volx fixed bin; dcl voli fixed bin; if volume_pool.head = volx & /* volume is alone in the list.*/ volume_pool.tail = volx then return; if volume_pool.head = volx then do; /* first, remove volume from the list. */ volume_pool.head = vpe(volx).next; vpe(vpe(volx).next).previous = no_link; end; else if volume_pool.tail = volx then do; volume_pool.tail = vpe(volx).previous; vpe(vpe(volx).previous).next = no_link; end; else do; vpe(vpe(volx).previous).next = vpe(volx).next; vpe(vpe(volx).next).previous = vpe(volx).previous; end; do voli = volume_pool.head repeat vpe(voli).next /* then skip over volumes with more */ while (voli ^= no_link & vpe(voli).state_date > vpe(volx).state_date); end; /* state date than our volume. */ if voli = no_link then do; /* put volume at tail of list. */ voli = volume_pool.tail; vpe(voli).next = volx; vpe(volx).previous = voli; vpe(volx).next = no_link; volume_pool.tail = volx; end; else if voli = volume_pool.head then do; /* put volume at head of list. */ voli = volume_pool.head; vpe(voli).previous = volx; vpe(volx).next = voli; vpe(volx).previous = no_link; volume_pool.head = volx; end; else do; /* put volume in front of voli */ vpe(vpe(voli).previous).next = volx; vpe(volx).previous = vpe(voli).previous; vpe(volx).next = voli; vpe(voli).previous = volx; end; end move_into_state_date_order; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ move_to_head: proc(volx); /* move_to_head moves the volume entry specified by volx to the head of the volume_pool list by relinking the volume list. */ dcl volx fixed bin; vpe(volx).state_date = clock(); if volx = volume_pool.head then goto END_MOVE_TO_HEAD; /* Volume is already at head of pool */ if vpe(volx).previous ^= no_link then do; vpe(vpe(volx).previous).next = vpe(volx).next; if volx = volume_pool.tail then volume_pool.tail = vpe(volx).previous; end; if vpe(volx).next ^= no_link then vpe(vpe(volx).next).previous = vpe(volx).previous; vpe(volx).previous = no_link; vpe(volx).next = volume_pool.head; vpe(volume_pool.head).previous = volx; volume_pool.head = volx; END_MOVE_TO_HEAD: return; end move_to_head; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ path: proc (dirname, ename) returns (char (168)); /* Constructs a pathname given the directory name and the entry name. */ dcl dirname char (*); dcl ename char (*); dcl pathname char (168); call ioa_$rsnnl ("^a^[>^]^a", pathname, (0), dirname, dirname ^= ">", ename); return (pathname); end path; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print: proc(vidx, vs_size); /* Called by list_key, print determines whether a volume is to be printed. vidx: Index to volume. vs_size: Size of volumes to be printed. */ dcl (vs_size, printx, vidx) fixed bin; printx = vidx; if listed_flag(printx) then goto END_PRINT; if vpe(printx).secondary_vol then /* set printx to primary volume as he has all the info. */ printx = vpe(printx).primary_idx; if ^(specified_states(vpe (printx).state)) then goto END_PRINT; if vs_size = -1 then; /* get volume_sets of any size */ else if (vpe(printx).vs_count) ^= vs_size then goto END_PRINT; if expire_sw then do; /* print only those whose expire_date is < clock */ if ^(vpe(printx).expire) then goto END_PRINT; if vpe(printx).expire_date > clock() then goto END_PRINT; end; if match_sw then do; compare = vpe (printx).comment; if ((index (compare, match_string) = 0) | (index (compare, match_string) = 64)) then goto END_PRINT; end; /* At this point, all initial criteria to print has been met */ call format_print_output(printx, False); if verify(output, blank_NL) = 0 then; /* don't print if no output is found */ else do; if active_fnc & ^totals_wanted then do; requoted_output = requote_string_ (substr (output, 1, length(output))); ret = ret || " "; ret = ret || requoted_output; end; else do; if header_sw then do; /* did we print the header yet? */ call ioa_("^a", header_output); header_sw = False; end; if ^totals_wanted then call ioa_("^a", output); end; total_cnt = total_cnt + 1; end; if vpe(printx).vs_count > 1 then call print_secondary_volumes(printx); END_PRINT: return; end print; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ print_secondary_volumes: proc(printx); /* Called by print, this procedure prints secondary volumes of a set. */ dcl printx fixed bin parameter; /* printx is the index to the primary volume. we want to now print the secondary volumes only */ listed_flag(printx) = True; printx = vpe(printx).secondary_idx; do while (printx ^= no_link); call format_print_output(printx, True); listed_flag(printx) = True; if output ^= "" then do; if active_fnc & ^totals_wanted then do; requoted_output = requote_string_ (substr (output, 1, length(output))); ret = ret || " "; ret = ret || requoted_output; end; else if ^totals_wanted then call ioa_("^a", output); end; printx = vpe(printx).secondary_idx; end; end print_secondary_volumes; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process: proc (fetch, routine); /* Used by obselete keys change, comment and the old version of allocate. */ dcl fetch bit (1) ; dcl routine entry; if narg < 2 then call abort_proc (error_table_$noarg, ""); ac = 2; do while (ac <= narg); call get_arg (ac, ap, al, (0), alp); if arg = "" then call abort_proc (error_table_$noarg, ""); call search (arg); if fetch then do; ac = ac + 1; call get_arg (ac, apa, ala, code, alp); if code ^= 0 then call abort_proc (code, "No comment specified."); end; call routine; ac = ac + 1; end; return; end process; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ process_ctl_args: proc(Pargs_allowed, begin_arg, vol_cnt); /* Called by various keys to process their control arguments. Also fills in the volume structure when volume names are specified. Pargs_allowed: Pointer to structure which specifies which arguments are allowed for the given key procedure caller (input). begin_arg: Where to start argument processing (input). vol_cnt: The number of volumes to be acted upon (output). */ dcl begin_arg fixed bin; dcl get_area bit(1); dcl vol_cnt fixed bin; dcl Pargs_allowed ptr; dcl 1 args_allowed unaligned based (Pargs_allowed), 2 first bit(1), 2 last bit(1), 2 force bit(1), 2 volume_size bit(1), 2 comment bit(1), 2 expire bit(1), 2 brief bit(1), 2 fexp bit(1), 2 match bit(1), 2 all bit(1), 2 pvexp bit(1), 2 alloc bit(1), 2 reserve bit(1), 2 free bit(1), 2 svol bit(1), 2 asterisk bit(1), 2 exp_dt bit(1), /* requires a date after -exp */ 2 pvexp_dt bit(1), /* requires a date after -pvexp */ 2 state_dt bit(1); vs_size = -1; /* default is any size volume set if -vs isn't specified */ vol_cnt = 0; asterisk_cnt = 0; get_area = True; most_recent = False; do ac = begin_arg to narg; call get_arg (ac, ap, al, (0), alp); if arg = "-exp" | arg = "-expire" then do; if ^(args_allowed.expire) then goto bad_ctl; expire_sw = True; if (args_allowed.exp_dt) then /* some keys require a date */ call get_next_arg("date", expire_ptr, expire_len); end; else if arg = "-fc" | arg = "-force" then do; if ^(args_allowed.force) then goto bad_ctl; force_sw = True; end; else if arg = "-ft" | arg = "-first" then do; if ^(args_allowed.first) then goto bad_ctl; first_last_sw, first_sw, most_recent = True; vol_cnt = get_number(); end; else if arg = "-lt" | arg = "-last" then do; if ^(args_allowed.last) then goto bad_ctl; first_last_sw, last_sw = True; most_recent = False; vol_cnt = get_number(); end; else if arg = "*" then do; /* have to support obsolete '*' use for test, delete, reserve. Same as -last 1 */ if ^(args_allowed.asterisk) then goto bad_ctl; asterisk_sw = True; most_recent = False; asterisk_cnt = asterisk_cnt + 1; end; else if arg = "-vs" | arg = "-volume_size" then do; if ^(args_allowed.volume_size) then goto bad_ctl; vs_sw = True; vs_size = get_number(); end; else if arg = "-com" | arg = "-comment" then do; if ^(args_allowed.comment) then goto bad_ctl; comment_sw = True; call get_next_arg("comment", com_ptr, com_len); end; else if arg = "-bf" | arg = "-brief" then do; if ^(args_allowed.brief) then goto bad_ctl; brief_sw = True; end; else if arg = "-fexp" | arg = "-force_expire" then do; if ^(args_allowed.fexp) then goto bad_ctl; fexp_sw = True; end; else if arg = "-a" | arg = "-all" then do; if ^(args_allowed.all) then goto bad_ctl; all_sw = True; end; else if arg = "-pvexp" | arg = "-pv_expire" then do; if ^(args_allowed.pvexp) then goto bad_ctl; pvexp_sw = True; if (args_allowed.pvexp_dt) then /* add and set keys require a date */ call get_next_arg("date", pvexp_ptr, pvexp_len); end; else if arg = "-stdt" | arg = "-state_date" then do; if ^(args_allowed.state_dt) then go to bad_ctl; state_dt_sw = True; call get_next_arg("date", state_dt_ptr, state_dt_len); end; else if arg = "-free" then do; if ^(args_allowed.free) then goto bad_ctl; free_sw = True; end; else if arg = "-alloc" | arg = "-allocate" | arg = "-allocated" then do; if ^(args_allowed.alloc) then goto bad_ctl; alloc_sw = True; end; else if arg = "-rsv" | arg = "-reserved" | arg = "-reserve" then do; if ^(args_allowed.reserve) then goto bad_ctl; reserve_sw = True; end; else if arg = "-match" then do; if ^(args_allowed.match) then goto bad_ctl; ac = ac + 1; call get_arg (ac, ap, al, code, alp); if code ^= 0 then call abort_proc (code, "Unable to get arg after ^a", arg); match_sw = True; match_string = arg; end; else if arg = "-svol" | arg = "-secondary_volumes" then do; if ^(args_allowed.svol) then goto bad_ctl; svol_sw = True; end; else do; /* assume a volume name */ if get_area then do; get_area = False; volume_cnt = narg; allocate volume in (based_area) set (Pvolume); end; volume_sw = True; vol_cnt = vol_cnt + 1; volume(vol_cnt).name = arg; end; end; return; bad_ctl: call abort_proc(error_table_$badopt, " ^a", arg); end process_ctl_args; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ pv_expire_key: proc(); /* Procedure which handles the pv_expire key */ dcl primary_idx fixed bin; dcl (i, volx, vol_cnt) fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("1"b), 2 vs init ("0"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); if narg < 2 then call abort_proc (error_table_$noarg, "Usage: mvp pvexp volume_names {-control_arg}"); /* get volume_names */ call process_ctl_args(addr(args_allowed), 2, vol_cnt); if vol_cnt = 0 then call abort_proc (error_table_$noarg, "No volume names specified."); call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | check_pvexp); call evaluate_volumes_wanted("physically expired", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw | abort_sw then do; if active_fnc then do; ret = "false"; return; end; if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); end; /* expire the volumes */ do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; vpe(volx).state = pvexp_state; vpe(volx).pv_expire = False; if vpe(volx).vs_count > 1 then do; /* multiple volume set */ primary_idx = volx; do while (volx ^= no_link); vpe(volx).pv_expire = False; volx = vpe(volx).secondary_idx; end; volx = primary_idx; end; call move_to_head(volx); end; end; end; if active_fnc then ret = "true"; else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); end pv_expire_key; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ pvexp_secondary_vol_check: proc(a_idx) returns(bit(1)); /* Called by check_for_pvexp, this procedure determines whether any secondary volumes of a set have physically expired. If so, true is returned, else false. */ dcl (a_idx, vol_idx) fixed bin; vol_idx = a_idx; if vpe(vol_idx).vs_count = 1 then return(False); /* Not a multiple volume set */ if vpe(vol_idx).state = allocated_state then return(False); /* allocated volumes cannot be expired */ vol_idx = vpe(vol_idx).secondary_idx; do while (vol_idx ^= no_link); if vpe(vol_idx).pv_expire & vpe(vol_idx).pv_expire_date < clock() then return(True); vol_idx = vpe(vol_idx).secondary_idx; end; return(False); end pvexp_secondary_vol_check; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ pvexp_volume: proc(vol_idx); /* Called by check_for_pvexp, pvexp_volume does the actual work of physically expiring a volume as specified by vol_idx. */ dcl (primary_idx, vol_idx) fixed bin; vpe(vol_idx).state = pvexp_state; vpe(vol_idx).pv_expire = False; if vpe(vol_idx).vs_count > 1 then do; /* multiple volume set, reset secondary volumes too */ primary_idx = vol_idx; do while (vol_idx ^= no_link); vpe(vol_idx).pv_expire = False; vol_idx = vpe(vol_idx).secondary_idx; end; vol_idx = primary_idx; end; call move_to_head(vol_idx); end pvexp_volume; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ query_to_continue: proc(requestor, msg, force, continue); /* Determines whether to query or not. requestor: The action required by the caller, used in querying (input). msg: The message specified by the caller (input). force: Specifies whether to query the user or not (input). continue: Continue or abort the request? (output). */ dcl (continue, force) bit(1); dcl (requestor, msg) char(*); if force then continue = True; else if active_fnc then continue = False; else continue = yes_to_query(requestor, msg); return; end query_to_continue; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ remove_volume_set: proc(); /* This procedure handles the rmvs key of the mvp command */ dcl (done, just_expired, found) bit(1); dcl i, volx, current_idx, remove_cnt, prev_idx, primary_idx, set_state fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("1"b), 2 vs init ("0"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("1"b), 2 fexp init ("1"b), 2 match init ("0"b), 2 all init ("1"b), 2 pvexp init ("1"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); if narg < 3 then call abort_proc (error_table_$noarg, "^/Usage: mvp rmvs primary_volume_name {secondary_volume_names} {-control_args} "); /* first get primary_volume_name */ ac = 2; call get_arg (ac, ap, al, (0), alp); if ^(volume_in_pool((arg), primary_idx)) then call abort_proc(error_table_$action_not_performed, "Primary volume specified is not in the pool. " || arg); else if vpe(primary_idx).secondary_vol then call abort_proc(error_table_$action_not_performed, "^/Primary volume specified ^a is a secondary volume of set ^a.", arg, vpe(vpe(primary_idx).primary_idx).name); /* now look at secondary volumes specified or control args */ call process_ctl_args(addr(args_allowed), 3, vol_cnt); if pvexp_sw then set_state = pvexp_state; else set_state = free_state; if (pvexp_sw & all_sw) then call abort_proc(error_table_$inconsistent, "-pvexp -all"); if (pvexp_sw | all_sw) & volume_sw then call abort_proc(error_table_$inconsistent, "secondary_volumes and -control_args"); if vpe(primary_idx).state = allocated_state & ^(fexp_sw) then do; /* check -expire date */ if vpe(primary_idx).expire & (vpe(primary_idx).expire_date > clock()) then do; /* hasn't expired, abort request */ if brief_sw then do; if active_fnc then call abort_proc(error_table_$action_not_performed, "^/Volume set ^a is not expired. ^a", vpe(primary_idx).name, time_string_(vpe(primary_idx).expire_date)); end; else call abort_proc(error_table_$action_not_performed, "^/Volume set ^a is not expired. ^a", vpe(primary_idx).name, time_string_(vpe(primary_idx).expire_date)); end; end; if ^(volume_sw) then do; vol_cnt, volume_cnt = max( 1, vpe(primary_idx).vs_count - 1); allocate volume in (based_area) set (Pvolume); volume.want_it, volume.noaction = False; if vpe(primary_idx).vs_count = 1 then /* volume set is size one */ volx = primary_idx; else /* set index to first secondary volume. primary volume stays unchanged */ volx = vpe(primary_idx).secondary_idx; do i = 1 to vol_cnt while (volx >= 1); /* fill volume array with volumes to be removed */ volume(i).name = vpe(volx).name; volume(i).indx = volx; volume(i).want_it = True; volx = vpe(volx).secondary_idx; end; if pvexp_sw then do; volume.want_it = False; do i = 1 to vol_cnt; if vpe(volume(i).indx).pv_expire & (vpe(volume(i).indx).pv_expire_date < clock()) then volume(i).want_it = True; end; end; end; else do; /* secondary volume names were specified, verify them. */ call check_for_errors(Pvolume, volume_cnt, vol_cnt, primary_idx, not_reg | sec_not_found); end; call evaluate_volumes_wanted("removed", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "No physically expired volumes found in set ^a.", vpe(primary_idx).name); else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* now remove the volumes */ remove_cnt = 0; prev_idx = primary_idx; if vpe(primary_idx).vs_count = 1 then current_idx = primary_idx; else current_idx = vpe(primary_idx).secondary_idx; done = False; do while (^done); if vpe(current_idx).secondary_idx <= 0 then done = True; found = False; do i = 1 to vol_cnt while (^found); if volume(i).want_it & (volume(i).name = vpe(current_idx).name) then found = True; end; if found then call remove_volume(); else do; /* update prev_idx */ prev_idx = current_idx; current_idx = vpe(current_idx).secondary_idx; end; end; /* do loop */ vpe(primary_idx).vs_count = max(1, vpe(primary_idx).vs_count - remove_cnt); if all_sw then do; /* remove primary volume also */ current_idx, prev_idx = primary_idx; call remove_volume(); end; if just_expired then do; call construct_msg(check_pvexp); if ^active_fnc & noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); end; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ remove_volume: proc(); /* Internal procedure to remove_volume_set procedure, this guy does the actual removing of volumes */ dcl save_idx fixed bin; /* first check pvexp date to print message */ call check_for_pvexp(current_idx, brief_sw, just_expired); remove_cnt = remove_cnt + 1; /* relink the volume set chain */ vpe(prev_idx).secondary_idx = vpe(current_idx).secondary_idx; /* reset the vpe being removed */ if active_fnc & ^just_expired then ret = ret || " " || rtrim(vpe(current_idx).name); vpe(current_idx).comment = ""; vpe(current_idx).secondary_vol = False; vpe(current_idx).expire = False; vpe(current_idx).expire_date = 0; vpe(current_idx).primary_idx = no_link; if ^just_expired then do; vpe(current_idx).state = free_state; vpe(current_idx).state_date = clock(); call move_to_head(current_idx); end; if vpe(current_idx).secondary_idx > 0 then do; save_idx = current_idx; current_idx = vpe(current_idx).secondary_idx; vpe(save_idx).secondary_idx = no_link; end; end remove_volume; end remove_volume_set; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reserved_by_another_process: proc(vol_idx) returns (bit(1)); /* Returns true when a volume specified by vol_idx is reserved by another process */ dcl vol_idx fixed bin; if vpe(vol_idx).processid ^= get_process_id_() then do; /* reserved by another process */ call hcs_$validate_processid (vpe (vol_idx).processid, code); if code = error_table_$process_unknown then return(False); /* other process is not active */ else return(True); end; return(False); end reserved_by_another_process; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reserve_key: proc(); /* Procedure which handles the mvp command reserve key. */ dcl (i, vol_cnt, volx) fixed bin; dcl just_expired bit(1); /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("1"b), 2 last init ("1"b), 2 force init ("1"b), 2 vs init ("1"b), 2 com init ("1"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("1"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); /* first process control args */ if narg < 2 then call abort_proc (error_table_$noarg, "Usage: reserve {volume_names} {-control_args}"); specified_states(free_state) = True; just_expired = False; call process_ctl_args(addr(args_allowed), 2, vol_cnt); if asterisk_sw then if (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "The asterisk '*' is obsolete. Use '-last'"); else call msg_proc(-1, "The asterisk '*' is obsolete. Use '-last'"); if volume_sw & (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "volume_names ^[-volume_size^;^]^[-first^;-last^]", vs_sw, most_recent); if asterisk_sw then do; tcnt = asterisk_cnt; allocate tvol in (based_area) set (Ptvol); tvol.want_it = False; call get_volumes_specified ("reserved", specified_states, Ptvol, tcnt, vs_size, most_recent); end; else if ^(volume_sw) then do; /* -first or -last or -vs were specified */ if vol_cnt = 0 then vol_cnt = 1; volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); call get_volumes_specified ("reserved", specified_states, Pvolume, vol_cnt, vs_size, most_recent); end; if volume_sw then call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | not_free | check_pvexp); if asterisk_sw then do; if ^(volume_sw) then do; vol_cnt = 0; volume_cnt = tcnt; allocate volume in (based_area) set (Pvolume); end; do i = 1 to tcnt; volume(vol_cnt + 1).name = tvol(i).name; volume(vol_cnt + 1).indx = tvol(i).indx; volume(vol_cnt + 1).want_it = tvol(i).want_it; vol_cnt = vol_cnt + 1; end; end; call evaluate_volumes_wanted("reserved", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* reserve volumes specified */ vol_msg_list = ""; vol_msg_cnt = 0; do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; if active_fnc then ret = ret || " " || rtrim(vpe(volx).name); vpe (volx).state = reserved_state; vpe(volx).processid = get_process_id_ (); if comment_sw then vpe (volx).comment = comment_str; else vpe (volx).comment = ""; if (first_last_sw | asterisk_sw) then do; vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name); vol_msg_cnt = vol_msg_cnt + 1; end; call move_to_head(volx); end; end; end; if ^active_fnc then do; if vol_msg_list ^= "" then call msg_proc (0, "Volume set^[s^] ^a ^[has^;have^] been reserved. ^[^a^;^s^]", (vol_msg_cnt > 1), vol_msg_list, (vol_msg_cnt = 1), (noaction_msg ^=""), noaction_msg); else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg ); end; end reserve_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ reuse: proc(); /* Procedure which handles the mvp command reuse key. */ dcl (i, vol_cnt, volx) fixed bin; dcl just_expired bit(1); /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("1"b), 2 last init ("1"b), 2 force init ("1"b), 2 vs init ("1"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("1"b), 2 fexp init ("1"b), 2 match init ("1"b), 2 all init ("0"b), 2 pvexp init ("0"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("0"b), 2 asterisk init ("0"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); /* first process list control args */ call process_ctl_args(addr(args_allowed), 2, vol_cnt); if volume_sw & (vs_sw | match_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "volume_names ^[-volume_size^;^]^[-match^;^]^[-first^;-last^]", vs_sw, match_sw, most_recent); if first_last_sw | vs_sw then do; if vol_cnt = 0 then volume_cnt, vol_cnt = 1; else volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); volume.want_it, volume.noaction = False; specified_states(allocated_state) = True; call get_volumes_specified("re-allocated", specified_states, Pvolume, vol_cnt, vs_size, most_recent); end; if match_sw then do; if vol_cnt = 0 then do; volume_cnt, vol_cnt = volume_pool.n_vol; allocate volume in (based_area) set (Pvolume); end; volume.want_it, volume.noaction = False; do i = 1 to vol_cnt; if (index (vpe(i).comment, match_string) > 0) & (vpe(i).state = allocated_state) then do; volume(i).name = vpe(i).name; volume(i).indx = i; volume(i).want_it = True; if (vpe(i).expire & vpe(i).expire_date < clock()) & ^fexp_sw then volume(i).noaction = True; call check_for_pvexp(i, brief_sw, just_expired); if just_expired then volume(i).noaction = True; end; end; /* do loop */ if index(want_str, "1"b) = 0 then if ^(brief_sw) then call abort_proc(error_table_$action_not_performed, "^/No allocated volumes found with comment string matching ^a.", match_string); if just_expired then call construct_msg(check_pvexp); end; /* if match_sw */ /* here's the case where volume names were specified */ else if volume_sw then do; call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_alloc | already_sec_vol | not_exp | check_pvexp); end; call evaluate_volumes_wanted("reused", Pvolume, volume_cnt, vol_cnt, none_sw, abort_sw); if none_sw then call abort_proc(error_table_$action_not_performed, "Volume set^[s^] specified ^[are^;is^] not registered in the pool.", (vol_cnt > 1), (vol_cnt > 1)); else if abort_sw then if noaction_msg ^= "" then call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); /* now free and re-allocate the volumes */ vol_msg_list = ""; vol_msg_cnt = 0; do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; volx = volume(i).indx; if active_fnc then ret = ret || " " || rtrim(vpe(volx).name); if (( match_sw | first_last_sw) & ^brief_sw) then do; vol_msg_cnt = vol_msg_cnt +1; vol_msg_list = vol_msg_list || " " || rtrim(vpe(volx).name); end; call move_to_head(volx); end; end; end; if ^active_fnc then do; if vol_msg_list ^= "" then call msg_proc(-1, "^a: Volume set^[s^] ^a ^[has^;have^] been re-allocated. ^[^a^;^s^]", myname, (vol_msg_cnt > 1), vol_msg_list, (vol_msg_cnt = 1), (noaction_msg ^= ""), noaction_msg); end; end reuse; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ search: proc (name); /* Used by obselete keys and subroutine entry points. */ dcl name char (*); vlx = 0; if name = "*" then do; tvlx = volume_pool.tail; do while ((tvlx ^= no_link) & (vlx = 0)); if vpe(tvlx).state = free_state & vpe(tvlx).vs_count = 1 then vlx = tvlx; tvlx = vpe(tvlx).previous; end; end; else do; if volume_in_pool(arg, tvlx) then do; if vpe(tvlx).secondary_vol then vlx = vpe(tvlx).primary_idx; else vlx = tvlx; end; end; return; end search; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_key: proc(); /* Procedure which handles the mvp command set key. */ dcl (exp_clock, pv_clock) fixed bin(71); dcl i, vol_idx fixed bin; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("0"b), 2 last init ("0"b), 2 force init ("0"b), 2 vs init ("0"b), 2 com init ("1"b), 2 expire init ("1"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("0"b), 2 all init ("0"b), 2 pvexp init ("1"b), 2 alloc init ("0"b), 2 reserve init ("0"b), 2 free init ("0"b), 2 svol init ("1"b), 2 asterisk init ("0"b), 2 exp_dt init ("1"b), 2 pvexp_dt init ("1"b), 2 state_dt init ("1"b)) bit(1); if narg < 3 then call abort_proc (error_table_$noarg, "^/Usage: mvp set volume_names -control_args "); pv_clock = 0; call process_ctl_args(addr(args_allowed), 2, vol_cnt); if vol_cnt = 0 then call abort_proc(0, "No volume names specified."); if ^(comment_sw | pvexp_sw | expire_sw | state_dt_sw) then call abort_proc(0, "No -control_args specified."); if (svol_sw & ^(pvexp_sw | state_dt_sw)) then call abort_proc(error_table_$inconsistent, "-svol is used only in conjuction with -pvexp or -state_date"); if pvexp_sw then do; call convert_date_to_binary_(pvexp_str, pv_clock, code); if code ^= 0 then call abort_proc(code, pvexp_str); end; if expire_sw then do; call convert_date_to_binary_(expire_str, exp_clock, code); if code ^= 0 then call abort_proc(code, expire_str); end; if state_dt_sw then do; call convert_date_to_binary_(state_dt_str, state_dt_clock, code); if code ^= 0 then call abort_proc(code, state_dt_str); end; call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | not_updated | check_pvexp); if vol_list.name(fb_not_updated) ^= "" then do; /* this is the only case to abort the request */ if active_fnc then do; ret = "false"; return; end; else call abort_proc(error_table_$action_not_performed, "^a", noaction_msg); end; /* process volumes specified */ do i = 1 to vol_cnt; if volume(i).want_it then do; if ^(volume(i).noaction) then do; vol_idx = volume(i).indx; if pvexp_sw then do; if svol_sw then do; if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx; do while (vol_idx ^= no_link); vpe(vol_idx).pv_expire_date = pv_clock; vpe(vol_idx).pv_expire = True; vol_idx = vpe(vol_idx).secondary_idx; end; end; else do; vpe(vol_idx).pv_expire = pvexp_sw; vpe(vol_idx).pv_expire_date = pv_clock; end; vol_idx = volume(i).indx; end; if state_dt_sw then do; if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx; do while (vol_idx ^= no_link); vpe(vol_idx).state_date = state_dt_clock; vol_idx = vpe(vol_idx).secondary_idx; end; vol_idx = volume(i).indx; call move_into_state_date_order (vol_idx); end; if vpe(vol_idx).secondary_vol then vol_idx = vpe(vol_idx).primary_idx; if expire_sw & vpe(vol_idx).state = allocated_state then do; vpe(vol_idx).expire = True; vpe(vol_idx).expire_date = exp_clock; end; if comment_sw then vpe (vol_idx).comment = comment_str; end; end; end; if active_fnc then ret = "true"; else if noaction_msg ^= "" then call msg_proc(0, "^a", noaction_msg); end set_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ setup: proc ; /* Called by just about everyone to initialize things */ Pvolume, Ptvol, areap, retp, vpp = null(); lock = False; code, ecode = 0; active_fnc = False; abort_proc = abort; msg_proc = msg; if subroutine then do; a_code = 0; myname = "manage_volume_pool_"; error_rnt = a_error_rnt; vpp = a_vpp; if vpp ^= null() then do; if volume_pool.version ^= volume_pool_version_3 then call check_first_then_convert(); call lock_volume_pool; end; end; else do; noaction_cnt, total_cnt = 0; vol_msg_list, noaction_msg = ""; vol_list.name = ""; vol_list.cnt = 0; free_sw, match_sw, most_recent, asterisk_sw = False; name_sw, sdt_sw, comment_sw, state_sw, alloc_sw, reserve_sw, free_sw, force_sw, fexp_sw, brief_sw, pvedt_sw, edt_sw, first_sw, last_sw, expire_sw, first_last_sw, pvexp_sw, state_dt_sw, all_sw, totals_wanted, svol_sw, volume_sw, vs_sw, dfmt_sw, specified_states(*) = False; all_states, header_sw, header_to_be_printed = True; call cu_$arg_list_ptr (alp); call cu_$af_return_arg (narg, retp, retl, code); active_fnc = (code = 0); if active_fnc then error_rnt = active_fnc_err_; else error_rnt = com_err_; myname = "manage_volume_pool"; if active_fnc then get_arg = cu_$af_arg_ptr_rel; else get_arg = cu_$arg_ptr_rel; if narg = 0 then arg_err: call abort_proc (0, "USAGE: manage_volume_pool key {-control_args}"); call get_arg (1, ap, al, (0), alp); if bad_arg (arg) then goto arg_err; if arg = "use" | arg = "u" then goto END_SETUP; else call setup_pool_path("0"b); if volume_pool.version ^= volume_pool_version_3 then call check_first_then_convert(); if lock_required() then call lock_volume_pool(); areap = get_system_free_area_(); end; END_SETUP: return; end setup; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ setup_pool_path: proc(have_pool_path); /* Two cases: */ /* 1) have_pool_path is FALSE */ /* Called by setup and use_key procedures. Sets the default volume pool, which is person_id.volumes in */ /* the user's home_dir, */ /* creating the pool if it doesn't exist. */ /* 2) have_pool_path is TRUE */ /* Called by use_key procedure and set_pool_path entry. Initiates the volume pool specified by arg */ /* creating the pool if it doesn't exist. */ /* */ /* Variables vol_dir and vol_ename are set. */ dcl have_pool_path bit(1); if have_pool_path then do; call expand_pathname_ (arg, vol_dir, vol_ename, code); if code ^= 0 then call abort_proc (code, "Unable to expand ^a", arg); end; else do; /* Use volume pool last referenced */ if vol_dir = "" then do; /* no previous volume pool was referenced; set to default pool, */ call user_info_$homedir (vol_dir); call user_info_ (vol_ename, "", ""); end; /* if vol_dir = "" */ end; call suffixed_name_$make (vol_ename, "volumes", vol_ename, code); if code ^= 0 then call abort_proc (code, "Unable to construct volume pool name ^a.volumes.", vol_ename); call initiate_file_ (vol_dir, vol_ename, RW_ACCESS, vpp, vp_bc, code); if vpp = null then call create_pool(); if subroutine then a_vpp = vpp; end setup_pool_path; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ test_key: proc(); /* Procedure which handles the mvp command test key. */ dcl (volx, list_cnt, list_no_cnt, vol_cnt, i) fixed bin; dcl (yes, no) bit(1); dcl (test_vol_list, test_no_vol_list) char(256) var; /* The structure below describes the control arguments allowed for a given key. A control arg is valid when the bit is "1"b. */ dcl 1 args_allowed unaligned static int options(constant), (2 first init ("1"b), 2 last init ("1"b), 2 force init ("0"b), 2 vs init ("1"b), 2 com init ("0"b), 2 expire init ("0"b), 2 brief init ("0"b), 2 fexp init ("0"b), 2 match init ("1"b), 2 all init ("0"b), 2 pvexp init ("1"b), 2 alloc init ("1"b), 2 reserve init ("1"b), 2 free init ("1"b), 2 svol init ("0"b), 2 asterisk init ("1"b), 2 exp_dt init ("0"b), 2 pvexp_dt init ("0"b), 2 state_dt init ("0"b)) bit(1); /* process control args */ if narg < 2 then call abort_proc (error_table_$noarg, "^/Usage: mvp test {volume_names} {-control_args}"); call process_ctl_args(addr(args_allowed), 2, vol_cnt); if asterisk_sw then if (vs_sw | first_last_sw) then call abort_proc(error_table_$inconsistent, "The asterisk '*' is obsolete. Use '-last'"); else call msg_proc(-1, "The asterisk '*' is obsolete. Use '-last'"); if volume_sw & (vs_sw | first_last_sw ) then call abort_proc(error_table_$inconsistent, "volumes and ^[-vs ^]^[-first^;-last ^]", vs_sw, most_recent); specified_states(free_state) = free_sw; specified_states(allocated_state) = alloc_sw; specified_states(reserved_state) = reserve_sw; specified_states(pvexp_state) = pvexp_sw; if state_string = truebits then call abort_proc(error_table_$inconsistent, "^[ -free ^]^[-alloc ^]^[-reserve ^]^[-pvexp ^]", specified_states(free_state), specified_states(allocated_state), specified_states(reserved_state), specified_states(pvexp_state)); if index(state_string, "1"b) = 0 then /* set default */ specified_states(free_state) = True; force_sw = True; /* query feature is not used with test key */ if vol_cnt = 0 then vol_cnt = 1; if asterisk_sw then do; tcnt = asterisk_cnt; allocate tvol in (based_area) set (Ptvol); tvol.want_it = False; call get_volumes_specified ("tested", specified_states, Ptvol, tcnt, vs_size, most_recent); end; else if ^(volume_sw) then do; volume_cnt = vol_cnt; allocate volume in (based_area) set (Pvolume); call get_volumes_specified("tested", specified_states, Pvolume, vol_cnt, vs_size, most_recent); end; if volume_sw then do; /* volume names were specified */ call check_for_errors(Pvolume, volume_cnt, vol_cnt, 0, not_reg | sec_vol | check_pvexp); end; if asterisk_sw then do; if ^(volume_sw) then do; vol_cnt = 0; volume_cnt = tcnt; allocate volume in (based_area) set (Pvolume); end; do i = 1 to tcnt; volume(vol_cnt + 1).name = tvol(i).name; volume(vol_cnt + 1).indx = tvol(i).indx; volume(vol_cnt + 1).want_it = tvol(i).want_it; vol_cnt = vol_cnt + 1; end; end; yes, no = False; test_vol_list, test_no_vol_list = ""; list_cnt, list_no_cnt = 0; do i = 1 to vol_cnt; if volume(i).want_it & ^(volume(i).noaction) then do; volx = volume(i).indx; if vpe(volx).secondary_vol then volx = vpe(volx).primary_idx; if specified_states (vpe(volx).state) then do; yes = True; test_vol_list = test_vol_list || " " || rtrim(volume(i).name); list_cnt = list_cnt +1; end; else do; no = True; test_no_vol_list = test_no_vol_list || " " || rtrim(volume(i).name); list_no_cnt = list_no_cnt + 1; end; end; end; if active_fnc then do; if yes & no then ret = "false"; else if yes then ret = "true"; else ret = "false"; /* no */ end; else do; if noaction_msg ^= "" then call msg_proc (0, "^a", noaction_msg); if yes then call msg_proc (-1, "^[^a: ^;^s^]Volume set^[s^]^a ^[are^;is^] ^[free^;^[reserved^;^[allocated^;pv_expired^]^]^].", (noaction_msg = ""), myname, (list_cnt > 1), test_vol_list, (list_cnt > 1), specified_states(free_state), specified_states(reserved_state), specified_states(allocated_state), specified_states(pvexp_state)); if no then call msg_proc (-1, "^[^a: ^;^s^]Volume set^[s^]^a ^[is^;are^] not ^[free^;^[reserved^;^[allocated^;pv_expired^]^]^].", (^yes), myname, (list_no_cnt > 1), test_no_vol_list, (list_no_cnt = 1), specified_states(free_state), specified_states(reserved_state), specified_states(allocated_state), specified_states(pvexp_state)); end; end test_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ time_string_: proc (time) returns (char (20)); dcl time fixed bin (71); dcl time_char char (24) aligned; call date_time_ (time, time_char); return (substr(time_char, 1, 20)); end time_string_; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ unlock_volume_pool: proc; /* unlocks the volume pool */ call set_lock_$unlock (volume_pool.lock, ecode); if ecode ^= 0 then do; if ecode = error_table_$lock_not_locked then ecode = 0; else call abort_proc (ecode, "Error unlocking volume pool ^a.", path (vol_dir, vol_ename)); end; lock = ^(ecode = 0); return; end unlock_volume_pool; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ use_key: proc(); /* Procedure which handles the mvp command use key. */ if narg > 2 then call abort_proc (0, "USAGE: manage_volume_pool use {pathname}."); if narg = 1 then do; vol_dir, vol_ename = ""; call setup_pool_path("0"b); end; else do; call get_arg (2, ap, al, code, alp); call setup_pool_path("1"b); end; if active_fnc then ret = path(vol_dir, vol_ename); end use_key; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ volume_in_pool: proc(vol_name, vol_idx) returns(bit(1)); /* Determines whether the volume specified by vol_name is in the pool, and returns true. vol_name: name of the volume to be looked for. (input) vol_idx: index of the volume found in the pool(output) */ dcl vol_name char(*), (i, vol_idx) fixed bin; if volume_pool.volume_count = 0 then return(False); /* no volumes yet in the pool */ vol_idx = volume_pool.head; do while (vol_idx ^= no_link); if vpe (vol_idx).name = vol_name then return(True); if vpe(vol_idx).vs_count > 1 then do; i = vpe(vol_idx).secondary_idx; do while (i ^= no_link); if vpe (i).name = vol_name then do; vol_idx = i; /* return secondary volume index */ return(True); end; i = vpe(i).secondary_idx; end; end; vol_idx = vpe(vol_idx).next; end; return(False); end volume_in_pool; %page; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ volume_in_volume_set: proc(vol_name, primary_idx, vol_idx) returns(bit(1)); /* determines whether a volume specified by vol_name is in a given volume set. vol_name: name of the volume to be looked for. (input) primary_idx: idx of primary volume of the set to be searched (input) vol_idx: index of the secondary volume found in the pool (output) */ dcl vol_name char(*), (primary_idx, vol_idx) fixed bin; vol_idx = vpe(primary_idx).secondary_idx; do while (vol_idx ^= no_link); if vpe (vol_idx).name = vol_name then return(True); vol_idx = vpe(vol_idx).secondary_idx; end; return(False); end volume_in_volume_set; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ yes_to_query: proc(request_type, msg) returns(bit(1)); /* Initializes the query_info structure and querys the user about continuing a */ /* given request or not. */ dcl (request_type, msg) char(*); dcl EXPLAIN_FORCE_MSG char(163) int static options(constant) init( "A no reply aborts the key request. A yes will perform the request on eligible volume sets and a message printed listing the ones upon which no action was taken."); if msg = "" then call command_query_$yes_no(yes_sw, 0, "mvp", EXPLAIN_FORCE_MSG, "Some volumes requested cannot be ^a. Do you wish to continue?", request_type); else call command_query_$yes_no(yes_sw, 0, "mvp", EXPLAIN_FORCE_MSG, "^a Do you wish to continue?", msg); return (yes_sw); end yes_to_query; %page; %include access_mode_values; end manage_volume_pool;  merge_ascii.pl1 07/12/88 1440.5rew 07/12/88 1435.0 171126 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1988 * * * * 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-07-06,TLNguyen), approve(88-07-06,MCR7925), audit(88-07-08,Parisek), install(88-07-12,MR12.2-1055): Fix bug which prevents printing out an error message when lacking path argument for -output_file (-of) control argument. END HISTORY COMMENTS */ merge_ascii: ma: proc; default (fixed&^precision&^constant) precision (21); /* DEFAULT 4*256K CHARS */ default (constant&real&^decimal) binary; /* Coded by RE Mullen, Fall '75 */ /* Recoded by RE Mullen, Spring '77 */ /* Added code for archive :: convention THVV 1980 */ /* Jay Pattin 11/10/80 made compare_ascii take -output_file */ /* Jay Pattin 6/30/82 added -extend, -truncate to cpa, cleaned up a little */ /* Jay Pattin 11/2/82 prevent -of file from being original in cpa. see TR13883 */ %page; %include merge_ascii_info; %page; dcl merge_ascii_ entry (ptr); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin, ptr, fixed bin (35)); dcl (ioa_$ioa_switch, com_err_, com_err_$suppress_name) entry options (variable); dcl iox_$user_output ptr external; dcl iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)), iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)), iox_$close entry (ptr, fixed bin(35)), iox_$detach_iocb entry (ptr, fixed bin(35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl get_equal_name_$component entry (char (*), char (*), char (*), char (*), char (32), char (32), fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl expand_pathname_$component entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl archive_$get_component entry (ptr, fixed bin (24), char (*), ptr, fixed bin (24), fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl unique_chars_ entry (bit(*)) returns(char(15)); dcl (error_table_$noarg, error_table_$inconsistent, error_table_$segknown, error_table_$zero_length_seg, error_table_$badopt, error_table_$rqover, error_table_$noentry) ext fixed bin (35); dcl cleanup condition; dcl record_quota_overflow condition; dcl (me, operation) char (16) aligned; dcl (addr, baseno, divide, index, null, rtrim, substr, unspec) builtin; dcl (i, j, k) fixed bin; dcl nargs fixed bin; dcl of_arg fixed bin; dcl al fixed bin; dcl ap ptr; dcl attach_desc char (256); dcl arg char (al) based (ap); dcl dn char (168); dcl en char (32); dcl ct char (32); dcl first_name char (32); dcl first_cpt char (32); dcl code fixed bin (35); dcl (edit_bit, have_tc_or_ex, extend, no_header, orig_bit, out_bit) bit (1); dcl (MA, CPA) bit (1) init (""b); dcl (first_is_orig, old_mins_ok, saw_minlines, saw_minchars) bit (1) init (""b); /* CPA compatibility switches */ dcl (iocb_ptr, p) ptr; dcl (bit_count, cpt_bc) fixed bin (24); dcl sx fixed bin; dcl expected char (32); dcl 1 mai aligned like ma_info; dcl ch char (999) based; /* ENDCL */ %page; me = "merge_ascii"; MA = "1"b; call cu_$arg_count (nargs, code); if code ^= 0 | nargs = 0 then do; call com_err_$suppress_name (code, me, "Usage: merge_ascii paths {-control_args}"); return; end; go to common; compare_ascii: cpa: entry; me = "compare_ascii"; CPA = "1"b; call cu_$arg_count (nargs, code); if code ^= 0 | nargs = 0 then do; /* tell usage of cpa */ call com_err_$suppress_name (code, me, "Usage: compare_ascii paths {-control_args}"); return; end; /* for cpa nums are minchars..minlines, if -minchars..minlines not given */ /* for cpa first path is orig unless -orig or -no_orig given somewhere */ of_arg = 0; first_is_orig = "1"b; old_mins_ok, extend = "1"b; have_tc_or_ex = "0"b; do i = 1 to nargs; call cu_$arg_ptr (i, ap, al, code); if arg = "-orig" | arg = "-original" | arg = "-no_orig" | arg = "-no_original" then do; if ^first_is_orig then do; call com_err_ (0, me, "Either -original or -no_original can be specified once."); return; end; first_is_orig = ""b; end; else if arg = "-minlines" | arg = "-minchars" then do; old_mins_ok = ""b; end; end; %page; common: unspec (mai) = ""b; mai.op_ptr = null (); mai.op_dirname, mai.op_ename = ""; do i = 1 to ma_max_texts; mai.textid (i) = substr (MA_TEXT_IDS, i, 1); /* print id's in uppercase */ mai.tptr (i), mai.cp (i) = null (); end; mai.output_iocb_ptr = iox_$user_output; iocb_ptr = null (); on cleanup call ma_cleanup_handler; mai.abort_label = ABORT; mai.minlines = 2; mai.minchars = 25; first_name = ""; no_header = ""b; i = 0; mai.lo = 3; mai.hi = 2; /* seg1 is output, seg2 is orig, segs3+ are updates */ do while (i < nargs); i = i + 1; out_bit, orig_bit, edit_bit = ""b; /* dont know what it is, yet */ call cu_$arg_ptr (i, ap, al, code); if ^CPA then goto COMMON_ARGS; if arg = "-totals" | arg = "-total" | arg = "-tt" then mai.totals_only = "1"b; else if arg = "-no_totals" | arg = "-no_total" | arg = "-ntt" then mai.no_totals = "1"b; else if arg = "-extend" then have_tc_or_ex, extend = "1"b; else if arg = "-truncate" | arg = "-tc" then do; extend = "0"b; have_tc_or_ex = "1"b; end; else if arg = "-header" | arg = "-he" then do; mai.print_heading = "1"b; no_header = "0"b; end; else if arg = "-no_header" | arg = "-nhe" then no_header = "1"b; else if arg = "-no_numbers" | arg = "-no_number" | arg = "-nnb" then mai.no_line_numbers = "1"b; else if arg = "-print_new_lines" | arg = "-pnl" then mai.print_new_lines = "1"b; else if arg = "-no_output_file" | arg = "-nof" then mai.output_iocb_ptr = iox_$user_output; else if arg = "-no_orig" | arg = "-no_original" then; /* if CPA then we've already noticed this arg */ else COMMON_ARGS: if arg = "-minlines" | arg = "-minchars" then do; expected = substr (arg, 2); /* note what we expect */ i = i + 1; call cu_$arg_ptr (i, ap, al, code); if code ^= 0 then do; NOARG: call com_err_ (code, me, "^a", expected); /* tell whats missing */ go to ABORT; end; k = cv_dec_check_ (arg, code); if code ^= 0 then do; BADNUM: call com_err_ (0, me, "Invalid ^a value: ""^a""", expected, arg); go to ABORT; end; if k <= 0 then go to BADNUM; if expected = "minlines" then mai.minlines = k; else mai.minchars = k; end; else if index (arg, "-") = 1 then do; /* -something path */ if MA & (arg = "-old_original" | arg = "-old_orig") then do; mai.convergence_ok = "1"b; go to ORIG; end; else if arg = "-original" | arg = "-orig" then do; ORIG: expected = "original"; if mai.have_orig then go to ONLYONE; mai.have_orig, orig_bit = "1"b; end; else if arg = "-output_file" | arg = "-of" then do; expected = "output"; if mai.have_output then do; ONLYONE: call com_err_ (0, me, "Only one ^a segment can be specified.", expected); go to ABORT; end; of_arg = i + 1; /* prepare to get the path argument for -output_file control argument */ if of_arg > nargs then do; call com_err_ (0, me, "Missing path argument for ^a control argument.", arg); goto ABORT; end; mai.have_output, out_bit = "1"b; end; else if MA & arg = "-edit" then do; expected = "edit"; mai.have_edit, edit_bit = "1"b; end; else do; /* -crap */ BAD_ARG: call com_err_ (error_table_$badopt, me, "^a", arg); go to ABORT; end; i = i + 1; if ^(CPA & out_bit) then do; /* Don't process cpa output path until end. */ call cu_$arg_ptr (i, ap, al, code); if code ^= 0 then go to NOARG; /* should have been path */ call PROCESS_PATH; end; end; else if ^old_mins_ok then call PROCESS_PATH; /* must be vanilla path */ else do; /* a vanilla path or a vanilla number */ k = cv_dec_check_ (arg, code); if code ^= 0 then call PROCESS_PATH; else do; /* a number */ if ^saw_minchars then do; saw_minchars = "1"b; mai.minchars = k; expected = "minchars"; end; else if ^saw_minlines then do; saw_minlines = "1"b; mai.minlines = k; expected = "minlines"; end; else go to BAD_ARG; if k <= 0 then go to BADNUM; end; end; end; /* end arg loop */ %page; /* GLOBAL ARG CHECKS */ if mai.lo ^< mai.hi then do; /* (orig&no_upd) | (no_orig&one_upd) is dumb */ call com_err_ (0, me, "Not enough texts supplied."); go to ABORT; end; if have_tc_or_ex & ^mai.have_output then do; call com_err_ (error_table_$inconsistent, me, "-extend and -truncate may only be used with -output_file."); return; end; if CPA & mai.have_output then do; /* my name is compare_ascii and -output_file (-of) is specified */ out_bit = "1"b; call cu_$arg_ptr (of_arg, ap, al, code); /* get path argument for -output_file (-of) control argument */ if code ^= 0 then do; call com_err_ (code, me); goto ABORT; end; if index (arg, "-") = 1 then do; /* the first character of arg value is a hyphen. */ /* example: cpa path1 path2 -of */ call com_err_ (error_table_$noarg, me, "^/Missing path argument for -output_file (-of) control argument. Found ^a", arg); goto ABORT; end; call PROCESS_PATH; if ^no_header then mai.print_heading = "1"b; if extend then attach_desc = rtrim (attach_desc) || " -extend"; call iox_$attach_name (unique_chars_ ("0"b) || ".cpa", iocb_ptr, attach_desc, null (), code); call iox_$open (iocb_ptr, 2, "0"b, code); if code ^= 0 then do; call com_err_ (code, me, "Attaching ^a.", arg); goto ABORT; end; mai.output_iocb_ptr = iocb_ptr; mai.have_output = "0"b; /* so merge_ascii_ knows this is a compare */ end; if MA & ^mai.have_output then do; code = error_table_$noarg; expected = "output_file"; go to NOARG; end; if mai.print_new_lines & ^mai.have_orig then do; call com_err_ (0, me, "An original must be supplied to use print_new_lines feature"); go to ABORT; end; do i = mai.lo to mai.hi; if mai.have_output then if mai.op_ptr ^= null () then if baseno (mai.op_ptr) = baseno (mai.tptr (i)) then do; /* Output must not be same as input */ dn = mai.op_dirname; en = mai.op_ename; ct = ""; go to SAMESEG; end; do j = i + 1 to mai.hi; /* No two inputs must be same */ if mai.tptr (i) = mai.tptr (j) then do; dn = mai.dirname (j); en = mai.ename (j); ct = mai.component (j); SAMESEG: call com_err_ (0, me, "^a^[>^]^a^[::^a^;^s^] is the same segment as ^a^[>^]^a^[::^a^;^s^]", dn, (dn ^= ">"), en, (ct ^= ""), ct, mai.dirname (i), (mai.dirname (i) ^= ">"), mai.ename (i), (mai.component (i) ^= ""), mai.component (i)); go to ABORT; end; end; end; %page; /* START WORK */ if mai.print_heading then do; do i = mai.lo to mai.hi; if mai.tptr (i) ^= null () then do; call ioa_$ioa_switch (mai.output_iocb_ptr, "^a ^a^[>^]^a^[::^a^;^s^] (^[original^;new^])", mai.textid (i), mai.dirname (i), (mai.dirname (i) ^= ">"), mai.ename (i), (mai.component (i) ^= ""), mai.component (i), (i = 2)); end; end; end; call merge_ascii_ (addr (mai)); /* if merge then copy to target segment */ if mai.have_output then do; /* now must move output to target */ if mai.op_ptr = null () then do; /* output seg not exist yet */ call hcs_$make_seg ((mai.op_dirname), (mai.op_ename), "", 01011b, mai.op_ptr, code); if mai.op_ptr = null then goto OP_ERR; /* can't create it! */ end; else do; /* output seg already exists */ call hcs_$truncate_seg (mai.op_ptr, 0, code); /* check access & save paging */ if code ^= 0 then go to OP_ERR; /* access bad, vanished? */ end; on record_quota_overflow begin; /* now target exists, prepare to copy */ code = error_table_$rqover; go to OP_ERR; end; substr (mai.op_ptr -> ch, 1, mai.tchars (1)) = substr (mai.tptr (1) -> ch, 1, mai.tchars (1)); call hcs_$set_bc_seg (mai.op_ptr, 9*mai.tchars (1), code); /* finally done */ if code ^= 0 then do; /* unlikely .. */ OP_ERR: call hcs_$set_bc_seg (mai.tptr (1), 9*mai.tchars (1), 0); /* come here if trouble with output seg */ call com_err_ (code, me, "^a^[>^]^a", mai.op_dirname, (mai.op_dirname ^= ">"), mai.op_ename); call com_err_ (0, me, "Merged output is in ^a>^a", mai.dirname (1), mai.ename (1)); end; else do; /* successful copy, delete temp */ call hcs_$delentry_seg (mai.tptr (1), code); if code ^= 0 then call com_err_ (code, me, "Could not delete ^a>^a", mai.dirname (1), mai.ename (1)); end; end; /* make soothing noise */ if ^mai.no_totals then do; if CPA then operation = "Comparison"; else operation = "Merge"; if CPA & mai.total_differences = 0 then call ioa_$ioa_switch (mai.output_iocb_ptr, "Segments are identical."); else call ioa_$ioa_switch (mai.output_iocb_ptr, "^a finished: ^d difference^[s^], ^d line^[s^].", operation, mai.total_differences, (mai.total_differences ^= 1), mai.total_lines_differing, (mai.total_lines_differing ^= 1)); end; call ma_cleanup_handler; /* clean up address space etc */ return; ABORT: /* come here for failure exit */ if mai.tptr (1) ^= null () then call hcs_$delentry_seg (mai.tptr (1), code); call ma_cleanup_handler; /* failure leave address space clean */ return; /* ------------------------------------------------------------ */ ma_cleanup_handler: proc; /* IP to cleanup */ do i = 2 to ma_max_texts; if mai.tptr (i) ^= null () then call hcs_$terminate_noname (mai.tptr (i), code); end; if mai.op_ptr ^= null () then call hcs_$terminate_noname (mai.op_ptr, 0); if iocb_ptr ^= null () then do; call iox_$close (iocb_ptr, code); call iox_$detach_iocb (iocb_ptr, code); end; end ma_cleanup_handler; %page; PROCESS_PATH: proc; /* IP to deal with pathname, switches already set */ dcl cpt_ptr ptr; dcl cpt char (32); dcl (sname, scpt) char (32); /* results of equal processing */ cpt = ""; /* can't have output in archive */ if out_bit then call expand_pathname_ (arg, dn, en, code); else call expand_pathname_$component (arg, dn, en, cpt, code); if code ^= 0 then do; ARG_ERR: call com_err_ (code, me, "^a", arg); go to ABORT; end; if first_name = "" then do; first_name = en; /* first_name is template for equal conv */ first_cpt = cpt; if first_is_orig then do; /* if f_i_o then first path is orig */ mai.have_orig, orig_bit = "1"b; /* so simulate preceding "-orig" arg */ expected = "original"; end; end; else do; /* all but first ename get equal conv */ call get_equal_name_$component (first_name, first_cpt, en, cpt, sname, scpt, code); if code ^= 0 then do; call com_err_ (code, me, "^a^[::^a^;^s^] ^a^[::^a^;^s^]", first_name, (first_cpt ^= ""), first_cpt, en, (cpt ^= ""), cpt); go to ABORT; end; en = sname; /* replace by expanded name */ cpt = scpt; end; if out_bit then do; if CPA then do; attach_desc = "vfile_ " || rtrim (dn) || ">" || en; return; end; else do /* attempt to initiate real output segment now */ /* if it does not exist we will create it later */ /* if is does exist we will compare the pointer to input segments */ mai.op_dirname = dn; mai.op_ename = en; call hcs_$initiate_count ((mai.op_dirname), (mai.op_ename), "", 0, 0, mai.op_ptr, code); if code ^= 0 then if code ^= error_table_$noentry then if code ^= error_table_$segknown then do; call com_err_ (code, me, "^a^[>^]^a", dn, (dn ^= ">"), en); go to ABORT; end; sx = 1; /* also create temporary seg for output */ dn = "[pd]"; en = "ma_temp." || rtrim (mai.op_ename); call hcs_$make_seg ("", en, "", 01011b, p, code); if p = null () then do; PATH_ERR: call com_err_ (code, me, "^a^[>^]^a", dn, (dn ^= ">"), en); go to ABORT; end; mai.tptr (1) = p; end; end; /* out_bit processing done */ else do; /* name of input seg */ if orig_bit then sx, mai.lo = 2; /* note seg_index for later */ else do; /* some updated version */ mai.hi = mai.hi + 1; if mai.hi > ma_max_texts then do; call com_err_ (0, me, "Only six versions and one original can be merged or compared."); go to ABORT; end; sx = mai.hi; end; p = null (); call hcs_$initiate_count (dn, en, "", bit_count, 0, p, code); if p = null () then go to PATH_ERR; mai.tptr (sx) = p; /* set ptr now */ if bit_count = 0 then do; code = error_table_$zero_length_seg; go to PATH_ERR; end; mai.tchars (sx) = divide (bit_count+8, 9, 17, 0); if edit_bit then mai.edit (sx) = "1"b; mai.len (sx) = mai.tchars (sx); if cpt ^= "" then do; /* read archive? */ call archive_$get_component (p, bit_count, cpt, cpt_ptr, cpt_bc, code); if code ^= 0 then do; call com_err_ (code, me, "^a^[>^]^a::^a", dn, (dn ^= ">"), en, cpt); go to ABORT; end; p, mai.tptr (sx) = cpt_ptr; /* set ptr to archive element */ mai.tchars (sx), mai.len (sx) = divide (cpt_bc+8, 9, 17, 0); end; end; mai.cp (sx) = mai.tptr (sx); /* fill in info structure */ mai.line (sx) = 1; mai.dirname (sx) = dn; mai.ename (sx) = en; mai.component (sx) = cpt; end PROCESS_PATH; end merge_ascii;  merge_ascii_.pl1 11/04/82 1951.6rew 11/04/82 1627.6 59526 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ merge_ascii_: proc (a_maip); default (fixed&^precision&^constant) precision (21); /* DEFAULT */ default (constant&real&^decimal) binary; /* Subroutine implementing top level of merge/compare subsystem. */ /* It is called with a pointer to a main control structure. */ /* It may pass that pointer to procs it calls */ /* This subroutine is not externally available. The interface can change. */ /* Re-coded Spring '77 RE Mullen */ dcl a_maip ptr; /* parameter */ dcl ch char (999) based; dcl skipchars (0:1) char (1) unal based; dcl (i, j, k) fixed bin; dcl code fixed bin (35); dcl NL char (1) init (" "); dcl (ioa_, ioa_$nnl) entry options (variable); dcl (iox_$user_input, iox_$user_output) ptr ext; dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl (ma_resynch_, ma_analyze_) entry (ptr); dcl (addr, index, substr) builtin; /* */ %include merge_ascii_info; /* */ ma_info_ptr = a_maip; /* pointer at least to automatic */ call find_same_at_start; /* skip over matching chars at start */ if have_output then call take_same; /* pick up any found */ call skip_same; /* skip over those chars */ do while (^ma_info.eof); call ma_resynch_ (ma_info_ptr); /* sets synchlen, difflen(*), eof, etc */ total_differences = total_differences + 1; /* keep change counters */ do i = lo to hi; total_lines_differing = total_lines_differing + difflines (i); end; if ^totals_only | have_output then call ma_analyze_ (ma_info_ptr); /* print diff, auto-take, call editor */ call skip_diff; /* advance past difflen(*) chars */ if have_output then call take_same; /* pick up synchlen chars */ call skip_same; /* advance past synchlen chars */ end; return; /* all done */ /* */ find_same_at_start: proc; /* IP to skip over matching lines */ dcl (ssj, ssk) fixed bin; dcl lo_cp ptr; dcl lo_len fixed bin; dcl same_len bit (1); /* The objective of the following code is to determine the number of matching lines. In order to avoid indexing into all segments, we index for newlines only in the lowest segment and then compare those characters, including the newline (if any), with the corresponding characters in the other segments. If all compares come out equal, we have found one more matching line. For this scheme to work we must not reference past the end of any segment, so we compute the min of all lengths. If in text(lo) we ever fail to find a newline then the end of text(lo) cannot match the other texts unless they are all of the same length */ synchlen = 0; /* skipped no chars yet */ synchlines = 0; /* skipped no lines yet */ lo_cp = cp (lo); lo_len = len (lo); /* Set lo_len to the minimum remaining length in any text */ same_len = "1"b; do ssk = lo + 1 to hi; if len (ssk) < lo_len then do; /* found unequal and shorter text */ lo_len = len (ssk); /* note new, lower min len */ same_len = ""b; /* note all lengths not the same */ end; end; /* Step through text(lo) line by line. Compare each line to text in other texts. Whenever any other text differs we have found what is the same */ ss_loop: ssj = index (substr (lo_cp -> ch, synchlen + 1, lo_len - synchlen), NL); /* get current line length */ if ssj = 0 then do; /* no new line found */ if same_len then ssj = lo_len - synchlen; /* else get matching partial lines, not at EOF .. */ if ssj = 0 then go to ss_done; end; do ssk = lo + 1 to hi; /* see if lines all match */ if substr (lo_cp -> ch, synchlen + 1, ssj) ^= substr (cp (ssk) -> ch, synchlen + 1, ssj) then go to ss_done; end; synchlen = synchlen + ssj; /* count more chars */ synchlines = synchlines + 1; /* count this line */ go to ss_loop; /* try for another */ ss_done: /* here when cant match one more line */ end find_same_at_start; /* */ skip_diff: proc; /* IP to skip over (processed) differences */ dcl sdi fixed bin; do sdi = lo to hi; /* for each input seg */ cp (sdi) = addr (cp (sdi) -> skipchars (difflen (sdi))); /* advance ptr */ line (sdi) = line (sdi) + difflines (sdi); /* advance linno */ len (sdi) = len (sdi) - difflen (sdi); /* decrease remaining len */ end; end skip_diff; skip_same: proc; /* IP to skip over synched block */ dcl ssx fixed bin; eof = "1"b; /* assume we are not at eof */ do ssx = lo to hi; /* for each input seg */ len (ssx) = len (ssx) - synchlen; /* decrement remaining length */ if len (ssx) > 0 then eof = ""b; /* note if at eof */ line (ssx) = line (ssx) + synchlines ; /* increment linno */ cp (ssx) = addr (cp (ssx) -> skipchars (synchlen)); /* advance pointer */ end; end skip_same; take_same: proc; /* IP to pick up unchanged text */ substr (cp (1) -> ch, 1, synchlen) /* copy text */ = substr (cp (lo) -> ch, 1, synchlen); /* grab chars */ tlines (1) = tlines (1) + synchlines; /* increment output linno */ tchars (1) = tchars (1) + synchlen; /* increment output charcount */ cp (1) = addr (cp (1) -> skipchars (synchlen)); /* bump pointer */ end take_same; /* */ /* print_diff: proc; /* temporary IP to print diffs, fo debugging */ /* /*dcl (pdi, pdj, pdk) fixed bin; /* /* do pdi = lo to hi; /* call iox_$put_chars (iox_$user_output, cp (pdi), difflen (pdi), code); /* end; /* /* end print_diff; /*dump: proc; /* IP to dump key vars */ /* dcl di fixed bin; /* call ioa_ ("^/ sx tptp tch tlines cp len line dlen dlin same"); /* do di = lo to hi; /* /* call ioa_ ("^4d: ^p ^4d ^4d ^p ^4d ^4d ^4d ^4d ^4d", /* di, tptr (di), tchars (di), tlines (di), /* cp (di), len (di), line (di), /* difflen (di), difflines (di), /* same_as (di)); /* end; /* /* end dump; */ end merge_ascii_;  overlay.pl1 02/02/88 1716.5r w 02/02/88 1540.0 98478 /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ overlay: ov: proc; /* OVERLAY - overlay multiple segments. THVV */ /* Usage message with no args; reject bad control args 08/14/80 S. Herbst */ /* Change -in to -ind, add clean_up handler, rename variables 02/18/82 L. Baldwin */ /* Change to allow the archive convention. 07/08/84 R. Roach */ %include prt_conv_info; %include access_mode_values; dcl BEAD_COUNT fixed bin; dcl NL char (1) int static options (constant) init (" "), NLVTFF char (3) int static options (constant) init (" "), SP char (1) int static options (constant) init (" "), BS char (1) int static options (constant) init (""), VT char (1) int static options (constant) init (" "), FF char (1) int static options (constant) init (" "); dcl obuf char (BEAD_COUNT+1) based (obuf_ptr) aligned; dcl system_area area (1024) based (area_ptr); dcl 1 bead (BEAD_COUNT) based (bead_ptr) aligned, 2 loc fixed bin (26) unal, 2 char char (1) unal; dcl seg char (curr_seg_len) based (curr_seg_ptr) aligned; dcl arg char (arg_len) based (arg_ptr) unaligned; dcl slew char (1); dcl cpt char (32); dcl en char (32); dcl dn char (168); dcl obuf_storage char (513); dcl output char (4096); dcl eof (10) bit (1); dcl (area_ptr, arg_ptr, bead_ptr, obuf_ptr, curr_ptr, curr_seg_ptr) ptr; dcl info_ptr (10) ptr; dcl seg_ptr (10) ptr init ((10) null); dcl (temp_ptr, temp1_ptr) ptr init (null); dcl (arg_count, arg_no, arg_len) fixed bin; dcl (i, ii, j, k, m, n) fixed bin; dcl nchars fixed bin; dcl (next_line, curr_line) fixed bin; dcl neof fixed bin; dcl file_count fixed bin; dcl col_no fixed bin; dcl nxline (10) fixed bin init ((10)0); dcl ocount fixed bin; dcl offset (10) fixed bin; dcl page_len fixed bin init (60); dcl storage (512) fixed bin; dcl io fixed bin (21); dcl curr_seg_len fixed bin (21); dcl seg_len (10) fixed bin (21); dcl line_no (10) fixed bin (21); dcl bit_count fixed bin (24); dcl code fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl iox_$user_output ptr ext; dcl print_conv_$print_conv_ ext; dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl expand_pathname_$component entry (char(*), char(*), char(*), char(*), fixed bin(35)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl initiate_file_$component entry (char(*), char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); dcl prt_conv_ entry (ptr, fixed bin, ptr, fixed bin, ptr); dcl (addr, divide, hbound, length, min, mod, null, search, string, substr, unspec) builtin; dcl cleanup condition; /* ======================================================= */ area_ptr = get_system_free_area_ (); file_count = 0; BEAD_COUNT = hbound (storage, 1); /* set the initial values */ bead_ptr = addr (storage); obuf_ptr = addr (obuf_storage); call cu_$arg_count (arg_count, code); if code ^= 0 then do; call com_err_ (code, "overlay"); return; end; if arg_count = 0 then do; call com_err_$suppress_name (0, "overlay", "Usage: overlay paths {-control_args}"); return; end; do arg_no = 1 to arg_count; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if arg = "-page_length" | arg = "-pl" then do; arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if code ^= 0 then do; ERROR: call com_err_ (code, "overlay", "^a", arg); return; end; page_len = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, "overlay", "Invalid integer argument ^a for -page_length", arg); return; end; end; else if arg = "-indent" | arg = "-ind" | arg = "-in" then do; arg_no = arg_no + 1; call cu_$arg_ptr (arg_no, arg_ptr, arg_len, code); if code ^= 0 then go to ERROR; offset (file_count) = cv_dec_check_ (arg, code); if code ^= 0 then do; call com_err_ (0, "overlay", "Invalid integer argument ^a for -indent", arg); return; end; end; else if substr (arg, 1, 1) = "-" then do; code = error_table_$badopt; go to ERROR; end; else do; file_count = file_count + 1; if file_count > hbound (seg_ptr, 1) then do; call com_err_ (0, "overlay", "Number of files exceeds implementation maximum of ^d", hbound (seg_ptr, 1)); return; end; call expand_pathname_$component (arg, dn, en, cpt, code); if code ^= 0 then go to ERROR; allocate pci set (info_ptr (file_count)) in (system_area); call init_pci (info_ptr (file_count)); offset (file_count) = 0; line_no (file_count) = 1; seg_ptr (file_count) = null; call initiate_file_$component (dn, en, cpt, R_ACCESS, seg_ptr (file_count), bit_count, code); if code ^= 0 then go to ERROR; seg_len (file_count) = divide (bit_count, 9, 17, 0); end; end; if file_count = 0 then do; call com_err_$suppress_name (0, "overlay", "Usage: overlay paths {-control_args}"); return; end; on cleanup call clean_up; do i = 1 to file_count; info_ptr (i) -> pci.page_length = page_len; info_ptr (i) -> pci.phys_page_length = page_len; info_ptr (i) -> pci.overflow_off = "0"b; end; neof = 0; /* Initialize counters */ curr_line = 1; eof (*) = "0"b; do while (neof < file_count); /* Stop when end of all input */ nchars = 0; /* number of chars in this line */ next_line = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0); do i = 1 to file_count; /* Take input from all segs */ if eof (i) then go to SKIP; if curr_line < nxline (i) then go to SKIP; curr_seg_len = seg_len (i); /* Get input seg length */ curr_seg_ptr = seg_ptr (i); /* .. ptr */ curr_ptr = addr (substr (seg, line_no (i), 1)); /* .. ptr to current loc */ n = search (substr (seg, line_no (i)), NLVTFF); /* .. loc of end of input line */ if n = 0 then n = seg_len (i) - line_no (i); line_no (i) = line_no (i) + n; if line_no (i) >= seg_len (i) then do; eof (i) = "1"b; /* ignore this seg from now on */ neof = neof + 1; end; do while (n > 0); /* Normalize line */ call prt_conv_ (curr_ptr, n, addr (obuf), ocount, info_ptr (i)); do j = 1 to ocount-1; if substr (obuf, j, 1) ^= " " then do; nchars = nchars + 1; /* Save each character */ if nchars > BEAD_COUNT then call MORE_ROOM; bead (nchars).char = substr (obuf, j, 1); bead (nchars).loc = j + offset (i); end; end; end; slew = substr (obuf, ocount, 1); /* Deal with slew */ if slew = FF then do; nxline (i) = 1 + page_len * divide (curr_line+page_len-1, page_len, 17, 0); end; else if slew = VT then do; nxline (i) = 1 + 10 * divide (curr_line+9, 10, 17, 0); end; else if slew = NL then do; /* Can reach vertical tabstop via NL's */ nxline (i) = curr_line+1; end; next_line = min (next_line, nxline (i)); SKIP: end; /* End loop on input files. one line assembled */ call sort; /* Order chars on line */ io = 0; /* output counter */ col_no = 1; /* column */ do k = 1 to nchars; /* put out all chars */ m = bead (k).loc - col_no; /* compute white space */ if m > 0 then do ii = 1 to m; /* if going right */ io = io + 1; substr (output, io, 1) = SP; end; if m < 0 then do; /* if going left (should be only one) */ io = io + 1; substr (output, io, 1) = BS; end; io = io + 1; /* Now put out char */ substr (output, io, 1) = bead (k).char; col_no = bead (k).loc + 1; /* remember last used column */ end; io = io + 1; /* output slew char */ if next_line = curr_line+1 then substr (output, io, 1) = NL; else if mod (next_line-1, page_len) = 0 then substr (output, io, 1) = FF; else substr (output, io, 1) = VT; call iox_$put_chars (iox_$user_output, addr (output), io, (0)); curr_line = next_line; end; call clean_up; return; /* ------------------------------------------------------- */ sort: proc; dcl temp fixed bin; dcl swaps fixed bin; dcl d fixed bin; dcl i fixed bin; dcl vec (BEAD_COUNT) fixed bin based (bead_ptr); d = nchars; PASS: swaps = 0; d = divide (d + 1, 2, 17, 0); do i = 1 to nchars - d; if vec (i) > vec (i+d) then do; swaps = swaps + 1; temp = vec (i); vec (i) = vec (i+d); vec (i+d) = temp; end; end; if d > 1 then go to PASS; if swaps > 0 then go to PASS; end sort; init_pci: proc (p); dcl p ptr; unspec (p -> pci) = "0"b; /* clear everything */ p -> pci.cv_proc = addr (print_conv_$print_conv_); p -> pci.level = 0; p -> pci.pos = 0; p -> pci.lmarg = 0; p -> pci.rmarg = length (obuf) - 1; p -> pci.phys_line_length = length (obuf) - 1; p -> pci.page_length = 60; p -> pci.phys_page_length = 66; p -> pci.lpi = 6; p -> pci.sheets_per_page = 1; p -> pci.line_count = 0; p -> pci.page_count = 0; string (p -> pci.modes) = ""b; p -> pci.top_label_line = ""; p -> pci.bot_label_line = ""; p -> pci.top_label_length = 0; p -> pci.bot_label_length = 0; p -> pci.line = 1; p -> pci.slew_residue = 0; p -> pci.label_nelem = 0; p -> pci.sav_pos = 0; p -> pci.func = 0; p -> pci.temp = "0"b; p -> pci.overflow_off = "1"b; end init_pci; MORE_ROOM: proc; dcl k fixed bin; k = BEAD_COUNT; BEAD_COUNT = 2*BEAD_COUNT; allocate bead set (temp_ptr) in (system_area); allocate obuf set (temp1_ptr) in (system_area); BEAD_COUNT = k; temp_ptr -> bead = bead; temp1_ptr -> obuf = obuf; if bead_ptr ^= addr (storage) then free bead; if obuf_ptr ^= addr (obuf_storage) then free obuf; BEAD_COUNT = 2*BEAD_COUNT; bead_ptr = temp_ptr; obuf_ptr = temp1_ptr; end MORE_ROOM; clean_up: proc; do i = 1 to file_count; if seg_ptr (i) ^= null then call hcs_$terminate_noname (seg_ptr (i), code); free info_ptr (i) -> pci; end; if temp_ptr ^= null then free bead; if temp1_ptr ^= null then free obuf; end clean_up; end overlay;  print_conv_.alm 02/02/88 1716.5r w 02/02/88 1538.1 27522 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " *********************************************************** " PRINT_CONV_ - Conversion for for producing canonical output " coded 11/4/74 by Noel I. Morris " borrowed by thvv " ****************************************************** " * * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " * * " ****************************************************** include prt_conv_info name print_conv_ segdef print_conv_ tempd pointer temp char,line,tabstop,residue print_conv_: tra print_send_init tra print_send_chars tra print_send_slew_pattern tra print_send_slew_count " " Entry called at beginning of conversion print_send_init: ldq lb|pci.line get current line sbq 1,dl .. cause tabs are at 11 ... stq line div 10,dl compute starting tabstop stq tabstop sta residue tra sb|0 return " print_send_chars: eax2 0,2 set indicators from X2 tmoz nospace if no white space, skip following mlr (),(pr,rl),fill(040) insert blanks into output desc9a *,0 .. desc9a bb|0,x2 .. a9bd bb|0,2 step output pointer over blanks eax2 0 set white space count back to zero nospace: mlr (pr,rl),(pr,rl) copy characters into output desc9a bp|0,au .. desc9a bb|0,au .. a9bd bp|0,au step input and output pointers a9bd bb|0,au .. tra sb|0 return to caller " print_send_slew_pattern: eax7 0 initialize for search rpt nslew/2,2,tze search for slew characters cmpa slew,7 .. lda -1,7 sta char stslew: mlr (pr),(pr) desc9a char,1 desc9a bb|0,1 ldq 1,dl a9bd bb|0,ql tra sb|0 return to caller slew: vfd 27/,o9/0 FF vfd o9/014 vfd 27/,o9/013 top of inside page vfd o9/014 treat as ff vfd 27/,o9/011 top of outside page vfd o9/014 equ nslew,*-slew nlchar: vfd o9/012 crchar: vfd o9/015 vtstring: vfd o9/013,o9/013,o9/013,o9/013 vfd o9/013,o9/013,o9/013,o9/013 vfd o9/013,o9/013,o9/013,o9/013 vfd o9/013,o9/013,o9/013,o9/013 " print_send_slew_count: spribp pointer see if faked slew char is beyond end of seg ldq pointer+1 qrl 18 cmpq =o776000 tze no_vt if so, skip test for VT char cmpc (pr),() see if slew was VT desc9a bp|0,1 desc9a vtstring,1 tnz no_vt ada line VT, compute new ending line lrs 36 div 10,dl convert to stop sba residue a has spaces over sbq tabstop q has vt count tze no_vt mlr (rl),(pr,rl) undo work of prt_conv_ desc9a vtstring,ql .. by putting out VT desc9a bb|0,ql a9bd bb|0,ql step output ptr tra sb|0 no_vt: ldq crchar sba 1,dl one at a time tmi 2,ic ldq nlchar stq char tra stslew end  print_error_message.pl1 11/21/84 0948.9rew 11/21/84 0944.4 33876 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ print_error_message: pem: proc; /* Modified 84-05-28 by SGH (UNCA) for active function. */ /* Modified 840724 by Charlie Spitzer. fix for MCR changes. */ /* Automatic */ dcl active_fnc bit(1); dcl af_return_arg_len fixed bin(21); dcl af_return_arg_ptr ptr; dcl code fixed bin (35); dcl error_code fixed bin (35); dcl esw fixed bin; dcl long char (100) aligned; dcl n_args fixed bin; dcl short char (8) aligned; dcl tc fixed bin; dcl tp ptr; /* Based */ dcl af_return_arg char (af_return_arg_len) varying based (af_return_arg_ptr); dcl targ char (tc) based (tp); /* Builtins */ dcl rtrim builtin; /* Static */ dcl ME char (32) int static options (constant) init ("print_error_message"); /* External */ dcl error_table_$bad_arg ext fixed bin (35); dcl error_table_$not_act_fnc ext fixed bin (35); /* Procedures */ dcl active_fnc_err_ entry options (variable); dcl argument_routine entry variable options (variable); dcl com_err_ entry options (variable); dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned); dcl cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)); dcl cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl error_routine entry variable options (variable); dcl ioa_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl requote_string_ entry (char(*)) returns(char(*)); esw = 1; /* indicates decimal short form */ go to common; peo: entry; esw = 3; /* indicates octal short form */ go to common; pel: entry; esw = 2; /* indicates decimal long form */ go to common; peol: entry; esw = 4; /* indicates octal long form */ common: call cu_$af_return_arg (n_args, af_return_arg_ptr, af_return_arg_len, code); if code = error_table_$not_act_fnc then do; active_fnc = "0"b; argument_routine = cu_$arg_ptr; error_routine = com_err_; end; else do; active_fnc = "1"b; argument_routine = cu_$af_arg_ptr; error_routine = active_fnc_err_; end; call argument_routine (1, tp, tc, code); if code ^= 0 | tc = 0 then do; call error_routine (code, ME); return; end; if esw < 3 then error_code = cv_dec_check_ (targ, code); else error_code = cv_oct_check_ (targ, code); /* get correct code value */ if code ^= 0 then do; call error_routine (error_table_$bad_arg, ME, "^a", targ); return; end; call convert_status_code_ (error_code, short, long); if active_fnc then if esw = 1 | esw = 3 then call ioa_$rsnnl ("^a", af_return_arg, af_return_arg_len, requote_string_ (rtrim (short))); else call ioa_$rsnnl ("^a", af_return_arg, af_return_arg_len, requote_string_ (rtrim (long))); else do; if esw = 1 then call ioa_ ("^d = ^a", error_code, short); else if esw = 2 then call ioa_ ("^d = ^a", error_code, long); else if esw = 3 then call ioa_ ("^o = ^a", error_code, short); else call ioa_ ("^o = ^a", error_code, long); end; end print_error_message;  rje_args.pl1 11/04/82 1951.6rew 11/04/82 1627.7 58824 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ rje_args: proc; /* This is the initial version of an active function to return some information about the submission of an RJE card input job. It will eventually be fashoned after the user active function. This version is modeled after the value command to set certain values which are then returned by giving the correct key to the active function. Only the active function entry is to be documented. The setting entry is internal interfaces and will go away when the source data can be put into the PIT. */ /* Initial version taken from the value active function by J. C. Whitmore, Aug. 1977 */ dcl en char (32) aligned int static, dn char (168) aligned int static, segptr ptr int static init (null), ap ptr, al fixed bin, bchr char (al) unal based (ap), answer char (168) varying, bvcs char (al) varying based (ap), ec fixed bin, i fixed bin, af_sw bit (1) init ("0"b), string char (168) aligned; dcl (null, substr, addr, length, rtrim) builtin; dcl com_err_ entry options (variable), adjust_bit_count_ entry (char (*) aligned, char (*) aligned, bit (1), fixed bin (24), fixed bin (17)), get_pdir_ entry () returns (char (168) aligned), active_fnc_err_ entry options (variable), cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), cu_$arg_count entry (fixed bin), cu_$af_arg_count entry (fixed bin, fixed bin), cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin), error_table_$wrong_no_of_args fixed bin ext, error_table_$bad_arg fixed bin ext, error_table_$not_act_fnc fixed bin ext, hcs_$make_seg entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (5), ptr, fixed bin), unique_chars_ entry (bit (*)) returns (char (15)), ioa_ entry options (variable); dcl 1 valueseg based (segptr) aligned, 2 laste fixed bin, 2 freep fixed bin, 2 pad (6) fixed bin, 2 arry (1000), 3 name char (32), 3 valu char (168), 3 lth fixed bin, 3 chain fixed bin; /* ========================================= */ af_sw = "1"b; /* this should be an active function */ call cu_$af_arg_count (i, ec); if ec = error_table_$not_act_fnc then af_sw = "0"b; else if ec ^= 0 then go to er; if ^af_sw then call cu_$arg_count (i); /* not an active function so get valid count */ if i ^= 1 then do; ec = error_table_$wrong_no_of_args; go to er; end; if segptr = null then do; call get_segptr (ec); if segptr = null then do; er: if af_sw then call active_fnc_err_ (ec, "rje_args"); else call com_err_ (ec, "rje_args"); return; end; end; if af_sw then call cu_$af_arg_ptr (1, ap, al, ec); else call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er; /* check to see if the key given is legal */ if bchr = "prt_rqt" then; /* the printer request type */ else if bchr = "pun_rqt" then; /* the punch request type */ else if bchr = "station" then; /* the station code of the job */ else do; /* all others are invalid! */ ec = error_table_$bad_arg; go to er; end; do i = 1 to laste; if chain (i) = 0 then if name (i) ^= "" then if bchr = name (i) then go to found; end; answer = "undefined!"; go to give; found: answer = substr (valu (i), 1, lth (i)); if answer = "" then answer = "undefined!"; /* always return something */ give: if af_sw then do; call cu_$af_return_arg (i, ap, al, ec); if ec ^= 0 then if ec ^= error_table_$not_act_fnc then go to er; bvcs = answer; return; end; call ioa_ (answer); return; /* ---------------------------------- */ set: entry; if segptr = null then do; call get_segptr (ec); if segptr = null then go to er; end; call cu_$arg_ptr (1, ap, al, ec); if ec ^= 0 then go to er; if bchr = "prt_rqt" then; /* ok to set the printer request type */ else if bchr = "pun_rqt" then; /* ok to set the punch request type */ else if bchr = "station" then; /* ok to set the station code */ else do; /* all other keys are invalid! */ ec = error_table_$bad_arg; go to er; end; string = bchr; call cu_$arg_ptr (2, ap, al, ec); if ec ^= 0 then do; do i = 1 to laste; if string = name (i) then do; chain (i) = freep; freep = i; name (i) = ""; end; end; return; end; do i = 1 to laste; if chain (i) = 0 then if name (i) ^= "" then if name (i) = string then do; go to f1; end; end; if freep = 0 then i, laste = laste + 1; else do; i = freep; freep = chain (i); end; name (i) = string; f1: valu (i) = bchr; chain (i) = 0; lth (i) = al; call adjust_bit_count_ (dn, en, "0"b, (0), ec); return; /* ------------------------------------------ */ list: entry; if segptr = null then do; call get_segptr (ec); if segptr = null then go to er; end; call cu_$arg_ptr (1, ap, al, ec); do i = 1 to laste; if name (i) = "" then go to nop; if chain (i) = 0 then do; if ec = 0 then if name (i) ^= bchr then go to nop; call ioa_ ("^20a^-^a", name (i), substr (valu (i), 1, lth (i))); end; nop: end; call ioa_ (""); return; /* ------------------------------------ */ get_segptr: proc (code); dcl code fixed bin; dn = get_pdir_ (); en = "rje_args." || unique_chars_ ((70)"0"b); /* make a unique name */ call hcs_$make_seg (dn, en, "", 1011b, segptr, code); if code = 0 then do; /* initialize the values to the defaults */ laste = 3; /* 3 entries */ name (1) = "prt_rqt"; valu (1) = "printer"; lth (1) = length (rtrim (valu (1))); name (2) = "pun_rqt"; valu (2) = "punch"; lth (2) = length (rtrim (valu (2))); name (3) = "station"; valu (3) = "central_site"; lth (3) = length (rtrim (valu (3))); end; return; end get_segptr; end rje_args;  set_epilogue_command.pl1 11/04/82 1951.6rew 11/04/82 1627.5 11484 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ set_epilogue_command: sec: proc; dcl command char (256) int static init (""); dcl code fixed bin (35); dcl argp ptr; dcl arglen fixed bin; dcl arg char (arglen) based (argp); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl com_err_ entry options (variable); dcl default_error_handler_$add_finish_handler entry (entry, fixed bin (35)); dcl cu_$cp entry (ptr, fixed bin, fixed bin (35)); code = 0; call cu_$arg_ptr (1, argp, arglen, code); if code ^= 0 then goto ret; command = arg; call default_error_handler_$add_finish_handler (do, code); ret: if code ^= 0 then call com_err_ (code, "set_epilogue_command"); return; do: entry; call cu_$cp (addr (command), length (command), code); return; end set_epilogue_command;  suffixed_name_.pl1 11/04/82 1951.6rew 11/04/82 1627.7 98820 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* N__a_m_e: suffixed_name_ */ /* */ /* This subroutine handles suffixed names. */ /* */ /* E__n_t_r_y: suffixed_name_$find */ /* */ /* This entry point attempts to find an entry which is supposed to (but may not) */ /* have a suffixed name. The entry may be a directory, a segment, or a multi-segment */ /* file. */ /* */ /* U__s_a_g_e */ /* */ /* dcl suffixed_name_$find entry (char(*), char(*), char(*), char(32) aligned, */ /* fixed bin(2), fixed bin(35)); */ /* */ /* call suffixed_name_$find (directory, entry, suffix, name, type, mode, code); */ /* */ /* 1) directory name of directory in which entry is to be found.(In) */ /* 2) entry entry name supplied by user which may or may not have a suffix.(In) */ /* 3) suffix the suffix which is supposed to be on the entry. It should not */ /* contain a period (".").(In) */ /* 4) name name of the entry which was found.(Out) */ /* 5) type switch indicating the type of entry which was found.(Out) */ /* 1 = segment; 2 = directory; 3 = multi-segment file. */ /* 6) mode caller's access mode to the entry which was found.(Out) */ /* 7) code an error code.(Out) */ /* */ /* E__n_t_r_y: suffixed_name_$make */ /* */ /* This entry point makes a properly-suffixed name out of a user-supplied name */ /* which may or may not be suffixed. */ /* */ /* U__s_a_g_e */ /* */ /* dcl suffixed_name_$make entry (char(*), char(*), char(*), char(32) aligned, */ /* fixed bin(35)); */ /* */ /* call suffixed_name_$make (entry, suffix, name, code); */ /* */ /* 1) entry is the user-supplied entry name.(In) */ /* 2) suffix is the suffix which is to be appended to the name.(In) */ /* 3) name is the properly-suffixed name.(Out) */ /* 4) code is a status code which indicates whether the properly-suffixed name */ /* will fit into the _p_r_o_p_e_r__n_a_m_e string. (Out) */ /* */ /* E__n_t_r_y: suffixed_name_$new_suffix */ /* */ /* This entry point creates a properly-suffixed name from a (possibly-improperly-) */ /* suffixed name supplied by the user. */ /* */ /* U__s_a_g_e */ /* */ /* dcl suffixed_name_$new_suffix entry(char(*), char(*), char(*), char(32) aligned, */ /* fixed bin(35)); */ /* */ /* call suffixed_name_$new_suffix (name, suffix, new_suffix, new_name, code); */ /* */ /* 1) name is the suffixed name returned by suffixed_name_$find.(In) */ /* 2) suffix is the suffix which is supposed to be on name.(In) */ /* 3) new_suffix is the new suffix which is to be appended to the name to be made.(In) */ /* 4) new_name is the name which was made.(Out) */ /* 5) code is a status code which indicates whether the properly-suffixed new */ /* name will fit into the _n_e_w__n_a_m_e string. (Out) */ /* */ /* N__o_t_e_s */ /* */ /* "code" may be any error code returned by hcs_$status_long, except */ /* error_table_$no_s_permission. "name" will contain a properly-suffixed name, even if */ /* "code" is non-zero. */ /* */ /* S__t_a_t_u_s */ /* */ /* 1) Created: Nov 1972 by Gary C. Dixon */ /* 2) Modified: Jan 1973 by Gary C. Dixon; add mode argument to find entry point. */ /* 3) Modified: Feb 1973 by Gary C. Dixon; add code argument to make/new_suffix entries. */ /* 4) Modified: Dec 1980 by M. Broussard; fixed to work with names containing imbedded */ /* blanks. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ suffixed_name_: procedure; /* procedure to handle suffixed names. */ /* parameters */ dcl directory char(*), /* absolute directory path of segment to be found */ entry char(*), /* entry name to be suffixed. */ suffix char(*), /* suffix character string (not including ".") */ new_suffix char(*), /* new suffix character string (not including ".")*/ name char(32) aligned, /* properly-suffixed name. */ Stype fixed bin(2), /* type of entry which was found. */ mode fixed bin(5), /* caller's access mode to the found dir entry. */ code fixed bin(35); /* an error code. */ /* automatic variables */ dcl Lentry fixed bin, /* length of non-blank part of entry. */ Lname fixed bin, /* length of a part of non-blank part of name. */ Lnew_suffix fixed bin, /* length of non-blank part of new suffix. */ Lsuffix fixed bin, /* length of non-blank part of suffix. */ e fixed bin, /* an entry point indicator. */ 1 stat, /* a file system status block. */ (2 type bit(2), /* entry type; "01"b=seg, "10"b=dir */ 2 pad1 bit(106), 2 mode bit(5), /* caller's access to the entry. */ 2 pad2 bit(151), 2 bitcnt bit(24), /* multi-segment file indicator count. */ 2 pad3 bit(72)) unal; /* entries and builtin functions */ dcl hcs_$status_long entry(char(*), char(*) aligned, fixed bin(1), ptr, ptr, fixed bin(35)), fixed builtin, index builtin, length builtin, null builtin, rtrim builtin, substr builtin; /* static variables */ dcl dir fixed bin(2) int static init (2), error_table_$entlong fixed bin(35) ext static, error_table_$no_s_permission fixed bin(35) ext static, msf fixed bin(2) int static init (3); /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ find: entry (directory, entry, suffix, name, Stype, mode, code); /* find the name of the entry which matches a */ /* suffixed entry name. */ e = 1; go to common; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ make: entry (entry, suffix, name, code); /* make a suffixed name out of a user-supplied */ /* entry name which may or may not be suffixed. */ e = 2; go to common; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ new_suffix: entry (entry, suffix, new_suffix, name, code); /* change the suffix on a (possibly) suffixed */ /* name to a new suffix. */ e = 3; /* * * * * * * * * * * * * * * * * ** * * * * * * * * * * * * * * * * * * */ common: Lentry = length (rtrim (entry)); Lsuffix = length (rtrim (suffix)); /* find lengths of non-blank parts of char strings*/ if Lsuffix = 0 then /* if _s_u_f_f_i_x is null string, then use _e_n_t_r_y as */ go to use_entry; /* the suffixed _n_a_m_e. */ else if Lentry < Lsuffix + 1 then /* if the _s_u_f_f_i_x won't fit in _e_n_t_r_y, then */ go to add_suffix; /* assume its not there. */ else if substr (entry, Lentry-Lsuffix, Lsuffix+1) = "." || substr (suffix, 1, Lsuffix) then /* otherwise, see if _s_u_f_f_i_x is already on _e_n_t_r_y. */ use_entry: if Lentry <= length(name) then do; /* if so, and if _e_n_t_r_y isn't too long, then */ name = substr (entry, 1, Lentry); /* use _e_n_t_r_y as the suffixed _n_a_m_e. */ Lname = Lentry; end; else /* if _e_n_t_r_y won't fit into the _n_a_m_e string, then */ go to long_entry_error; /* that's an error. Tell the caller. */ else if Lentry + Lsuffix + 1 <= length(name) then do; /* make suffixed _n_a_m_e by appending _s_u_f_f_i_x to */ /* _e_n_t_r_y, if that will fit. */ add_suffix: name = substr (entry, 1, Lentry) || "." || substr (suffix, 1, Lsuffix); Lname = Lentry + Lsuffix + 1; end; else /* if all else fails, then report error to user. */ go to long_entry_error; go to do(e); /* perform remainder of processing according to */ /* entry point. */ do(1): call hcs_$status_long (directory, name, 1, addr (stat), null, code); /* look for a directory entry with a name of */ if code ^= 0 then /* _n_a_m_e. */ if code = error_table_$no_s_permission then; /* ignore no_s_permission error code. We got what */ /* information we want. */ else /* other errors indicate that the directory entry */ return; /* was not found. */ Stype = fixed (stat.type, 2); /* convert type to a number. */ mode = fixed (stat.mode, 5); /* same for access mode. */ if Stype = dir then /* if its a directory, then */ if stat.bitcnt then /* maybe its really an MSF. */ Stype = msf; /* Ah ha! I was right. */ do(2): code = 0; /* make sure no error is returned. */ return; do(3): Lnew_suffix = length (rtrim (new_suffix)); /* compute actual length of the _n_e_w__s_u_f_f_i_x. */ if Lsuffix > 0 then /* if _s_u_f_f_i_x is non-blank, remove _s_u_f_f_i_x from */ Lname = Lname - Lsuffix; /* length count of _n_a_m_e (do not include the dot). */ else /* if there's no suffix, add 1 to the length */ Lname = Lname + 1; /* count to make it look like there's a dot. */ if Lnew_suffix = 0 then /* if _n_e_w__s_u_f_f_i_x is null string, then */ substr (name, Lname) = ""; /* return just the non-suffixed part of _n_a_m_e. */ else if Lname + Lnew_suffix <= length(name) then /* if _n_e_w__s_u_f_f_i_x will fit in _n_a_m_e string, then */ /* return suffixed _n_a_m_e formed by appending the */ /* _n_e_w__s_u_f_f_i_x to non-suffix components of entry. */ substr (name, Lname) = "." || substr (new_suffix, 1, Lnew_suffix); /* (remember, dot is already included in Lname.) */ else /* if all else fails, then report error to user. */ go to long_entry_error; go to do(2); /* clear error code and return. */ /* */ long_entry_error: /* report to user that suffixed name won't fit in */ code = error_table_$entlong; /* _n_a_m_e. */ return; end suffixed_name_;  translate_bytes_to_hex9_.alm 08/19/86 1119.2rew 08/19/86 1113.2 18504 " *********************************************************** " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " " Written by R.J.C. Kissel, 11/17/76, for use by dump_segment. " Modified by Linda Pugh, 10/4/82, to spell misspelled word correctly " so this program would compile. " HISTORY COMMENTS: " 1) change(86-07-30,Kissel), approve(86-07-30,MCR7476), audit(86-08-01,Ex), " install(86-08-19,MR12.0-1132): " Changed the name from translate_to_hex9 which was non-standard to " translate_bytes_to_hex9_, which is better. This was done because this " entry is now retained for external use. " END HISTORY COMMENTS " " PL/I Usage: " dcl translate_bytes_to_hex9_ (bit(*), char(*)) " call translate_bytes_to_hex9_ (input_bits, output_chars) " name translate_bytes_to_hex9_ entry translate_bytes_to_hex9_ translate_bytes_to_hex9_: epp1 ap|2,* address of source string to pr1 epp3 ap|4,* address of target string to pr3 ldx3 0,du set x3 not to skip parent pointer if none lxl2 ap|0 load arg list code value canx2 =o0000004,du check for no parent pointer (code 4) tnz *+2 transfer if no parent pointer ldx3 2,du parent pointer, set x3 to skip it ldq ap|6,x3* load source string descriptor anq mask drop all but string size bits qls 1 get length of string in q-reg div 9,dl lda ap|8,x3* load target string descriptor ana mask drop all but string size bits even "EIS address must be even mvt (pr,rl),(pr,rl),fill(00) now do the bcd to ascii desc4a 1|0,ql desc9a 3|0,al arg table short_return mask: oct 000077777777 even table: aci "0123456789ABCDEF" end  walk_subtree.pl1 01/26/85 1258.7r w 01/22/85 1217.0 102726 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ walk_subtree: ws: proc; /* Initially coded in September 1969 by V. Voydock */ /* Converted to pl1 in May 1970 by V. Voydock */ /* Modified on May 4, 1970 at 12:25 midnight by V. Voydock */ /* Modified on January 4, 1971 (to add pi handler) by V. Voydock */ /* Modified on July 8, 1971 by J. Stern Command name changed from "global" to "execute_in_subdirectories". Command format and options changed ("-bottom_up" option added). */ /* Modified Dec 13 1973 by S. Herbst Converted to Version II Names changed to walk_subtree and ws_recursive. Var. length temporary command line. */ /* Bugs fixed 12/9/75 by Steve Herbst: walking through MSF's and cwd in command line changing walk */ /* By Greenberg 3/8/77 to allow walking MSF's (!) on -msf, and -priv for hphcs_$star_. */ /* By GTWilliams 5/9/78 to eliminate BRS's and RRS's from output, move pi handler functionality to a cleanup handler, explicitly set value of op to addr(original_dir). */ /* Badpath error message fixed 05/12/80 S. Herbst */ /* By R. Kovalcik 9/10/82 to handle security-out-of-service error better */ /* By C Spitzer 7 Nov 83: use include star_structures, attempt to use get_shortest_path_ if the directory length would be > 168 */ /* By Keith Loepere, December 1984: generate good paths for dirs off root. */ dcl cleanup condition; dcl original_dir char(168), /* directory from which ws was invoked */ command_line char(clng) based(cp), starting_node char(slng) based(sp), /* starting node of subtree of subdirectories */ starting_dir char (168), arg char(lng) based(ap), cstring char(168), /* ioa_ control string passed to com_err_ */ ws char(16) aligned int static init("walk_subtree"), nl char(1) aligned internal static initial(" "); /* new line character */ dcl (lng, clng, slng, first_level init(1), /* level of recursion at which to begin executing command line */ last_level init(999), i, nargs, level init(0) /* current level of recursion */ ) fixed bin(17); dcl (nnn, code) fixed bin(35); dcl (bottom_up_flag init("0"b), (privf, msff) init ("0"b), trace_flag init("1"b), f_option_flag) bit(1) aligned; dcl (ap, arp, op, sp, tcp, cp )ptr; dcl tem_ area based(arp), tem_com_line char(clng) aligned based(tcp); /* temporary command line to be allocated in tem_ */ dcl error_table_$badopt ext fixed bin(35), error_table_$noarg ext fixed bin(35); dcl (addr, fixed, null, rtrim, substr) builtin, absolute_pathname_ entry (char(*), char(*), fixed bin(35)), pathname_ entry (char(*), char(*)) returns(char(168)), cv_dec_check_ external entry(char(*), fixed bin(35)) returns(fixed bin(35)), cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(35)), cu_$arg_count ext entry(fixed bin(17)), get_system_free_area_ ext entry returns(ptr), get_wdir_ entry() returns(char(168)), change_wdir_ external entry(char(168), fixed bin(35)), ioa_ ext entry options(variable), com_err_ ext entry options(variable); /* */ /* Save original working directory */ /* Establish handler for cleanup to reset user's original working_dir */ on condition (cleanup) call change_wdir_(original_dir,code); op = addr(original_dir); original_dir = get_wdir_(); if original_dir="" then return; /* Get argument count */ call cu_$arg_count(nargs); if nargs < 2 then do; code = error_table_$noarg; cstring = " "; go to ERROR_EXIT1; end; /* Get starting node name */ call cu_$arg_ptr(1, sp, slng, code); if code ^= 0 then do; i = 1; go to ERROR_EXIT3; end; /* "-wd" => current working directory */ if starting_node = "-wd" then do; sp = op; slng = 168; end; call absolute_pathname_ (starting_node, starting_dir, code); if code ^= 0 then do; cstring = starting_node; goto ERROR_EXIT1; end; /* Get command line */ call cu_$arg_ptr(2, cp, clng, code); if code ^= 0 then do; i = 2; go to ERROR_EXIT3; end; /* Check for options */ do i = 3 to nargs; call cu_$arg_ptr(i,ap,lng,code); if code ^= 0 then go to ERROR_EXIT3; if substr(arg,1,1) ^= "-" then /* not an option */ do; cstring = "Argument does not have option format as expected. ^a"; go to ERROR_EXIT2; end; /* Identify options */ if arg="-ft" | arg="-first" then do; f_option_flag="1"b; go to SETLEVEL; end; else if arg="-lt" | arg="-last" then do; f_option_flag="0"b; go to SETLEVEL; end; else if arg="-msf" then msff = "1"b; else if arg = "-priv" then privf = "1"b; else if arg="-bf" | arg="-brief" then trace_flag="0"b; else if arg="-bu" | arg = "-bottom_up" then bottom_up_flag = "1"b; else do; code = error_table_$badopt; cstring= arg; go to ERROR_EXIT1; end; go to ENDLOOP; SETLEVEL: i=i+1; call cu_$arg_ptr(i,ap,lng,code); if code ^= 0 then do; cstring = "Level number missing."; go to ERROR_EXIT2; end; nnn = cv_dec_check_(arg, code); /* convert level number from char to binary */ if code ^= 0 | nnn <= 0 then do; cstring = "Bad level number. ^a"; go to ERROR_EXIT2; end; if f_option_flag then first_level = nnn; else last_level = nnn; ENDLOOP: end; /* Control comes here when all arguments have been processed. */ CALL_CP: if last_level < first_level then do; code = 0; cstring = "Last level must be >= first level."; go to ERROR_EXIT1; end; /* Get area in which star handler can allocate information */ arp = get_system_free_area_(); /* Allocate temporary command line in this area */ allocate tem_com_line in(tem_) set(tcp); /* Now do the real work */ call ws_recursive(starting_dir); /* Free tem_com_line */ free tem_com_line in(tem_); RETURN_TO_ORIGINAL_DIR: /* The real work has been done. Now make the user's working directory be the same as when command was invoked, then return */ call change_wdir_(original_dir,code); if code = 0 then return; cstring = original_dir; ERROR_EXIT1: call com_err_(code, ws, cstring); return; ERROR_EXIT2: call com_err_(0, ws, cstring, arg); return; ERROR_EXIT3: call com_err_(code, ws, "ARG ^d", i); return; /* */ /* Internal procedure to execute the command line set up in the main body of the program at all specified points of the file system hierarchy */ ws_recursive: proc(nodeP); dcl nodeP char(*) parameter; dcl (dp, (ep, np) init(null) ) ptr; dcl node char (168); dcl dpath char (dlng) based (dp); dcl type fixed bin(2); dcl (dlng, k, ecount ) fixed bin(17); dcl nind fixed bin(18); dcl bitcnt fixed bin(24); dcl code fixed bin(35); dcl cu_$cp ext entry(ptr,fixed bin(17),fixed bin(35)), get_shortest_path_ entry (char(*)) returns(char(168)), pathname_ entry (char(*), char(*)) returns(char(168)), hcs_$star_ ext entry(char(*),char(*),fixed bin(2),ptr,fixed bin(17),ptr,ptr,fixed bin(35)); dcl hphcs_$star_ ext entry (char(*),char(*),fixed bin(2),ptr,fixed bin(17),ptr,ptr,fixed bin(35)); dcl hcs_$status_minf entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin(35)); dcl error_table_$dirlong fixed bin(35) ext static; dcl error_table_$no_s_permission ext fixed bin(35); dcl error_table_$nomatch ext fixed bin(35); dcl error_table_$oosw ext fixed bin(35); %include star_structures; /* */ /* Establish cleanup handler */ star_entry_ptr, star_names_ptr = null; on condition(cleanup) begin; if star_names_ptr ^= null then free star_names in (tem_); if star_entry_ptr ^= null then free star_entries in (tem_); end; /* Push level of recursion */ level=level+1; node = nodeP; /* Change working directory to this node */ call change_wdir_(node, code); if code ^= 0 then go to CALL_COM; /* See if top-down trace is wanted */ if bottom_up_flag then go to NEXT; /* See if command processor should be called at this level. If so, copy the command line into temporary because the the command processor destroys the input line passed to it */ EXECUTE: if level>=first_level then do; if trace_flag then call ioa_("^-^a",node); /* trace in effect */ tem_com_line=command_line; call cu_$cp(tcp,clng,code); if code^=0 then if code^=100 then do; level = 0; return; end; call change_wdir_(node,code); /* restore working dir after command line */ if code^=0 then go to CALL_COM; end; if bottom_up_flag then go to FREE; /* If this is last level then skip looking for subdirectories */ NEXT: if level >= last_level then go to SKIP; /* Get list of all subdirectories */ if privf then call hphcs_$star_(node,"**",2,arp,star_entry_count,star_entry_ptr,star_names_ptr,code); else call hcs_$star_(node,"**",2,arp,star_entry_count,star_entry_ptr,star_names_ptr,code); if code=error_table_$nomatch then go to SKIP; /* no subdirectories */ /* Execute command in all subdirectories which are in range */ do k=1 to star_entry_count; nind = fixed(star_entries(k).nindex); if ^msff then do; call hcs_$status_minf(node,star_names(nind),0,type,bitcnt,code); if code^=0 then if code^=error_table_$no_s_permission then if code^=error_table_$oosw then go to CALL_COM; if bitcnt ^= 0 then go to ENDLOOP; /* Don't care if its not dir. */ end; if star_entries(k).type ^= 2 then go to ENDLOOP; if length (rtrim (node)) + length (rtrim (star_names(nind))) + 1 > 168 then do; /* try to make it fit */ node = get_shortest_path_ (node); if length (rtrim (node)) + length (rtrim (star_names(nind))) + 1 > 168 then do; /* still doesn't fit */ call com_err_ (error_table_$dirlong, ws, "^a", pathname_ (node, star_names (nind))); goto ENDLOOP; end; end; call ws_recursive(pathname_ (node, star_names(nind))); /* check for error condition occuring when starting level is greater than one. e.g. "ws