COMPILATION LISTING OF SEGMENT get_library_segment Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Multics Op. - System M Compiled on: 10/22/86 1512.9 mst Wed Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Information Systems Inc., 1982 * 4* * * 5* * Copyright (c) 1972 by Massachusetts Institute of * 6* * Technology and Honeywell Information Systems, Inc. * 7* * * 8* *********************************************************** */ 9 10 11 12 13 /****^ HISTORY COMMENTS: 14* 1) change(86-10-20,TLNguyen), approve(86-10-22,MCR7561), 15* audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1194): 16* Fix bug which occurs when the return value has a leading space. 17* END HISTORY COMMENTS */ 18 19 20 get_library_segment: gls: procedure; 21 22 /* 23* 24* get_library_segment (gls): Special command used to copy source 25* segments from the library archives to the user's working directory. 26* It will call get_archive_file_ to search the source archives 27* in the "source" directories off of specified "system" directories 28* in >ldd. 29* 30* The option "-sys" is followed by a system name (ie, "hard") and 31* specifies what directories to search (ie, ">ldd>hard>source"). 32* Up to 32 system names may be specified. The systems are searched 33* in the order given. 34* 35* The "-long" ("-lg") option is used the cause the printing 36* of a message specifying where each segment is found. 37* The "-brief" ("-bf") option is used to suppress the printing 38* of all messages except those associated with argument processing. 39* 40* 41* If the -sys control arg is not specified all the 42* directories specified in the system control files 43* are searched. 44* 45* Up to 25 segments may be searched for. 46* 47* Usage: 48* 49* gls seg_name1_ ... seg_name_n opt1_ ... opt_n 50* 51* David M. Jordan, June 1971, from P. Bos and J. Spall 52* Modified November, 1971 to add the brief and long options 53* and to expand error messages. David M. Jordan 54* 55* modified June 1972 by steve tepper due to reorganization of 56* source libraries. 57* 58* Modified on August 9, 1972 by Gary C. Dixon to correct 59* errors in parsing the control file, to remove the "pl1" 60* library from the default list of systems to be searched 61* in order to prevent access violations for most users, 62* and to improve error messages. 63* 64* Modified on September 30, 1972 by Gary C. Dixon to use 65* a ptr to gls as the caller_ptr in the call to hcs_$make_entry 66* which initiates the search routines so that gls users don't 67* have to have tools in their search path. 68* 69* Modified on February 27, 1973 by Peter B. Kelley to rename the 70* primary entry point "get_library_source" to "get_library_segment". 71* The entry point get_library_source" was kept. Also modified 72* to remove "dev" from the default search paths as "sss" and "dev" 73* are now one and the same. 74* 75* Modified May 1974 by Arlene Scherer to add code for the Network library 76* and to make it able to copy an archive component into the user's directory 77* with the -rename option when a same-named component is already there. 78* Also removed obsolete entry get_library_source. 79* 80* Modified July 1974 by Steve Herbst to fix namedup bug when returning from 81* nd_handler_ with an answer of "no". 82* 83* Modified July 1974 by Arlene J. Scherer to fix bug which occurs when fetching 84* a source segment with a two-character name (i.e. if.pl1). 85* 86* Modified Aprint 1978 by Michael R. Jordan to change the meaning of -brief to allow 87* error message-less operation. 88* 89* Completely rewritten by D. Vinograd to make it maintainble and in up-to-date prog technology 90* October 1979 91* 92* Modified 03/25/81, W. Olin Sibert, to make -rename implement equal convention. Isn't it strange how these 93* journalization notices get longer and longer each time someone adds one? 94* Modified 10/15/86, Tai Le Nguyen, to fix bug which occurs when the gls active function returned a pathname preceded by a space. 95* 96**/ 97 98 dcl arglp ptr; 99 dcl ac fixed bin; /* number of args processed */ 100 dcl active_fnc bit (1); 101 dcl segx fixed bin; /* loop varsegxable */ 102 dcl sysx fixed bin; /* loop variable */ 103 dcl nargs fixed bin; /* number of arguments */ 104 dcl segcount fixed bin; /* number of segments to be found */ 105 dcl syscount fixed binary; /* number of systems to be searched */ 106 dcl code fixed bin (35); /* error code */ 107 dcl long_sw bit (1); /* switch for -lg options */ 108 dcl brief_sw bit (1); /* switch for -bf option */ 109 dcl argp ptr; /* argument ptr */ 110 dcl argl fixed binary; /* argument length */ 111 dcl arg character (argl) based (argp); /* command argument */ 112 dcl segname (max_names) character (32); /* array of segments to find */ 113 dcl new_name (max_names) char (32); 114 dcl equal_name char (32); 115 dcl (dirname, ename, sname) char (168); 116 dcl (break, eof) bit (1); 117 dcl (break_f, eof_f) fixed bin (1); 118 dcl errsw bit (1) aligned; 119 dcl controlp ptr; 120 dcl atom char (cc) unaligned based (controlp); 121 dcl cc fixed bin; 122 dcl lib_name char (32) ; 123 dcl root char (168); 124 dcl process_dir char (168); 125 dcl working_dir char (168); 126 dcl idx fixed bin; 127 dcl sys (max_sys) character (32); /* array of systems to search */ 128 dcl retp ptr; 129 dcl retl fixed bin; 130 dcl ret char (retl) based (retp) var; 131 132 dcl 1 segment_acl aligned, 133 2 access_name char (32), 134 2 modes bit (36) initial ("0"b), 135 2 pad bit (36) initial ("0"b), 136 2 status_code fixed bin (35); 137 138 dcl myname character (32) static internal options (constant) init ("get_library_segment"); 139 dcl max_names fixed bin int static init (25) options (constant); 140 dcl max_sys fixed bin int static init (100) options (constant); 141 142 dcl (addr, 143 binary, 144 divide, 145 hbound, 146 rtrim, 147 bit, 148 before, 149 reverse, 150 null, 151 codeptr, 152 substr) builtin; 153 154 dcl (error_table_$badopt, 155 error_table_$namedup, 156 error_table_$seg_not_found, 157 error_table_$noarg, 158 error_table_$too_many_names) fixed bin (35) ext; 159 160 dcl search_entry entry (char (*), char (*), char (*), fixed bin (35)) variable; 161 dcl suffixed_name_$make entry (char (*), char (*), char (*), fixed bin (35)); 162 dcl err_rnt entry variable options (variable); 163 dcl get_system_free_area_ entry returns (ptr); 164 dcl hcs_$star_dir_list_ entry (char (*), char (*), fixed bin (3), ptr, fixed bin, fixed bin, ptr, ptr, fixed bin (35)); 165 dcl ioa_ entry options (variable); 166 dcl active_fnc_err_ entry options (variable); 167 dcl com_err_ entry options (variable); 168 dcl archive entry options (variable); 169 dcl cu_$arg_list_ptr entry (ptr); 170 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); 171 dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin, fixed bin (35), ptr); 172 dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); 173 dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); 174 dcl hcs_$make_entry entry (ptr, char (*), char (*), entry, fixed bin (35)); 175 dcl get_equal_name_ entry (char (*), char (*), char (*), fixed bin (35)); 176 dcl get_wdir_ entry returns (char (168)); 177 dcl get_pdir_ entry returns (char (168)); 178 dcl get_group_id_$tag_star entry returns (char (32)); 179 dcl parse_file_$parse_file_init_name entry (char (*), char (*), ptr, fixed bin (35)); 180 dcl parse_file_$parse_file_set_break entry (char (*)); 181 dcl parse_file_$parse_file_unset_break entry (char (*)); 182 dcl parse_file_$parse_file_ptr entry (ptr, fixed bin, fixed bin (1), fixed bin (1)); 183 dcl pathname_ entry (char (*), char (*)) returns (char (168)); 184 dcl pathname_$component entry (char (*), char (*), char (*)) returns (char (194)); 185 dcl copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); 186 dcl requote_string_ entry (char(*)) returns (char(*)); 187 1 1 /* BEGIN INCLUDE FILE . . . star_structures.incl.pl1 */ 1 2 1 3 /* This include file contains structures for the hcs_$star_, 1 4* hcs_$star_list_ and hcs_$star_dir_list_ entry points. 1 5* 1 6* Written 23 October 1978 by Monte Davidoff. 1 7* Modified January 1979 by Michael R. Jordan to use unsigned and different pointers for different structures. 1 8* Modified June 1981 by C. Hornig to count link pathnames more efficiently. 1 9**/ 1 10 1 11 /* automatic */ 1 12 1 13 declare star_branch_count fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: matching branch count */ 1 14 declare star_entry_count fixed binary; /* hcs_$star_: number of matching entries */ 1 15 declare star_entry_ptr pointer; /* hcs_$star_: pointer to array of entry information */ 1 16 declare star_list_branch_ptr pointer; /* hcs_$star_list_, hcs_$star_dir_list_: ptr to array of info */ 1 17 declare star_link_count fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: matching link count */ 1 18 declare star_linkx fixed binary; /* hcs_$star_list_, hcs_$star_dir_list_: index into star_links */ 1 19 declare star_names_ptr pointer; /* hcs_$star_: pointer to array of entry names */ 1 20 declare star_list_names_ptr pointer; /* hcs_$star_list_, hcs_$star_dir_list_: ptr to entry names */ 1 21 declare star_select_sw fixed binary (3); /* hcs_$star_list_, hcs_$star_dir_list_: what info to return */ 1 22 1 23 /* based */ 1 24 1 25 /* hcs_$star_ entry structure */ 1 26 1 27 declare 1 star_entries (star_entry_count) aligned based (star_entry_ptr), 1 28 2 type fixed binary (2) unsigned unaligned, 1 29 /* storage system type */ 1 30 2 nnames fixed binary (16) unsigned unaligned, 1 31 /* number of names of entry that match star_name */ 1 32 2 nindex fixed binary (18) unsigned unaligned; 1 33 /* index of first name in star_names */ 1 34 1 35 /* hcs_$star_ name structure */ 1 36 1 37 declare star_names (sum (star_entries (*).nnames)) char (32) based (star_names_ptr); 1 38 1 39 /* hcs_$star_list_ branch structure */ 1 40 1 41 declare 1 star_list_branch (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 1 42 2 type fixed binary (2) unsigned unaligned, 1 43 /* storage system type */ 1 44 2 nnames fixed binary (16) unsigned unaligned, 1 45 /* number of names of entry that match star_name */ 1 46 2 nindex fixed binary (18) unsigned unaligned, 1 47 /* index of first name in star_list_names */ 1 48 2 dtcm bit (36) unaligned, /* date-time contents of branch were last modified */ 1 49 2 dtu bit (36) unaligned, /* date-time branch was last used */ 1 50 2 mode bit (5) unaligned, /* user's access mode to the branch */ 1 51 2 raw_mode bit (5) unaligned, /* user's ACL access mode */ 1 52 2 master_dir bit (1) unaligned, /* is branch a master directory */ 1 53 2 pad bit (7) unaligned, 1 54 2 records fixed binary (18) unsigned unaligned; 1 55 /* records used by branch */ 1 56 1 57 /* hcs_$star_dir_list_ branch structure */ 1 58 1 59 declare 1 star_dir_list_branch (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 1 60 2 type fixed binary (2) unsigned unaligned, 1 61 /* storage system type */ 1 62 2 nnames fixed binary (16) unsigned unaligned, 1 63 /* number of names of entry that match star_name */ 1 64 2 nindex fixed binary (18) unsigned unaligned, 1 65 /* index of first name in star_list_names */ 1 66 2 dtem bit (36) unaligned, /* date-time directory entry of branch was last modified */ 1 67 2 pad bit (36) unaligned, 1 68 2 mode bit (5) unaligned, /* user's access mode to the branch */ 1 69 2 raw_mode bit (5) unaligned, /* user's ACL access mode */ 1 70 2 master_dir bit (1) unaligned, /* is branch a master directory */ 1 71 2 bit_count fixed binary (24) unaligned; 1 72 /* bit count of the branch */ 1 73 1 74 /* hcs_$star_list_ and hcs_$star_dir_list_ link structure */ 1 75 1 76 declare 1 star_links (star_branch_count + star_link_count) aligned based (star_list_branch_ptr), 1 77 2 type fixed binary (2) unsigned unaligned, 1 78 /* storage system type */ 1 79 2 nnames fixed binary (16) unsigned unaligned, 1 80 /* number of names of entry that match star_name */ 1 81 2 nindex fixed binary (18) unsigned unaligned, 1 82 /* index of first name in star_list_names */ 1 83 2 dtem bit (36) unaligned, /* date-time link was last modified */ 1 84 2 dtd bit (36) unaligned, /* date-time the link was last dumped */ 1 85 2 pathname_len fixed binary (18) unsigned unaligned, 1 86 /* length of the pathname of the link */ 1 87 2 pathname_index fixed binary (18) unsigned unaligned; 1 88 /* index of start of pathname in star_list_names */ 1 89 1 90 /* hcs_$star_list_ and hcs_$star_dir_list_ name array */ 1 91 1 92 declare star_list_names char (32) based (star_list_names_ptr) 1 93 dimension (star_links (star_branch_count + star_link_count).nindex 1 94 + star_links (star_branch_count + star_link_count).nnames 1 95 + divide (star_links (star_branch_count + star_link_count).pathname_len + 31, 32, 17, 0) 1 96 * binary ( 1 97 (star_links (star_branch_count + star_link_count).type = star_LINK) 1 98 & (star_select_sw >= star_LINKS_ONLY_WITH_LINK_PATHS), 1)); 1 99 1 100 /* hcs_$star_list_ and hcs_$star_dir_list_ link pathname */ 1 101 1 102 declare star_link_pathname char (star_links (star_linkx).pathname_len) 1 103 based (addr (star_list_names (star_links (star_linkx).pathname_index))); 1 104 1 105 /* internal static */ 1 106 1 107 /* star_select_sw values */ 1 108 1 109 declare star_LINKS_ONLY fixed binary (2) internal static options (constant) initial (1); 1 110 declare star_BRANCHES_ONLY fixed binary (2) internal static options (constant) initial (2); 1 111 declare star_ALL_ENTRIES fixed binary (2) internal static options (constant) initial (3); 1 112 declare star_LINKS_ONLY_WITH_LINK_PATHS 1 113 fixed binary (3) internal static options (constant) initial (5); 1 114 declare star_ALL_ENTRIES_WITH_LINK_PATHS 1 115 fixed binary (3) internal static options (constant) initial (7); 1 116 1 117 /* storage system types */ 1 118 1 119 declare star_LINK fixed binary (2) unsigned internal static options (constant) initial (0); 1 120 declare star_SEGMENT fixed binary (2) unsigned internal static options (constant) initial (1); 1 121 declare star_DIRECTORY fixed binary (2) unsigned internal static options (constant) initial (2); 1 122 1 123 /* END INCLUDE FILE . . . star_structures.incl.pl1 */ 188 189 190 root = ">ldd"; /* set default root name* (ast) */ 191 star_list_branch_ptr = null; 192 star_list_names_ptr = null; 193 star_select_sw = star_ALL_ENTRIES; 194 lib_name = ""; 195 working_dir = get_wdir_ (); 196 ac = 0; 197 active_fnc = "0"b; 198 err_rnt = com_err_; 199 segcount = 0; 200 syscount = 0; 201 brief_sw = "0"b; /* default is to print the missing segment error */ 202 long_sw = "0"b; /* default is not to print a message */ 203 204 call cu_$arg_list_ptr (arglp); 205 call cu_$af_return_arg (nargs, retp, retl, code); 206 if code = 0 then do; 207 active_fnc = "1"b; 208 err_rnt = active_fnc_err_; 209 ret = ""; 210 end; 211 if nargs = 0 then do; 212 call err_rnt (error_table_$noarg, myname, 213 "Usage is: get_library_segment seg_name {seg_name} {-control_args}"); 214 return; 215 end; 216 217 /* * * * * * * * * * * * * * * * * * * * * * * * */ 218 /* */ 219 /* Argument processing, options start with "-", */ 220 /* otherwise assumed to be segment name. The */ 221 /* arg following the "-sys" option is taken to */ 222 /* be a system (ldd directory) name. */ 223 /* */ 224 /* * * * * * * * * * * * * * * * * * * * * * * * */ 225 226 ac = 1; 227 do while (ac <= nargs); 228 229 call cu_$arg_ptr_rel (ac, argp, argl, code, arglp); 230 if code ^= 0 then do; 231 noarg: call err_rnt (code, myname, "no argument after ^a", arg); 232 return; 233 end; 234 235 if substr (arg, 1, 1) ^= "-" then /* Assumed to be source segment name */ 236 do; 237 segcount = segcount + 1; 238 if segcount > hbound (segname, 1) then do; 239 call err_rnt (error_table_$too_many_names, myname, 240 "A maximum of ^d segment names may be specified.", hbound (segname, 1)); 241 return; 242 end; 243 segname (segcount) = arg; 244 new_name (segcount) = arg; 245 end; 246 247 else if arg = "-sys" then do; 248 249 /* * * * * * * * * * * * * * * * * * * * * * * * */ 250 /* */ 251 /* Must be followed by a system (ldd dir) name, */ 252 /* but we don't check the name for validity. */ 253 /* */ 254 /* * * * * * * * * * * * * * * * * * * * * * * * */ 255 256 syscount = syscount + 1; 257 if syscount > hbound (sys, 1) then do; 258 call err_rnt (error_table_$too_many_names, myname, 259 "A maximum of ^d system names may be specified.", hbound (sys, 1)); 260 return; 261 end; 262 sys (syscount) = get_arg (); 263 end; 264 265 266 else if arg = "-bf" | arg = "-brief" then do; 267 268 /* * * * * * * * * * * * * * * * * * * * * * * * */ 269 /* */ 270 /* Specifies that no message is to be printed */ 271 /* */ 272 /* * * * * * * * * * * * * * * * * * * * * * * * */ 273 274 brief_sw = "1"b; 275 long_sw = "0"b; 276 end; 277 278 else if arg = "-lg" | arg = "-long" then do; 279 280 /* * * * * * * * * * * * * * * * * * * * * * * * */ 281 /* */ 282 /* Specifies that a message should be printed */ 283 /* */ 284 /* * * * * * * * * * * * * * * * * * * * * * * * */ 285 286 brief_sw = "0"b; 287 long_sw = "1"b; 288 end; 289 290 291 /* **************************************** 292* 293* option "-control" 294* 295* sets the root node. 296* the arg after "-root" is the new root node name. 297* 298* **************************************** */ 299 else if arg = "-control" | arg = "-ct" then do; 300 root = get_arg (); 301 if root = "-working_directory" | root = "-wd" then 302 root = working_dir; 303 end; 304 305 306 307 /* ********************************************************** 308* 309* option "-rename" ("-rn") 310* 311* renames the source segment to a new name in the target directory. 312* 313* *********************************************************** */ 314 else if arg = "-rename" | arg = "-rn" then do; 315 equal_name = get_arg (); 316 call get_equal_name_ (segname (segcount), equal_name, new_name (segcount), code); 317 if code ^= 0 then do; 318 call err_rnt (code, myname, "-rename ^a", equal_name); 319 return; 320 end; 321 end; /* of processing for -rename */ 322 323 324 325 /* *********** bad option ************ */ 326 else do; 327 call err_rnt (error_table_$badopt, myname, "^a", arg); /* Unknown option */ 328 return; 329 end; 330 331 ac = ac + 1; 332 end; 333 334 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 335 336 337 if segcount = 0 then /* No segment to look for specified */ 338 do; 339 call err_rnt (error_table_$noarg, myname, 340 "A segment name must be specified."); 341 return; 342 end; 343 344 if syscount = 0 then /* No system specified, search them all */ 345 do; 346 call hcs_$star_dir_list_ (root, "**.control", star_select_sw, get_system_free_area_ (), 347 star_branch_count, star_link_count, star_list_branch_ptr, star_list_names_ptr, code); 348 if code ^= 0 then do; 349 call err_rnt (code, myname, "Unable to list root"); 350 return; 351 end; 352 do idx = 1 to star_branch_count + star_link_count while (idx <= hbound (sys, 1)); 353 sys (idx) = star_list_names (star_dir_list_branch (idx).nindex); 354 end; 355 syscount = idx - 1; 356 if syscount = hbound (sys, 1) then 357 call err_rnt (0, myname, "Warning - some control segs have been skipped"); 358 end; 359 360 361 /* * * * * * * * * * * * * * * * * * * * * * * * */ 362 /* */ 363 /* Main Search Loop */ 364 /* */ 365 /* * * * * * * * * * * * * * * * * * * * * * * * */ 366 367 do segx = 1 to segcount; 368 do sysx = 1 to syscount; 369 370 /* for each sys(sysx), make a ptr to [root || ">" || sys(sysx) || ".control"]. 371* read that file, which contains records of the format: 372* [ ]. 373* may be either , or $. 374* 375* call the search segname, giving as an arg. 376* 377* the search seg will return the name of the segment (archive or otherwise) 378* that contains the target segment. 379* */ 380 call suffixed_name_$make (sys (sysx), "control", sys (sysx), code); 381 if code ^= 0 then do; 382 call err_rnt (code, myname, "error constructing control file name for ^a", 383 sys (sysx)); 384 goto finish; 385 end; 386 call parse_file_$parse_file_init_name (root, sys (sysx), controlp, code); /* make a ptr to control file */ 387 if code ^= 0 then do; 388 call err_rnt (code, myname, " Unable to locate segment ^a>^a.", 389 root, sys (sysx)); 390 goto finish; 391 end; 392 again: dirname, sname = ""; 393 call parse_file_$parse_file_unset_break ("!""#%&'()+,-./;>?@[\]^_`{|}~"); 394 call get_atom; 395 if eof then goto sys_done; /* eof means done parsing file. */ 396 if break then goto syntax_err; /* entry starting w/ break is an error */ 397 dirname = atom; 398 399 call get_atom; 400 if eof then goto eof_err; /* to end file in mid-line is a no-no. */ 401 if break then /* break must be ":"; else error. */ 402 if atom ^= ":" then goto syntax_err; 403 if substr (dirname, 1, 1) ^= ">" then dirname = rtrim (root) || ">" || dirname; /* fudge if rel. path */ 404 405 call parse_file_$parse_file_set_break (">;"); 406 /* absolute path name for search rtn is an error 407* name of routine terminate by a ";". */ 408 call get_atom; 409 if eof then /* ending file in mid-line is error. */ 410 goto eof_err; 411 if break then /* segname starting w/ break is also bad. */ 412 goto syntax_err; 413 sname = atom; 414 call get_atom; 415 /* get entry name of search rtn, or ";" statement terminator. */ 416 if break then do; 417 if atom = ";" then 418 ename = sname; /* if end of stmt, use segname as entryname. */ 419 else if atom = "$" then do; /* look for entry name. */ 420 if eof then goto eof_err; /* error to end file in mid-line */ 421 call get_atom; 422 if eof then goto eof_err; /* oops, forget stmt terminator. */ 423 if break then goto syntax_err; /* no breaks in valid entry name; error */ 424 ename = atom; 425 426 call get_atom; 427 if break then do; 428 if atom ^= ";" then goto syntax_err; 429 end; 430 else goto syntax_err; /* non-break char is an error, too */ 431 /* eof is ignored at this time, if 432* it occurs, but will be caught on the 433* next parse call at top of this loop */ 434 end; /* break other than ";" or "$" is error */ 435 else goto syntax_err; /* non-break is an error, too */ 436 end; 437 else goto syntax_err; 438 /* eof is ignored at this point, 439* but caught next time at top of loop */ 440 /* now, dirname has directory to be searched, 441* sname has segment name of search seg, 442* ename has entry point name in search seg 443* */ 444 445 446 dummy: call hcs_$make_entry (codeptr (dummy), sname, ename, search_entry, code); 447 if code ^= 0 then do; 448 call err_rnt (code, myname, "Unable to initiate search routine ^a$^a.", 449 sname, ename); 450 goto finish; 451 end; 452 453 454 /* call search routine with "dirname", which contains the directory 455* to be searched, and "segment", which contains the segname of what we are looking for. 456* 457* call it with: 458* dirname - name of node below which to search. 459* segname(segx) - target segname. 460* lib_name - file where we found it (may be an archive file). 461* code - error code (0 if ok, 1 if not found, n if other error). 462* */ 463 call search_entry (dirname, segname (segx), lib_name, code); 464 465 /* now, analyze the return code from the searching seg. 466* code=0 means that the segment was found, in segment lib_name 467* (may be archive file). 468* code=1 means that the segment was not found in the directory searched. 469* */ 470 471 if code = 0 then do; /* hooray, we found it */ 472 if reverse (before (reverse (lib_name), ".")) = "archive" then do; /* is anarchive file */ 473 if long_sw then call ioa_ ("^a: Extracting ^a from ^a>^a.", 474 myname, segname (segx), dirname, lib_name); 475 476 /* ************************************************************************* 477* if rename option, extract segment into process directory and then copy it with 478* new name to avoid name dups in the working directory 479* ***************************************************** */ 480 481 if active_fnc then do; 482 if ret ^= "" then ret = ret || " "; 483 ret = ret || requote_string_ (rtrim (pathname_$component (dirname, lib_name, segname (segx)))); 484 end; 485 else do; 486 if segname (segx) ^= new_name (segx) then do; 487 process_dir = get_pdir_ (); 488 489 call archive ("x", rtrim (dirname) || ">" || lib_name, rtrim (process_dir) || ">" || segname (segx)); 490 call copy_seg_ (process_dir, segname (segx), working_dir, new_name (segx), myname, 491 errsw, code); 492 if code ^= 0 then if code ^= error_table_$namedup then 493 call err_rnt (code, myname, "error copying from pdir"); 494 495 call hcs_$delentry_file (process_dir, segname (segx), code); 496 if code ^= 0 then call err_rnt (code, myname, "error deleteing pdir copy"); 497 end; 498 499 /* ***************************************************************** 500* if no rename option just extract it into the working directory 501* ***************************************************************** */ 502 503 else call archive ("x", rtrim (dirname) || ">" || lib_name, segname (segx)); 504 505 /* **************************************************** 506* In either case, set the acl to rew for user -extracter 507* ***************************************************** */ 508 509 segment_acl.access_name = get_group_id_$tag_star (); 510 segment_acl.modes = "1110"b; 511 512 call hcs_$add_acl_entries (working_dir, new_name (segx), addr (segment_acl), 1, code); 513 if (segment_acl.status_code ^= 0) | (code ^= 0) then 514 call err_rnt (code, myname, "error adding access"); 515 516 end; 517 goto seg_done; /* in either case */ 518 end; /* end of archive code */ 519 else do; 520 if active_fnc then do; 521 if ret ^= "" then ret = ret || " "; 522 ret = ret || requote_string_ (rtrim (pathname_ (dirname, lib_name))); 523 end; 524 else do; 525 /* copy from "dirname || ">" || lib_name" to "segment" */ 526 if long_sw then call ioa_ ("^a: Copying ^a from ^a>^a.", myname, 527 segname (segx), dirname, lib_name); 528 call copy_seg_ (dirname, lib_name, working_dir, new_name (segx), myname, errsw, code); 529 if code ^= 0 then if code ^= error_table_$namedup 530 then if ^brief_sw 531 then call err_rnt (code, myname, "Error while attempting to copy ^a>^a to ^a.", 532 dirname, lib_name, new_name (segx)); 533 end; 534 end; 535 goto seg_done; 536 end; /* end of loop for segments */ 537 if code ^= 1 then /* Some other error (code = 1 means not found) */ 538 if ^brief_sw & ^active_fnc then call err_rnt (code, myname, 539 "^/Error encountered while searching ^a for ^a specified in ^a>^a.^/Search continues.", 540 dirname, segname (segx), root, sys (sysx)); 541 goto again; 542 sys_done: 543 end; 544 if ^brief_sw then call err_rnt (error_table_$seg_not_found, myname, "^a.", segname (segx)); 545 seg_done: 546 end; 547 finish: 548 if star_list_names_ptr ^= null then free star_list_names; 549 if star_list_branch_ptr ^= null then free star_dir_list_branch; 550 return; 551 552 syntax_err: call err_rnt (0, myname, "Syntax error in segment ^a>^a.", root, sys (sysx)); 553 goto finish; 554 555 eof_err: call err_rnt (0, myname, "Premature EOF in segment ^a>^a.", root, sys (sysx)); 556 goto finish; 557 558 get_atom: proc; 559 call parse_file_$parse_file_ptr (controlp, cc, break_f, eof_f); 560 break = bit (break_f, 1); /* convert to bit string */ 561 eof = bit (eof_f, 1); /* ... */ 562 563 end get_atom; 564 get_arg: proc returns (char (*)); 565 ac = ac + 1; 566 call cu_$arg_ptr_rel (ac, argp, argl, code, arglp); 567 if code ^= 0 then goto noarg; 568 return (arg); 569 end get_arg; 570 end get_library_segment; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 10/22/86 1512.9 get_library_segment.pl1 >spec>install>1194>get_library_segment.pl1 188 1 06/10/82 1045.5 star_structures.incl.pl1 >ldd>include>star_structures.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. ac 000102 automatic fixed bin(17,0) dcl 99 set ref 196* 226* 227 229* 331* 331 565* 565 566* access_name 000547 automatic char(32) level 2 dcl 132 set ref 509* active_fnc 000103 automatic bit(1) unaligned dcl 100 set ref 197* 207* 481 520 537 active_fnc_err_ 000032 constant entry external dcl 166 ref 208 addr builtin function dcl 142 ref 512 512 archive 000036 constant entry external dcl 168 ref 489 503 arg based char unaligned dcl 111 set ref 231* 235 243 244 247 266 266 278 278 299 299 314 314 327* 568 argl 000116 automatic fixed bin(17,0) dcl 110 set ref 229* 231 231 235 243 244 247 266 266 278 278 299 299 314 314 327 327 566* 568 arglp 000100 automatic pointer dcl 98 set ref 204* 229* 566* argp 000114 automatic pointer dcl 109 set ref 229* 231 235 243 244 247 266 266 278 278 299 299 314 314 327 566* 568 atom based char unaligned dcl 120 ref 397 401 413 417 419 424 428 before builtin function dcl 142 ref 472 binary builtin function dcl 142 ref 547 bit builtin function dcl 142 ref 560 561 break 000325 automatic bit(1) unaligned dcl 116 set ref 396 401 411 416 423 427 560* break_f 000327 automatic fixed bin(1,0) dcl 117 set ref 559* 560 brief_sw 000113 automatic bit(1) unaligned dcl 108 set ref 201* 274* 286* 529 537 544 cc 000334 automatic fixed bin(17,0) dcl 121 set ref 397 401 413 417 419 424 428 559* code 000111 automatic fixed bin(35,0) dcl 106 set ref 205* 206 229* 230 231* 316* 317 318* 346* 348 349* 380* 381 382* 386* 387 388* 446* 447 448* 463* 471 490* 492 492 492* 495* 496 496* 512* 513 513* 528* 529 529 529* 537 537* 566* 567 codeptr builtin function dcl 142 ref 446 446 com_err_ 000034 constant entry external dcl 167 ref 198 controlp 000332 automatic pointer dcl 119 set ref 386* 397 401 413 417 419 424 428 559* copy_seg_ 000100 constant entry external dcl 185 ref 490 528 cu_$af_return_arg 000042 constant entry external dcl 170 ref 205 cu_$arg_list_ptr 000040 constant entry external dcl 169 ref 204 cu_$arg_ptr_rel 000044 constant entry external dcl 171 ref 229 566 dirname 000127 automatic char(168) unaligned dcl 115 set ref 392* 397* 403 403* 403 463* 473* 483* 483* 489 503 522* 522* 526* 528* 529* 537* divide builtin function dcl 142 ref 547 ename 000201 automatic char(168) unaligned dcl 115 set ref 417* 424* 446* 448* eof 000326 automatic bit(1) unaligned dcl 116 set ref 395 400 409 420 422 561* eof_f 000330 automatic fixed bin(1,0) dcl 117 set ref 559* 561 equal_name 000117 automatic char(32) unaligned dcl 114 set ref 315* 316* 318* err_rnt 000566 automatic entry variable dcl 162 set ref 198* 208* 212 231 239 258 318 327 339 349 356 382 388 448 492 496 513 529 537 544 552 555 error_table_$badopt 000010 external static fixed bin(35,0) dcl 154 set ref 327* error_table_$namedup 000012 external static fixed bin(35,0) dcl 154 ref 492 529 error_table_$noarg 000016 external static fixed bin(35,0) dcl 154 set ref 212* 339* error_table_$seg_not_found 000014 external static fixed bin(35,0) dcl 154 set ref 544* error_table_$too_many_names 000020 external static fixed bin(35,0) dcl 154 set ref 239* 258* errsw 000331 automatic bit(1) dcl 118 set ref 490* 528* get_equal_name_ 000054 constant entry external dcl 175 ref 316 get_group_id_$tag_star 000062 constant entry external dcl 178 ref 509 get_pdir_ 000060 constant entry external dcl 177 ref 487 get_system_free_area_ 000024 constant entry external dcl 163 ref 346 346 get_wdir_ 000056 constant entry external dcl 176 ref 195 hbound builtin function dcl 142 ref 238 239 239 257 258 258 352 356 hcs_$add_acl_entries 000046 constant entry external dcl 172 ref 512 hcs_$delentry_file 000050 constant entry external dcl 173 ref 495 hcs_$make_entry 000052 constant entry external dcl 174 ref 446 hcs_$star_dir_list_ 000026 constant entry external dcl 164 ref 346 idx 000543 automatic fixed bin(17,0) dcl 126 set ref 352* 352* 353 353* 355 ioa_ 000030 constant entry external dcl 165 ref 473 526 lib_name 000335 automatic char(32) unaligned dcl 122 set ref 194* 463* 472 473* 483* 483* 489 503 522* 522* 526* 528* 529* long_sw 000112 automatic bit(1) unaligned dcl 107 set ref 202* 275* 287* 473 526 max_names constant fixed bin(17,0) initial dcl 139 ref 112 113 max_sys constant fixed bin(17,0) initial dcl 140 ref 127 modes 10 000547 automatic bit(36) initial level 2 dcl 132 set ref 132* 510* myname 000000 constant char(32) initial unaligned dcl 138 set ref 212* 231* 239* 258* 318* 327* 339* 349* 356* 382* 388* 448* 473* 490* 492* 496* 513* 526* 528* 529* 537* 544* 552* 555* nargs 000106 automatic fixed bin(17,0) dcl 103 set ref 205* 211 227 new_name 000117 automatic char(32) array unaligned dcl 113 set ref 244* 316* 486 490* 512* 528* 529* nindex 0(18) based fixed bin(18,0) array level 2 in structure "star_dir_list_branch" packed unsigned unaligned dcl 1-59 in procedure "gls" ref 353 nindex 0(18) based fixed bin(18,0) array level 2 in structure "star_links" packed unsigned unaligned dcl 1-76 in procedure "gls" ref 547 nnames 0(02) based fixed bin(16,0) array level 2 packed unsigned unaligned dcl 1-76 ref 547 null builtin function dcl 142 ref 191 192 547 549 pad 11 000547 automatic bit(36) initial level 2 dcl 132 set ref 132* parse_file_$parse_file_init_name 000064 constant entry external dcl 179 ref 386 parse_file_$parse_file_ptr 000072 constant entry external dcl 182 ref 559 parse_file_$parse_file_set_break 000066 constant entry external dcl 180 ref 405 parse_file_$parse_file_unset_break 000070 constant entry external dcl 181 ref 393 pathname_ 000074 constant entry external dcl 183 ref 522 522 pathname_$component 000076 constant entry external dcl 184 ref 483 483 pathname_len 3 based fixed bin(18,0) array level 2 packed unsigned unaligned dcl 1-76 ref 547 process_dir 000417 automatic char(168) unaligned dcl 124 set ref 487* 489 490* 495* requote_string_ 000102 constant entry external dcl 186 ref 483 522 ret based varying char dcl 130 set ref 209* 482 482* 482 483* 483 521 521* 521 522* 522 retl 000546 automatic fixed bin(17,0) dcl 129 set ref 205* 209 482 483 521 522 retp 000544 automatic pointer dcl 128 set ref 205* 209 482 482 482 483 483 521 521 521 522 522 reverse builtin function dcl 142 ref 472 472 root 000345 automatic char(168) unaligned dcl 123 set ref 190* 300* 301 301 301* 346* 386* 388* 403 537* 552* 555* rtrim builtin function dcl 142 ref 403 483 483 489 489 503 522 522 search_entry 000562 automatic entry variable dcl 160 set ref 446* 463 segcount 000107 automatic fixed bin(17,0) dcl 104 set ref 199* 237* 237 238 243 244 316 316 337 367 segment_acl 000547 automatic structure level 1 dcl 132 set ref 512 512 segname 000117 automatic char(32) array unaligned dcl 112 set ref 238 239 239 243* 316* 463* 473* 483* 483* 486 489 490* 495* 503* 526* 537* 544* segx 000104 automatic fixed bin(17,0) dcl 101 set ref 367* 463 473 483 483 486 486 489 490 490 495 503 512 526 528 529 537 544* sname 000253 automatic char(168) unaligned dcl 115 set ref 392* 413* 417 446* 448* star_ALL_ENTRIES constant fixed bin(2,0) initial dcl 1-111 ref 193 star_LINK constant fixed bin(2,0) initial unsigned dcl 1-119 ref 547 star_LINKS_ONLY_WITH_LINK_PATHS constant fixed bin(3,0) initial dcl 1-112 ref 547 star_branch_count 000572 automatic fixed bin(17,0) dcl 1-13 set ref 346* 352 547 547 547 547 549 star_dir_list_branch based structure array level 1 dcl 1-59 ref 549 star_link_count 000576 automatic fixed bin(17,0) dcl 1-17 set ref 346* 352 547 547 547 547 549 star_links based structure array level 1 dcl 1-76 star_list_branch_ptr 000574 automatic pointer dcl 1-16 set ref 191* 346* 353 547 547 547 547 549 549 star_list_names based char(32) array unaligned dcl 1-92 ref 353 547 star_list_names_ptr 000600 automatic pointer dcl 1-20 set ref 192* 346* 353 547 547 star_select_sw 000602 automatic fixed bin(3,0) dcl 1-21 set ref 193* 346* 547 status_code 12 000547 automatic fixed bin(35,0) level 2 dcl 132 set ref 513 substr builtin function dcl 142 ref 235 403 suffixed_name_$make 000022 constant entry external dcl 161 ref 380 sys 000544 automatic char(32) array unaligned dcl 127 set ref 257 258 258 262* 352 353* 356 380* 380* 382* 386* 388* 537* 552* 555* syscount 000110 automatic fixed bin(17,0) dcl 105 set ref 200* 256* 256 257 262 344 355* 356 368 sysx 000105 automatic fixed bin(17,0) dcl 102 set ref 368* 380 380 382 386 388 537* 552 555 type based fixed bin(2,0) array level 2 packed unsigned unaligned dcl 1-76 ref 547 working_dir 000471 automatic char(168) unaligned dcl 125 set ref 195* 301 490* 512* 528* NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. star_ALL_ENTRIES_WITH_LINK_PATHS internal static fixed bin(3,0) initial dcl 1-114 star_BRANCHES_ONLY internal static fixed bin(2,0) initial dcl 1-110 star_DIRECTORY internal static fixed bin(2,0) initial unsigned dcl 1-121 star_LINKS_ONLY internal static fixed bin(2,0) initial dcl 1-109 star_SEGMENT internal static fixed bin(2,0) initial unsigned dcl 1-120 star_entries based structure array level 1 dcl 1-27 star_entry_count automatic fixed bin(17,0) dcl 1-14 star_entry_ptr automatic pointer dcl 1-15 star_link_pathname based char unaligned dcl 1-102 star_linkx automatic fixed bin(17,0) dcl 1-18 star_list_branch based structure array level 1 dcl 1-41 star_names based char(32) array unaligned dcl 1-37 star_names_ptr automatic pointer dcl 1-19 NAMES DECLARED BY EXPLICIT CONTEXT. again 001741 constant label dcl 392 set ref 541 dummy 002147 constant label dcl 446 ref 446 446 eof_err 003746 constant label dcl 555 ref 400 409 420 422 finish 003630 constant label dcl 547 ref 384 390 450 553 556 get_arg 004040 constant entry internal dcl 564 ref 262 300 315 get_atom 004006 constant entry internal dcl 558 ref 394 399 408 414 421 426 get_library_segment 000460 constant entry external dcl 20 gls 000450 constant entry external dcl 20 noarg 000636 constant label dcl 231 ref 567 seg_done 003626 constant label dcl 545 ref 517 535 syntax_err 003706 constant label dcl 552 ref 396 401 411 416 419 423 427 428 sys_done 003570 constant label dcl 542 ref 395 THERE WERE NO NAMES DECLARED BY CONTEXT OR IMPLICATION. STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 4502 4606 4114 4512 Length 5054 4114 104 232 366 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME gls 592 external procedure is an external procedure. get_atom internal procedure shares stack frame of external procedure gls. get_arg 76 internal procedure uses returns(char(*)) or returns(bit(*)). STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME gls 000100 arglp gls 000102 ac gls 000103 active_fnc gls 000104 segx gls 000105 sysx gls 000106 nargs gls 000107 segcount gls 000110 syscount gls 000111 code gls 000112 long_sw gls 000113 brief_sw gls 000114 argp gls 000116 argl gls 000117 equal_name gls 000117 segname gls 000117 new_name gls 000127 dirname gls 000201 ename gls 000253 sname gls 000325 break gls 000326 eof gls 000327 break_f gls 000330 eof_f gls 000331 errsw gls 000332 controlp gls 000334 cc gls 000335 lib_name gls 000345 root gls 000417 process_dir gls 000471 working_dir gls 000543 idx gls 000544 retp gls 000544 sys gls 000546 retl gls 000547 segment_acl gls 000562 search_entry gls 000566 err_rnt gls 000572 star_branch_count gls 000574 star_list_branch_ptr gls 000576 star_link_count gls 000600 star_list_names_ptr gls 000602 star_select_sw gls THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as r_ge_a alloc_char_temp cat_realloc_chars call_ent_var_desc call_ext_out_desc call_ext_out call_int_this_desc return_mac tra_ext_1 alloc_auto_adj shorten_stack ext_entry int_entry_desc reverse_cs set_chars_eis return_chars_eis op_freen_ THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. active_fnc_err_ archive com_err_ copy_seg_ cu_$af_return_arg cu_$arg_list_ptr cu_$arg_ptr_rel get_equal_name_ get_group_id_$tag_star get_pdir_ get_system_free_area_ get_wdir_ hcs_$add_acl_entries hcs_$delentry_file hcs_$make_entry hcs_$star_dir_list_ ioa_ parse_file_$parse_file_init_name parse_file_$parse_file_ptr parse_file_$parse_file_set_break parse_file_$parse_file_unset_break pathname_ pathname_$component requote_string_ suffixed_name_$make THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$badopt error_table_$namedup error_table_$noarg error_table_$seg_not_found error_table_$too_many_names LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 112 000415 113 000423 127 000431 132 000437 316 000441 380 000444 20 000447 190 000466 191 000471 192 000473 193 000474 194 000476 195 000501 196 000510 197 000511 198 000512 199 000517 200 000520 201 000521 202 000522 204 000523 205 000531 206 000546 207 000550 208 000552 209 000557 211 000560 212 000562 214 000606 226 000607 227 000611 229 000615 230 000634 231 000636 232 000670 235 000671 237 000676 238 000677 239 000702 241 000733 243 000734 244 000744 245 000751 247 000752 256 000757 257 000760 258 000763 260 001014 262 001015 263 001042 266 001044 274 001054 275 001056 276 001057 278 001060 286 001070 287 001071 288 001073 299 001074 300 001104 301 001124 303 001140 314 001141 315 001151 316 001171 317 001223 318 001225 319 001255 321 001256 327 001257 328 001311 331 001312 332 001313 337 001314 339 001316 341 001342 344 001343 346 001345 348 001426 349 001430 350 001453 352 001454 353 001470 354 001510 355 001512 356 001515 367 001544 368 001553 380 001563 381 001616 382 001620 384 001651 386 001652 387 001701 388 001703 390 001740 392 001741 393 001747 394 001763 395 001764 396 001766 397 001770 399 001775 400 001776 401 002000 403 002010 405 002053 408 002067 409 002070 411 002072 413 002074 414 002101 416 002102 417 002104 419 002116 420 002122 421 002124 422 002125 423 002127 424 002131 426 002136 427 002137 428 002141 446 002147 447 002201 448 002203 450 002235 463 002236 471 002265 472 002267 473 002315 481 002356 482 002360 483 002375 484 002503 486 002505 487 002520 489 002527 490 002651 492 002715 495 002750 496 002774 497 003021 503 003022 509 003105 510 003120 512 003122 513 003163 517 003215 520 003216 521 003220 522 003235 523 003333 526 003335 528 003375 529 003440 535 003507 537 003510 541 003567 542 003570 544 003572 545 003626 547 003630 549 003674 550 003705 552 003706 553 003745 555 003746 556 004005 558 004006 559 004007 560 004024 561 004031 563 004036 564 004037 565 004045 566 004047 567 004065 568 004073 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved