backup_cleanup.pl1 10/28/88 1411.9r w 10/28/88 1302.3 66474 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ backup_cleanup: bc: proc; /* Command to dprint and delete backup maps and error files. Usage: backup_cleanup {starnames} {-no_dprint} If no starnames are specified, *.*.map and *.*.ef in the working directory are processed. If -no_dprint is specified, the segments are deleted. Otherwise they are dprinted and deleted. Written 04/26/79 S. Herbst */ %include dprint_arg; dcl 1 entries (branch_count) aligned based (entries_ptr), /* for hcs_$star_ */ 2 type bit (2) unaligned, 2 nnames bit (16) unaligned, 2 nindex bit (18) unaligned; dcl names (99) char (32) aligned based (names_ptr); /* for hcs_$star_ */ dcl area area based (area_ptr); dcl arg char (arg_len) based (arg_ptr); dcl ERROR_FILE_DIR char (168) int static options (constant) init (">udd>SysDaemon>error_file"); dcl dn char (168); dcl (en, name) char (32); dcl (dprint_sw, ef_sw, path_sw) bit (1) aligned; dcl (area_ptr, arg_ptr, entries_ptr, names_ptr) ptr; dcl rings (3) fixed bin (5); dcl (arg_count, arg_len, branch_count, i, j, queue_number) fixed bin; dcl code fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl bk_ss_$myname char (16) ext; dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl com_err_ entry options (variable); dcl copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35)); dcl cu_$arg_count entry (fixed bin); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$level_get entry returns (fixed bin); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin); dcl dprint_ entry (char (*), char (*), ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); dcl get_wdir_ entry returns (char (168)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (5), 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 (addr, fixed, length, max, null, rtrim, substr) builtin; dcl cleanup condition; /* */ bk_ss_$myname = "backup_cleanup"; call cu_$arg_count (arg_count); dprint_sw = "1"b; path_sw = "0"b; queue_number = 1; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-no_dprint" | arg = "-ndp" then dprint_sw = "0"b; else if arg = "-dprint" | arg = "-dp" then dprint_sw = "1"b; else if arg = "-queue" | arg = "-q" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, "backup_cleanup", "No value specified for ^a", arg); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); queue_number = cv_dec_check_ (arg, code); if code ^= 0 then do; BAD_QUEUE: call com_err_ (0, "backup_cleanup", "Invalid queue number ^a", arg); return; end; else if queue_number < 1 | queue_number > 4 then go to BAD_QUEUE; end; else do; call com_err_ (error_table_$badopt, "backup_cleanup", "^a", arg); return; end; else path_sw = "1"b; end; area_ptr = get_system_free_area_ (); if dprint_sw then do; dpap = addr (dprint_arg_buf); dprint_arg.version = 1; dprint_arg.copies = 1; dprint_arg.delete = 1; dprint_arg.queue = queue_number; dprint_arg.pt_pch = 1; dprint_arg.notify = 0; dprint_arg.output_module = 1; dprint_arg.dest = "SysDaemon"; end; if ^path_sw then do; /* no starnames specified */ call do_starname (get_wdir_ (), "*.*.map"); call do_starname (get_wdir_ (), "*.*.*.ef"); end; else do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) ^= "-" then do; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then do; call com_err_ (code, "backup_cleanup", "^a", arg); return; end; if substr (arg, arg_len - 3, 4) = ".map" | substr (arg, arg_len - 2, 3) = ".ef" then call do_starname (dn, en); else do; call do_starname (dn, rtrim (en) || ".map"); call do_starname (dn, rtrim (en) || ".ef"); end; end; end; return; /* */ do_starname: proc (a_dn, a_en); dcl (a_dn, a_en) char (*); call check_star_name_$entry (a_en, code); if code = 0 then do; branch_count, j = 1; name = a_en; go to ONE_FILE; end; else if code = 1 | code = 2 then do; entries_ptr, names_ptr = null; on condition (cleanup) call clean_up; call hcs_$star_ (a_dn, a_en, 2 /* branches */, area_ptr, branch_count, entries_ptr, names_ptr, code); if code ^= 0 then do; if code ^= error_table_$nomatch then call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", a_en); return; end; do j = 1 to branch_count; name = names (fixed (entries (j).nindex, 18)); ONE_FILE: if substr (a_en, length (rtrim (a_en)) - 2, 3) = ".ef" then do; ef_sw = "1"b; dprint_arg.heading = " for OLD ERROR FILE"; end; else do; ef_sw = "0"b; dprint_arg.heading = " for OLD MAP"; end; if dprint_sw | ef_sw then do; call adjust_bit_count_ ((a_dn), (name), "1"b, 0, code); if code ^= 0 then do; call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", name); return; end; rings (1), rings (2), rings (3) = max (4, cu_$level_get ()); call hcs_$set_ring_brackets (a_dn, name, rings, code); end; if ef_sw then do; /* copy error file */ call hcs_$status_minf (ERROR_FILE_DIR, name, 0, 0, 0, code); if code ^= error_table_$noentry then do; call hcs_$delentry_file (ERROR_FILE_DIR, name, code); COPY_ERROR: if code ^= 0 then call com_err_ (code, "backup_cleanup", "Copying ^a^[>^]^a to ^a>^a", a_dn, a_dn ^= ">", name, ERROR_FILE_DIR, name); end; else code = 0; if code = 0 then do; call copy_seg_ (a_dn, name, ERROR_FILE_DIR, name, "backup_cleanup", "0"b, code); if code ^= 0 then go to COPY_ERROR; end; end; if dprint_sw then call dprint_ (a_dn, name, dpap, code); else call hcs_$delentry_file (a_dn, name, code); end; call clean_up; end; else call com_err_ (code, "backup_cleanup", "^a", a_en); end do_starname; /* */ clean_up: proc; if entries_ptr ^= null then free entries_ptr -> entries in (area); if names_ptr ^= null then free names_ptr -> names in (area); end clean_up; end backup_cleanup;  backup_dump.pl1 03/30/87 1135.0rew 03/30/87 1050.8 252639 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-06-05,GWMay), approve(85-12-23,MCR7320), audit(86-11-19,GDixon), install(86-11-21,MR12.0-1223): Modified the process loop to abort when a fatal error is returned from the recursive dump subroutine. This way the program will not continue dumping with the next line in the control file. Added the entry backup_dump$abort_on_tape_errors to provide a means of returning the error code from a bad tape mount or write. 2) change(87-03-03,GWMay), approve(87-03-03,MCR7627), audit(87-03-13,Farley), install(87-03-30,MR12.1-1018): added switch in the condition handling routine so that when writing to the map, all conditions are passed back to the default handler. END HISTORY COMMENTS */ /* Hierarchy dumper */ /* Created: February 1969 by R. C. Daley */ /* Modified: 29 June 1970 by R. H. Campbell */ /* Modified: 6 May 1976 by R. Bratt for pv dump */ /* Modified: 2 November 1977 by Steve Herbst to add backup_dump_ */ /* Modified: 3 August 1979 by Steve Herbst to add bk_ss_$no_primary */ /* Modified: 28 January 1980 by S. Herbst to add missing options to the map */ /* Modified: 6 November 1980 by G. Palter for version 3 backup_control structure */ /* Modified: 30 December 1980 by Steve Herbst to read control file and implement cross-dumping */ /* Modified: 4 August 1981 by G. Palter to fix interaction of cross-dumping and incremental/catchup/complete dumper */ /* Modified: July 1982 by G. Palter to add features for IMFT support of AIM: enforce a maximum access class for dumping, refuse to dump upgraded directories, and check a user's effective access to each branch before dumping */ /* Modified February 1983 by E. N. Kittlitz for 256K segs */ /* Modified August 1983 by Robert Coren to enforce a minimum access class for dumping */ /* Modified November 1983 by Robert Coren to copy "upgrade_to_user_auth" flag */ /* Modified 1985-03-21, BIM: fixed prehistoric busted condition handler. phx18650 -- does not reset transparency switches. phx17329 -- mishandling empty acls. phx17310 -- unitialized variables in cross-dumping. phx16651 -- rqovers on the map do not always get to level 2. phx13714 -- catching command_error conditions */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ backup_dump: procedure (); dcl Sfatal_error bit (1) aligned; dcl Stape_entry bit (1) aligned; dcl (i, id_length, n) fixed bin, /* Temporary storage. */ (a_code, code, saved_code) fixed bin (35), /* Status codes */ (old_trans_sw, ts) fixed bin (2), /* To save previous transparent switch settings. */ vers char (13) init ("21 March 1985") aligned int static options (constant), /* version of dumper */ calendar char (16) aligned, /* Temporary for time conversion. */ ap ptr, /* Pointer to argument list */ p ptr, sp ptr, control_ptr ptr, /* ptr to backup_dump_ control structure */ path_index fixed bin, tchar (168) char (1) based, /* test character array */ saved_dtd fixed bin (52); dcl old_256K_switch bit (2) aligned; dcl (cross_dump_path, cross_dump_dn, dn, dump_dir, temp_dn) char (168); dcl cross_dump_en char (32); dcl text_line char (300); dcl NL char (1) int static options (constant) init (" "); dcl type fixed bin (2), btcnt fixed bin (24); /* Arguments for status_minf call */ dcl init static bit (1) initial ("1"b), /* Static storage. */ control_file_sw bit (1), /* Reading requests from a control file */ linep static ptr; /* Pointer to ID line buffer. */ dcl id static char (300); /* Name, version of dumper and arguments. */ dcl error_table_$noaccess fixed bin (35) external; /* Status */ dcl error_table_$noarg fixed bin (35) external; dcl error_table_$no_s_permission fixed bin (35) external; dcl error_table_$root fixed bin (35) external; dcl sys_info$seg_size_256K fixed bin (19) external; dcl backup_control_mgr_$initiate entry (pointer, fixed binary (35)), backup_control_mgr_$terminate entry (pointer), backup_dump_recurse entry (char (168), char (32), bit (1) aligned, bit (1) aligned, fixed bin (35)), backup_dump_recurse$set_directory_dtd entry (char (*) aligned, fixed bin (52)), backup_map_$beginning_line entry (fixed bin (52), ptr, fixed bin), backup_map_$fs_error_line entry (fixed bin (35), char (*), char (*), char (*)), backup_map_$directory_line entry (ptr, fixed bin), backup_map_$terminal_line entry (fixed bin (52), fixed bin (35)), backup_util$get_real_name entry (ptr, ptr, fixed bin, fixed bin (35)), bk_output$output_init entry (fixed bin, fixed bin (35)), bk_output$output_finish entry; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)), bk_arg_reader_$dump_arg_reader entry (fixed bin, ptr, fixed bin (35)), clock_ entry (fixed bin (52)), com_err_ entry options (variable), cu_$arg_count entry (fixed bin), cu_$arg_list_ptr entry (ptr), date_time_ entry (fixed bin (52), char (*) aligned), expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)), hcs_$fs_search_get_wdir entry (ptr, fixed bin), hcs_$status_minf entry (char (*) aligned, char (*) aligned, fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)), hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35)), hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35)), hcs_$set_max_length_seg ext entry (ptr, fixed bin (19), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)), (ioa_$rs) entry options (variable); /* Variable arguments. */ dcl ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned); dcl ios_$detach entry (char (*), char (*), char (*), bit (72) aligned); dcl ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned); dcl hphcs_$fs_get_trans_sw entry (fixed bin (2), fixed bin (2)); dcl ( hphcs_$suspend_quota, hphcs_$restore_quota ) external entry; dcl cleanup condition; dcl any_other condition; dcl (addr, index, length, max, min, null, reverse, rtrim, substr) builtin; /* */ %include bk_ss_; %page; %include backup_preamble_header; %page; %include backup_control; %page; %include io_status; /* */ bk_ss_$sub_entry = "0"b; Stape_entry = "0"b; if bk_ss_$myname = " " then bk_ss_$myname = "backup_dump"; go to common; abort_on_tape_errors: entry (tape_code); dcl tape_code fixed bin; tape_code = 0; bk_ss_$sub_entry = "0"b; Stape_entry = "1"b; control_file_sw = "0"b; /* control file is read by caller */ go to have_args; backup_dump_: entry (control_ptr, a_code); bk_ss_$sub_entry = "1"b; Stape_entry = "0"b; a_code = 0; bk_ss_$control_ptr = null(); old_256K_switch = ""b; /* initialize for cleanup */ old_trans_sw = -1; /* leaves the switches alone */ on condition (cleanup) begin; call hcs_$set_256K_switch (old_256K_switch, (""b), (0)); if ^bk_ss_$debugsw then do; call hphcs_$fs_get_trans_sw (old_trans_sw, (0)); call hphcs_$restore_quota; /* Restore the quota */ end; if bk_ss_$control_ptr ^= null then call backup_control_mgr_$terminate (control_ptr); end; call backup_control_mgr_$initiate (control_ptr, a_code); if a_code ^= 0 then return; if bk_ss_$control_ptr -> backup_control.debug_sw then do; bk_ss_$debugsw = "1"b; bk_ss_$trimsw = "0"b; end; else bk_ss_$debugsw = "0"b; bk_ss_$mapsw = bk_ss_$control_ptr -> backup_control.map_sw; bk_ss_$no_reload = bk_ss_$control_ptr -> backup_control.no_reload_sw; bk_ss_$holdsw = bk_ss_$control_ptr -> backup_control.hold_sw; bk_ss_$preattached = bk_ss_$control_ptr -> backup_control.preattached; if bk_ss_$preattached then bk_ss_$data_iocb = bk_ss_$control_ptr -> backup_control.data_iocb; bk_ss_$sub_entry_errfile = bk_ss_$control_ptr -> backup_control.error_file; bk_ss_$caller_handles_conditions = bk_ss_$control_ptr -> backup_control.caller_handles_conditions; bk_ss_$enforce_max_access_class = bk_ss_$control_ptr -> backup_control.enforce_max_access_class; if bk_ss_$enforce_max_access_class then bk_ss_$maximum_access_class = bk_ss_$control_ptr -> backup_control.maximum_access_class; bk_ss_$enforce_min_access_class = bk_ss_$control_ptr -> backup_control.enforce_min_access_class; if bk_ss_$enforce_min_access_class then bk_ss_$minimum_access_class = bk_ss_$control_ptr -> backup_control.minimum_access_class; bk_ss_$dont_dump_upgraded_dirs = bk_ss_$control_ptr -> backup_control.dont_dump_upgraded_dirs; if bk_ss_$dont_dump_upgraded_dirs then bk_ss_$maximum_dir_access_class = bk_ss_$control_ptr -> backup_control.maximum_dir_access_class; bk_ss_$check_effective_access = bk_ss_$control_ptr -> backup_control.check_effective_access; if bk_ss_$check_effective_access then do; bk_ss_$user_id = bk_ss_$control_ptr -> backup_control.user_for_access_check.id; bk_ss_$user_authorization = bk_ss_$control_ptr -> backup_control.user_for_access_check.authorization; bk_ss_$user_ring = bk_ss_$control_ptr -> backup_control.user_for_access_check.ring; end; bk_ss_$upgrade_to_user_auth = bk_ss_$control_ptr -> backup_control.upgrade_to_user_auth; do i = 1 to bk_ss_$control_ptr -> backup_control.request_count; bk_ss_$control_ptr -> backup_control.found (i) = "0"b; bk_ss_$control_ptr -> backup_control.loaded (i) = "0"b; bk_ss_$control_ptr -> backup_control.status_code (i) = 0; bk_ss_$control_ptr -> backup_control.error_name (i) = ""; end; bk_ss_$myname = "backup_dump_"; go to common; idump: entry; bk_ss_$sub_entry = "0"b; Stape_entry = "0"b; bk_ss_$myname = "idump"; common: cross_dump_path, cross_dump_dn, cross_dump_en = ""; /* read in arguments and set switches */ control_file_sw = "0"b; /* not yet told of control file in our arguments */ if bk_ss_$sub_entry then do; /* if backup_dump_, get first pathname */ do i = 1 to bk_ss_$control_ptr -> backup_control.request_count; call absolute_pathname_ (bk_ss_$control_ptr -> backup_control.path (i), dn, code); if code = 0 & dn = ">" then code = error_table_$root; if code ^= 0 then do; a_code, bk_ss_$control_ptr -> backup_control.status_code (i) = code; go to RETURN_FROM_BACKUP_DUMP; end; end; bk_ss_$save_path = bk_ss_$control_ptr -> backup_control.path (1); path_index, bk_ss_$path_index = 1; bk_ss_$pathsw = "1"b; bk_ss_$save_plen = length (rtrim (bk_ss_$save_path)); end; else do; /* else read command argument */ call cu_$arg_count (i); /* Get the number of input arguments */ if i ^= 0 then do; /* Don't bother if no args */ call cu_$arg_list_ptr (ap); /* Get pointer to argument list */ call bk_arg_reader_$dump_arg_reader (1, ap, code); /* Do the work */ if code ^= 0 then return; if bk_ss_$control_name ^= "" & bk_ss_$myname = "backup_dump" then do; call ios_$attach ("dump_control", "file_", bk_ss_$control_name, "r", addr (status) -> status_bits); if status.code ^= 0 then do; call com_err_ (status.code, bk_ss_$myname, "Attaching control file ^a", bk_ss_$control_name) ; return; end; READ_CONTROL: call ios_$read ("dump_control", addr (dump_dir), 0, length (dump_dir), n, addr (status) -> status_bits); if status.code ^= 0 then do; READ_ERROR: call com_err_ (status.code, bk_ss_$myname, "Reading control file ^a", bk_ss_$control_name); return; end; if substr (dump_dir, n, 1) = NL then substr (dump_dir, n) = ""; else substr (dump_dir, n + 1) = ""; if substr (dump_dir, 1, 1) ^= ">" then if status.end_of_data then return; else go to READ_CONTROL; i = index (dump_dir, "="); if i ^= 0 then do; cross_dump_path = substr (dump_dir, i + 1); substr (dump_dir, i) = ""; if substr (cross_dump_path, 1, 1) ^= ">" then cross_dump_path = substr (dump_dir, 1, length (dump_dir) + 1 - index (reverse (dump_dir), ">")) || cross_dump_path; if bk_ss_$mapsw then text_line = "(Cross-dumping " || rtrim (dump_dir) || " to " || rtrim (cross_dump_path) || ")"; call expand_pathname_ (cross_dump_path, cross_dump_dn, cross_dump_en, code); if code ^= 0 then do; call com_err_ (code, bk_ss_$myname, "Cross-dump path ^a", cross_dump_path); return; end; end; else cross_dump_path, cross_dump_dn, cross_dump_en = ""; bk_ss_$pathsw = "1"b; bk_ss_$save_path = dump_dir; bk_ss_$save_plen = n; control_file_sw = "1"b; end; else if ^bk_ss_$pathsw then do; call com_err_ (error_table_$noarg, bk_ss_$myname, "No absolute pathname specified."); return; end; else do; have_args: cross_dump_path, cross_dump_dn, cross_dump_en = ""; call absolute_pathname_ (substr (bk_ss_$save_path, 1, bk_ss_$save_plen), dn, code); if code = 0 & dn = ">" then code = error_table_$root; if code ^= 0 then do; call com_err_ (code, "backup_dump", "^a", substr (bk_ss_$save_path, 1, bk_ss_$save_plen)); return; end; end; end; else if bk_ss_$myname = "backup_dump" then do; call com_err_ (error_table_$noarg, "backup_dump", "No pathname specified."); return; end; end; /* initialization */ Sfatal_error = "0"b; old_256K_switch = ""b; /* initialize for cleanup */ old_trans_sw = -1; /* passing this back in has no effect */ if ^bk_ss_$sub_entry then on cleanup begin; /* need a cleanup handler */ call hcs_$set_256K_switch (old_256K_switch, (""b), (0)); /* ignore code */ if ^bk_ss_$debugsw then do; call hphcs_$fs_get_trans_sw (old_trans_sw, (0)); call hphcs_$restore_quota; /* Restore the quota */ end; end; call hcs_$set_256K_switch ("11"b, old_256K_switch, (0)); /* ignore code */ if init then do; call hcs_$make_seg ("", "dump_seg", "", 01011b, bk_ss_$sp, code); call hcs_$set_max_length_seg (bk_ss_$sp, sys_info$seg_size_256K, code); call hcs_$make_seg ("", "dump_area", "", 01011b, bk_ss_$areap, code); call hcs_$make_seg ("", "dump_preamble", "", 01011b, bk_ss_$hp, code); linep = addr (id); /* Set up pointer to identification line. */ bk_ss_$areap -> h.dumper_id, /* Insert dumper ID into preamble headers. */ bk_ss_$hp -> h.dumper_id = "Backup_dump " || vers; init = ""b; end; if bk_ss_$restart_dumpsw then do; /* Check for restart branch */ call hcs_$status_minf (bk_ss_$restart_path, "", 0, type, btcnt, code); if code ^= 0 then do; if bk_ss_$sub_entry then a_code = code; else call com_err_ (code, bk_ss_$myname, "^a", bk_ss_$restart_path); go to RETURN_FROM_BACKUP_DUMP; end; end; /* Start the dump .... first get absolute path name of starting directory */ start: bk_ss_$writing_map = "0"b; call clock_ (bk_ss_$save_time); /* Get the current time. */ if ^bk_ss_$pathsw then do; /* Was a path name supplied? */ call hcs_$fs_search_get_wdir (addr (bk_ss_$save_path), bk_ss_$save_plen); if bk_ss_$save_plen = 0 then do; /* Is there a current working directory? */ code = error_table_$noaccess; if bk_ss_$sub_entry then a_code = code; else call com_err_ (code, bk_ss_$myname, "working directory"); /* Gripe. */ go to RETURN_FROM_BACKUP_DUMP; end; end; if bk_ss_$sub_entry then bk_ss_$no_primary = bk_ss_$control_ptr -> backup_control.no_primary_sw (bk_ss_$path_index); if ^bk_ss_$no_primary then do; call backup_util$get_real_name (addr (bk_ss_$save_path), addr (bk_ss_$save_path), bk_ss_$save_plen, code); if bk_ss_$restart_dumpsw then call backup_util$get_real_name (addr (bk_ss_$restart_path), addr (bk_ss_$restart_path), bk_ss_$restart_plen, code); end; id_length = 0; /* Report switch settings */ if bk_ss_$mapsw then do; /* Is a map output desired? */ call append (rtrim (bk_ss_$myname)); /* set name into id line */ call append (vers); /* and version */ if bk_ss_$tapesw then /* Report tape option. */ if bk_ss_$ntapes = 1 then call append ("1tape"); /* How many tapes? */ else call append ("2tapes"); /* Both. */ else call append ("notape"); /* No tape output enabled. */ call append ("map"); /* Report map option */ if bk_ss_$holdsw then call append ("hold"); /* Report tape hold option. */ else call append ("nohold"); if bk_ss_$onlysw then call append ("only"); /* Report whether hierarchy dump */ else call append ("sweep"); if bk_ss_$dtdsw then call append ("dtd"); /* Report dtd setting. */ if bk_ss_$datesw then do; /* Report date value. */ call date_time_ (bk_ss_$date, calendar);/* Convert the time value. */ call append (calendar); end; if ^(bk_ss_$dtdsw | bk_ss_$datesw) then call append ("all"); /* Are both off? */ if bk_ss_$debugsw then call append ("debug");/* Report debug mode setting */ if bk_ss_$err_onlinesw then call append ("error_on"); if bk_ss_$no_contin then call append ("nocontin"); /* stop after catchup dump */ if bk_ss_$no_output then call append ("nooutput"); /* no tape or map (bug if ON) */ if bk_ss_$no_primary then call append ("noprimary"); /* do not use primary paths */ if bk_ss_$restart_dumpsw then call append ("restart"); /* restarting previous dump */ if bk_ss_$pvsw then do; call append ("pvname = " || rtrim (bk_ss_$pvname)); end; end; if bk_ss_$tapesw then do; call bk_output$output_init (bk_ss_$ntapes, code); /* initialize output if tape option ON */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "bk_output$output_init", "Initialization", ""); if Stape_entry then tape_code = code; else if bk_ss_$sub_entry then a_code = code; go to RETURN_FROM_BACKUP_DUMP; end; end; call backup_map_$beginning_line (bk_ss_$save_time, linep, id_length); /* Write and type the beginning time. */ if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to RETURN_FROM_BACKUP_DUMP; /* OK? */ /* Dump header and first directory */ bk_ss_$namesw = "1"b; /* tell dump to dump only this record */ if ^bk_ss_$debugsw then do; /* for real not debug */ call hphcs_$suspend_quota; /* dumper runs quota inhibited */ call hphcs_$fs_get_trans_sw (11b, old_trans_sw); /* Transparent use, modification. */ end; on any_other call idump_signal; /* First dump branch of starting directory to get names and ACLs */ do; p = addr (bk_ss_$save_path); /* Get pointer to starting pathname */ do i = bk_ss_$save_plen to 1 by -1 while (p -> tchar (i) ^= ">"); end; /* Find last ">" */ bk_ss_$hp -> h.dname = substr (bk_ss_$save_path, 1, max (1, i - 1)); bk_ss_$hp -> h.dlen = max (1, i - 1); bk_ss_$ename = substr (bk_ss_$save_path, i + 1, bk_ss_$save_plen - i); if bk_ss_$mapsw then do; if cross_dump_path ^= "" then do; call backup_map_$directory_line (addr (text_line), length (rtrim (text_line))); temp_dn = cross_dump_dn; end; else temp_dn = bk_ss_$hp -> h.dname; call backup_map_$directory_line (addr (temp_dn), length (rtrim (temp_dn))); end; if ^bk_ss_$pvsw then do; /* dump branch - except in pv dump case */ call hcs_$status_minf (bk_ss_$hp -> h.dname, bk_ss_$ename, 1, type, btcnt, code); if code ^= 0 & code ^= error_table_$no_s_permission then do; call backup_map_$fs_error_line (code, "status_minf", (bk_ss_$hp -> h.dname), (bk_ss_$ename)); if bk_ss_$sub_entry then bk_ss_$control_ptr -> backup_control.status_code (path_index) = code; go to dumped; end; call backup_dump_recurse (cross_dump_dn, cross_dump_en, "1"b, Sfatal_error, code); if Sfatal_error then go to error; /* D U M P T H E B R A N C H */ if type = 1 then do; /* If terminal node was a segment ... */ if code = 1 then code = 0; /* Code of 1 is normal return for single entry. */ go to dumped; /* Clean up and leave. */ end; end; end; /* Now dump the rest of the subtree */ if bk_ss_$sub_entry then saved_code = bk_ss_$control_ptr -> backup_control.status_code (path_index); do; saved_dtd = bk_ss_$hp -> h.dtd; /* needed to set DTD of the dir later (maybe) */ bk_ss_$hp -> h.dname = bk_ss_$save_path; /* Now dump everything else */ bk_ss_$hp -> h.dlen = bk_ss_$save_plen; /* .. */ bk_ss_$namesw = ""b; /* set for entire dump */ if bk_ss_$restart_dumpsw then bk_ss_$rlen = bk_ss_$save_plen + 1; /* Set starting length of name for recursion in restart */ call backup_dump_recurse (cross_dump_dn, cross_dump_en, "0"b, Sfatal_error, code); if Sfatal_error then go to error; /* D U M P S U B T R E E */ call backup_dump_recurse$set_directory_dtd (bk_ss_$hp -> h.dname, saved_dtd); end; dumped: if bk_ss_$sub_entry then do; /* if backup_dump_, get the next pathname */ if saved_code = 0 & bk_ss_$control_ptr -> backup_control.status_code (path_index) ^= 0 then bk_ss_$control_ptr -> backup_control.error_name (path_index) = "(in subtree) " || substr (bk_ss_$control_ptr -> backup_control.error_name (path_index), 1, length (bk_ss_$control_ptr -> backup_control.error_name (path_index)) - length ( "(in subtree)" )); path_index, bk_ss_$path_index = path_index + 1; if path_index <= bk_ss_$control_ptr -> backup_control.request_count then do; bk_ss_$save_path = bk_ss_$control_ptr -> backup_control.path (path_index); bk_ss_$save_plen = length (rtrim (bk_ss_$save_path)); cross_dump_path = bk_ss_$control_ptr -> backup_control.new_path (path_index); revert any_other; if ^bk_ss_$debugsw then do; /* Turn on quota, turn off trans sw if possible */ call hphcs_$restore_quota; /* Restore the quota */ call hphcs_$fs_get_trans_sw (old_trans_sw, ts); /* Restore previous settings. */ end; go to start; end; end; else if control_file_sw then /* get next control file entry */ if ^status.end_of_data then do; revert any_other; if ^bk_ss_$debugsw then do; /* Turn on quota, turn off trans sw if possible */ call hphcs_$restore_quota; /* Restore the quota */ call hphcs_$fs_get_trans_sw (old_trans_sw, ts); /* Restore previous settings. */ end; go to READ_CONTROL; end; else call ios_$detach ("dump_control", "", "", addr (status) -> status_bits); /* Cleanup and exit */ error: if Sfatal_error then do; if Stape_entry then tape_code = code; if bk_ss_$sub_entry then a_code = code; else call com_err_ (code, bk_ss_$myname, " Unable to continue dumping."); end; revert any_other; if ^bk_ss_$debugsw then do; /* Turn on quota, turn off trans sw if possible */ call hphcs_$restore_quota; /* Restore the quota */ call hphcs_$fs_get_trans_sw (old_trans_sw, ts); /* Restore previous settings. */ end; if bk_ss_$tapesw then call bk_output$output_finish (); /* Shutdown output proceedure */ call clock_ (bk_ss_$save_time); /* Get time of stopping. */ call backup_map_$terminal_line (bk_ss_$save_time, code); /* Write the trailer line. */ call hcs_$truncate_seg (bk_ss_$sp, 0, code); /* Free unused pages in buffer segments. */ call hcs_$truncate_seg (bk_ss_$areap, 1023, code);/* Save first page of preamble segments. */ call hcs_$truncate_seg (bk_ss_$hp, 1023, code); /* .. */ if (bk_ss_$myname = "backup_dump") | (bk_ss_$myname = "idump") then bk_ss_$myname = ""; RETURN_FROM_BACKUP_DUMP: call hcs_$set_256K_switch (old_256K_switch, (""b), (0)); /* ignore code */ if bk_ss_$sub_entry then /* possibly copy info back to older structure */ call backup_control_mgr_$terminate (control_ptr); return; /* */ append: procedure (string); /* Append string to identification line. */ dcl string character (*) aligned; /* What to append. */ if id_length < length (id) then do; /* Is there room in buffer? */ id_length = id_length + 1; /* Count it. */ substr (id, id_length, 1) = " "; /* Prepend a blank. */ i = min (length (id) - id_length, length (string)); /* Don't overflow. */ substr (id, id_length + 1, i) = string; /* Append this string. */ id_length = id_length + i; /* Count length. */ end; end append; /* */ /* Entry upon recieving an unclaimed signal */ idump_signal: procedure; dcl save_error fixed binary, /* Space to save error location code. */ is_temp fixed bin, is_code fixed bin (35), is_linep pointer, /* Pointer to line buffer. */ is_line character (300); /* Line for formatting output messages. */ declare continue_to_signal_ entry (fixed binary (35)); declare find_condition_info_ entry (pointer, pointer, fixed binary (35)); declare 1 CI aligned like condition_info; if bk_ss_$sub_entry & bk_ss_$caller_handles_conditions | bk_ss_$writing_map then do; call continue_to_signal_ ((0)); return; end; /* caller has any_other handler (for IMFT daemon usage) */ CI.version = condition_info_version_1; call find_condition_info_ (null (), addr (CI), (0)); if ^(CI.condition_name = "seg_fault_error" | CI.condition_name = "no_read_permission" | CI.condition_name = "record_quota_overflow"/* null pages ... */ | CI.condition_name = "out_of_bounds" /* joker changed maxl */ | CI.condition_name = "not_in_read_bracket" /* etc. */ | CI.condition_name = "page_fault_error" /* disk problems */) then do; call continue_to_signal_ ((0)); /* Not our problem */ return; end; /**** If we get here, we have a condition that could possibly have happened while referencing a segment that we were dumping. Check to see if we were dumping a segment. (bk_ss_$error ^= 0) If not, we continue to signal anyway, since it is a problem with the dumper and not just a joker nailing a segment we are dumping. */ save_error = bk_ss_$error; /* Save copy of error location code. */ bk_ss_$error = 0; /* Indicate future errors fatal. */ is_linep = addr (is_line); /* Get pointer to line buffer. */ if save_error ^= 0 then do; /* If error is not fatal at this time */ if bk_ss_$mapsw then do; /* Are we to report in the map? */ call ioa_$rs ("Non-fatal ^a at ^d: ^a>^a", is_line, is_temp, CI.condition_name, save_error, bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename); call backup_map_$directory_line (is_linep, is_temp); end; if bk_ss_$wasnt_known then do; /* Should we terminate this segment? */ bk_ss_$wasnt_known = ""b; /* Clear indicator for safety. */ bk_ss_$error = 1; /* Enable error recovery attempt. */ call hcs_$terminate_noname (bk_ss_$segptr, is_code); /* Terminate this segment. */ bk_ss_$error = 0; /* Disable error recovery. */ end; go to bk_ss_$err_label; /* attempt to recover with non-local go to */ end; call continue_to_signal_ ((0)); /* No internal error recovery */ return; %include condition_info; end idump_signal; end backup_dump;  backup_dump_recurse.pl1 07/16/87 1350.4rew 07/16/87 1312.4 413397 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* Dumps a branch to tape and, optionally, dumps the contents of the subtree if the branch is a directory */ /* Modified: 10 January 1972 by A. Kobziar to use special status entry instead of branch_info for actime,actind Modified: 01 March 1973 by A. Downing to make all calls to (area_,alloc_,freen_) be made to the old area package Modified: 15 December 1974 by A. Kobziar to set up sec_directory_list record with security info Modified: April 1976 by R. Bratt for tpd stuff and pv dump Modified: September 1976 by R. Bratt to no longer terminate directories Modified: ? by B. Greenberg for VTOC errors Modified: 26 June 1979 by S. Herbst to make incremental dumps ignore ring-0 entries Modified: 17 November 1980 by G. Palter to honor bk_ss_$no_primary and to always sort branches to allow restart bit to work properly Modified: 24 February 1981 by S. Herbst to retry dump twice after error_table_$device_attention Modified: 1 July 1981 by S. Herbst to add support -setdtd and -nosetdtd Modified: 4 August 1981 by G. Palter to properly handle dumping of top-level directories in the control file Modified: July 1982 by G. Palter to add features for IMFT support of AIM: enforce a maximum access class for dumping, refuse to dump upgraded directories, and check a user's effective access to each branch before dumping Modified: February 1983 by E. N. Kittlitz for 256K segs Modified: August 1983 by Robert Coren to enforce minimum access class for dumping Modified: November 1983 by Robert Coren to upgrade object access class to user's authorization if requested Modified 1985-03-21, BIM: fixed prehistoric busted condition handler. -------- -- Fixed not to force access in no-reload mode. phx17078 -- bks is not correctly zeroed. phx18650 -- does not reset transparency switches. phx17329 -- mishandling empty acls. phx17310 -- unitialized variables in cross-dumping. phx16651 -- rqovers on the map do not always get to level 2. phx13714 -- catching command_ /****^ HISTORY COMMENTS: 1) change(86-06-16,Lippard), approve(86-06-02,MCR7427), audit(86-06-16,Farley), install(86-06-17,MR12.0-1077): To not use status_for_backup.(actime actind). 2) change(86-10-15,GWMay), approve(86-10-15,MCR7320), audit(86-11-19,GDixon), install(86-11-21,MR12.0-1223): changed to return a fatal error to the caller when a tape error occurs. 3) change(87-07-15,GDixon), approve(87-07-15,MCR7617), audit(87-07-16,RBarstad), install(87-07-16,MR12.1-1040): Modified for change to backup_record_types.incl.pl1. END HISTORY COMMENTS */ /* format: style4,delnl,insnl,ifthenstmt,ifthen */ backup_dump_recurse: proc (A_cross_dump_dn, A_cross_dump_en, P_force_dump, Sfatal_error, A_code); dcl P_force_dump bit (1) aligned parameter; /* ON => dump this entry no matter what */ dcl A_code fixed binary (35); /* returned non-zero if dump aborted */ dcl Sfatal_error bit (1) aligned; /* used to signal a fatal tape error */ /* there are other errors which will */ /* stop only the current line in the */ /* control file from being dumped */ /* For those, the flag should not be set */ dcl (i, j, used) fixed binary, /* temporary storage */ retry_count fixed bin, code fixed bin (35), ignore fixed bin (35), /* ignored error code */ found fixed bin, /* Used in restarting a dump */ (havent_output_dirname, found_object) bit (1) aligned, (bc, lc, dircount, curl, name_len) fixed binary, (np, bp, lp, hnp, hbp, aclp, ix, jx) pointer, pp pointer, /* used within an incl file */ nssp ptr, /* -> bk_nss_info struct, in area */ dqip ptr, /* -> bk_dq_info struct, in area */ (dtd, dtu, dtem, dtsm, cutoff_time) fixed binary (52), /* Temporaries for date-time values. */ blocks fixed binary (9), ring fixed bin (3), ac_stg char (256), /* converted access class */ ac_stg_octal character (32) aligned, name_line char (200), /* dir name followed by access class */ sv_label label; dcl (A_cross_dump_dn, cross_dump_dn, restore_dn) char (168); dcl (A_cross_dump_en, cross_dump_en, restore_en, temp_en) char (32); dcl (restore_dlen, restore_elen) fixed bin; dcl ( incr_sw, incr_sw_set init ("0"b) ) bit (1) int static; dcl initialize static bit (1) initial ("1"b), /* Static storage. */ (header_areap, list_areap, hdp) static pointer, /* Pointers to selected items in headers. */ br_size fixed binary static, /* Number of words in branch info. */ 1 ksta aligned like kst_attributes static; dcl mover (curl) based; /* For fast block moves. */ dcl ( error_table_$ai_restricted, error_table_$device_attention, error_table_$segknown, error_table_$moderr, error_table_$noentry, error_table_$root ) fixed binary (35) external; /* error code. */ dcl sys_info$seg_size_256K fixed bin (19) external, sys_info$page_size fixed bin ext static, max_length_list_area fixed bin (19) static, max_length_header_area fixed bin (19) static; dcl old_alloc_ entry (fixed bin, ptr, ptr), old_area_ entry (fixed bin (19), ptr), mdc_$find_volname entry (bit (36) aligned, char (*) aligned, char (*) aligned, fixed bin (35)), aim_check_$greater_or_equal entry (bit (72) aligned, bit (72) aligned) returns (bit (1) aligned), convert_authorization_$to_string_short entry (bit (72) aligned, char (*), fixed bin (35)), convert_aim_attributes_ entry (bit (72) aligned, char (32) aligned), expand_pathname_ entry (char (*), char (*) aligned, char (*) aligned, fixed bin (35)), ( hcs_$list_acl, hcs_$list_dir_acl ) ext entry (char (*) aligned, char (*) aligned, ptr, ptr, ptr, fixed bin, fixed bin (35)), hcs_$get_max_length entry (char(*), char(*), fixed bin(19), fixed bin(35)), hcs_$get_max_length_seg entry (ptr, fixed bin(19), fixed bin(35)), hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)), hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$list_dir entry (char (*) aligned, (*) fixed bin, ptr, fixed bin, ptr, fixed bin, fixed bin (35)), hcs_$quota_get entry (char (*) aligned, fixed bin, fixed bin (35), fixed bin (35), fixed bin, fixed bin (1), fixed bin, fixed bin (35)), hcs_$dir_quota_read entry (char (*) aligned, fixed bin, fixed bin (71), bit (36) aligned, fixed bin, fixed bin (1), fixed bin, fixed bin (35)), hcs_$get_access_class entry (char (*) aligned, char (*) aligned, bit (72) aligned, fixed bin (35)), hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed bin (1), ptr, ptr, fixed bin (35)), pathname_ entry (char (*), char (*)) returns (char (168)), phcs_$deactivate entry (ptr, fixed bin (35)), hphcs_$set_kst_attributes entry (fixed bin (17), ptr, fixed bin (35)), hphcs_$set_backup_dump_time entry (char (*) aligned, char (*) aligned, fixed bin (52), fixed bin (35)), hcs_$terminate_noname entry (ptr, fixed bin (35)), hcs_$list_inacl_all entry (char (*) aligned, ptr, ptr, ptr, fixed bin (35)), hcs_$status_for_backup entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)), ioa_$rsnnl entry options (variable); dcl infoptr ptr; dcl 1 inacl_info based aligned, 2 sia_relp (0:7) bit (18), 2 sia_count (0:7) fixed bin, 2 dia_relp (0:7) bit (18), 2 dia_count (0:7) fixed bin; %include status_for_backup; dcl 1 bks aligned automatic like status_for_backup; dcl backup_map_$detail_line2 entry (char (32) aligned, fixed bin (9), char (10) aligned, fixed bin (52), fixed bin (52), fixed bin (52), fixed bin (52), fixed bin (52)), backup_map_$error_line entry () options (variable), backup_map_$fs_error_line entry (fixed bin (35), char (*) aligned, char (*) aligned, char (*) aligned), ( backup_map_$directory_line, backup_map_$name_line ) entry (ptr, fixed bin), bk_output$wr_tape entry (ptr, fixed bin (18), ptr, fixed bin, fixed bin (35)); dcl sort_branches entry (ptr, fixed bin) external; dcl (addr, addrel, baseno, binary, bit, divide, fixed, index, length) builtin; dcl (max, min, null, pointer, ptr, rel, rtrim, substr, unspec) builtin; dcl clock builtin; dcl size builtin; /* INITIALIZE */ if initialize then do; /* Is this the first time? */ bp = null; /* Compute branch info size. */ br_size = fixed (rel (addr (bp -> br (2))), 18) - fixed (rel (bp), 18); header_areap = addr (bk_ss_$hp -> h.list_area); /* Compute pointers to areas in headers. */ list_areap = addr (bk_ss_$areap -> h.list_area); /* .. */ call hcs_$get_max_length_seg (list_areap, max_length_list_area, code); if code ^= 0 then do; call backup_map_$fs_error_line (code, "get_max_length_seg", "list_areap", ""); go to terminate_dump; end; call hcs_$get_max_length_seg (header_areap, max_length_header_area, code); if code ^= 0 then do; call backup_map_$fs_error_line (code, "get_max_length_seg", "header_areap", ""); go to terminate_dump; end; hdp = addr (bk_ss_$hp -> h.dname); /* Get pointer to directory name. */ bk_ss_$areap -> h.elen = 0; /* No entry name in "directory list" records. */ bk_ss_$areap -> h.ename = ""; bk_ss_$areap -> h.record_type = ndc_directory_list; /* Set up type code. */ unspec (ksta) = "0"b; ksta.set.tms, ksta.value.tms = "1"b; ksta.set.tus, ksta.value.tus = "1"b; ksta.set.tpd, ksta.value.tpd = "1"b; ksta.set.explicit_deactivate_ok, ksta.value.explicit_deactivate_ok = "1"b; ksta.set.allow_write = "1"b; ksta.value.allow_write = "0"b; initialize = ""b; end; retry_count = 0; retry_dump: cross_dump_dn = A_cross_dump_dn; cross_dump_en = A_cross_dump_en; A_code = 0; havent_output_dirname = "1"b; bk_ss_$hp -> h.elen = 0; /* Reset entry name to null. */ bk_ss_$hp -> h.ename = ""; sv_label = bk_ss_$err_label; /* save previous error return label */ bk_ss_$err_label = dump_rtn; /* set up error return label variable */ call old_area_ (max_length_list_area - 128, list_areap); /* initialize empty area */ bk_ss_$areap -> h.dtd = clock (); /* Get time data gathered. */ bk_ss_$error = 2; /* Inform idump_signal to expect signals. */ /* LIST THE DIRECTORY */ call hcs_$list_dir (bk_ss_$hp -> h.dname, bk_ss_$areap -> h.list_area, bp, bc, lp, lc, code); bk_ss_$error = 0; /* Signals are now fatal again. */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "list_dir", bk_ss_$hp -> h.dname, ""); if bk_ss_$tapesw | bk_ss_$mapsw then go to dump_rtn; /* Are we still doing something? */ terminate_dump: if code = error_table_$device_attention & retry_count < 3 then do; retry_count = retry_count + 1; go to retry_dump; end; if code = 0 then code = 1; A_code = code; go to dump_rtn; end; if bk_ss_$namesw then do; /* we are dumping only a single record */ found_object = "0"b; go to do_it; end; if bk_ss_$pvsw then go to do_it; /* only dump segments for pv dump */ if bk_ss_$restart_dumpsw then do; /* Find comparison name for restart */ found = 0; i = index (substr (bk_ss_$restart_path, bk_ss_$rlen + 1, bk_ss_$restart_plen), ">"); /* Find next ">" */ if i > 0 then do; /* Found one */ bk_ss_$ename = substr (bk_ss_$restart_path, bk_ss_$rlen + 1, i - 1); /* Save compare name */ bk_ss_$rlen = bk_ss_$rlen + i; /* Reset restart length */ end; else do; bk_ss_$ename = substr (bk_ss_$restart_path, bk_ss_$rlen + 1, bk_ss_$restart_plen - bk_ss_$rlen); bk_ss_$rlen = 0; /* This signals last name */ end; end; cross_dump_dn = pathname_ (A_cross_dump_dn, A_cross_dump_en); if bk_ss_$tapesw then do; /* Is tape writing enabled? */ bk_ss_$areap -> h.dlen = bk_ss_$hp -> h.dlen;/* Copy directory name */ bk_ss_$areap -> h.dname = bk_ss_$hp -> h.dname; if bc > 0 then bk_ss_$areap -> h.bp = rel (bp); /* Set up pointers in header if not garbage. */ bk_ss_$areap -> h.bc = bc; /* Set up counts. */ if lc > 0 then bk_ss_$areap -> h.lp = rel (lp); bk_ss_$areap -> h.lc = lc; bk_ss_$areap -> h.aclc = 0; /* Indicate no CACL. */ bk_ss_$areap -> h.aclp = ""b; /* GET ACCESS CLASS AND VOLUME INFO */ bk_ss_$areap -> h.nss_info_relp = "0"b; bk_ss_$error = 20; unspec (bks) = ""b; bks.version = status_for_backup_version_2; call hcs_$status_for_backup (bk_ss_$hp -> h.dname, "", addr (bks), code); /* get access class */ bk_ss_$error = 0; if code ^= 0 then if code = error_table_$root then do; bks.access_class = "0"b; /* root starts low */ bks.switches.multiple_class = "0"b; end; else do; call backup_map_$fs_error_line (code, "hcs_$status_for_backup", bk_ss_$hp -> h.dname, ""); go to terminate_dump; end; else do; curl = size (bk_nss_info); call old_alloc_ (curl, list_areap, nssp); bk_ss_$areap -> h.nss_info_relp = rel (nssp); nssp -> bk_nss_info.version = 1; nssp -> bk_nss_info.lvid = bks.lvid; nssp -> bk_nss_info.pvid = bks.pvid; call mdc_$find_volname (bks.pvid, nssp -> bk_nss_info.pvname, nssp -> bk_nss_info.lvname, ignore); end; if bk_ss_$upgrade_to_user_auth then /* dump segment at user's authorization (hopefully >= access class) */ bks.access_class = bk_ss_$user_authorization; bk_ss_$areap -> h.switches = bks.switches; bk_ss_$areap -> h.access_class = bks.access_class; bk_ss_$areap -> h.status_version = bks.version; /* pass thru version for reloader */ /* GET THE INITIAL ACLS */ infoptr = addr (bk_ss_$areap -> h.inaclp (0)); bk_ss_$error = 4; call hcs_$list_inacl_all (bk_ss_$hp -> h.dname, list_areap, aclp, infoptr, code); bk_ss_$error = 0; if code ^= 0 then do; call backup_map_$fs_error_line (code, "hcs_$list_inacl_all", bk_ss_$hp -> h.dname, ""); if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump; unspec (infoptr -> inacl_info) = ""b; end; else do; /* make ia_relp's relative to base of seg */ do ring = 0 to 7; if infoptr -> inacl_info.sia_count (ring) ^= 0 then infoptr -> inacl_info.sia_relp (ring) = rel (addrel (aclp, infoptr -> inacl_info.sia_relp (ring))); if infoptr -> inacl_info.dia_count (ring) ^= 0 then infoptr -> inacl_info.dia_relp (ring) = rel (addrel (aclp, infoptr -> inacl_info.dia_relp (ring))); end; end; /* GET QUOTA AND ACCOUNTING INFO. */ bk_ss_$error = 6; /* Set up to try error recovery. */ call hcs_$quota_get (bk_ss_$hp -> h.dname, bk_ss_$areap -> h.quota, bk_ss_$areap -> h.trp, bk_ss_$areap -> h.tlu, bk_ss_$areap -> h.inf_acct, bk_ss_$areap -> h.term_acct, used, code); bk_ss_$error = 0; /* Clear recovery indicator. */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "quota_get", bk_ss_$hp -> h.dname, ""); bk_ss_$areap -> h.quota, bk_ss_$areap -> h.trp, bk_ss_$areap -> h.tlu, bk_ss_$areap -> h.inf_acct, bk_ss_$areap -> h.term_acct = 0; end; curl = size (bk_dq_info); call old_alloc_ (curl, list_areap, dqip); /* make room for dirquota */ bk_ss_$areap -> h.dq_info_relp = rel (dqip); /* set relp for reloader */ dqip -> bk_dq_info.version = 1; bk_ss_$error = 21; /* Set up to try error recovery. */ call hcs_$dir_quota_read (bk_ss_$hp -> h.dname, dqip -> bk_dq_info.quota, dqip -> bk_dq_info.ltrp, dqip -> bk_dq_info.tlu, dqip -> bk_dq_info.inf_acct, dqip -> bk_dq_info.term_acct, used, code); bk_ss_$error = 0; /* Clear recovery indicator. */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "dir_quota_read", bk_ss_$hp -> h.dname, ""); bk_ss_$areap -> h.dq_info_relp = ""b; end; /* WRITE OUT THE PREAMBLE, LIST_DIR AND ACCOUNTING INFO for a DIRECTORY */ cross_dump_en = ""; call output (bk_ss_$areap, null, 0, code); if code ^= 0 then go to terminate_dump; end; if bk_ss_$mapsw then do; /* if map option is on */ if ^bk_ss_$tapesw then do; /* get access class if -notape */ call hcs_$get_access_class (bk_ss_$hp -> h.dname, "", bks.access_class, code); if code ^= 0 then bks.access_class = "0"b; end; if bks.access_class ^= "0"b then do; /* format access class */ call convert_authorization_$to_string_short (bks.access_class, ac_stg, code); if code ^= 0 then do; /* couldn't get the conversion */ call convert_aim_attributes_ (bks.access_class, ac_stg_octal); ac_stg = ac_stg_octal; end; call ioa_$rsnnl ("^a[ac:^a]", name_line, name_len, bk_ss_$hp -> h.dname, ac_stg); call directory_line (addr (name_line), name_len); end; else call directory_line (hdp, bk_ss_$hp -> h.dlen); end; /* PROCESS THE BRANCHES */ do_it: if bc >= 15 then call sort_branches (bp, bc); /* sort the branches in order of primary name */ else call sort_small (bp, bc); bk_ss_$err_label = skip_branch; /* Set up label for skipping segments. */ bk_ss_$hp -> h.lp = ""b; /* Reset link pointer. */ bk_ss_$hp -> h.lc = 0; /* Reset link count. */ bk_ss_$hp -> h.bc = 1; /* Set branch count. */ dircount = 0; if ^incr_sw_set then do; if bk_ss_$myname ^= "backup_dump" & bk_ss_$myname ^= "backup_dump_" then incr_sw = "1"b; else incr_sw = "0"b; incr_sw_set = "1"b; end; /* GET TIMES AND COMPARE FOR OUTPUTTING */ do i = 1 to bc; /* scan through all branches */ ix = pointer (bp, bp -> br (i).ix); /* Get effective index. */ np = pointer (bp, ix -> br (1).namerp); /* Get pointer to names. */ if bk_ss_$namesw /* Are we looking to dump a single branch? */ then do; do j = 1 to binary (ix -> br (1).nnames, 17, 0); if (bk_ss_$ename = np -> name (j).string) then do; found_object = "1"b; go to dump_me; end; end; go to skip_branch; /* here iff no match */ end; else if bk_ss_$restart_dumpsw /* only if dumping more than branches */ then if bk_ss_$ename > np -> name (1).string then go to skip_branch; /* skip all already dumped */ else if found > 0 /* Passed dir or branches already dumped */ then if ^ix -> br (1).dirsw then go to skip_branch; /* only want dirs till last level */ else ; else if bk_ss_$ename = np -> name (1).string /* Found it? */ then if bk_ss_$rlen = 0 then bk_ss_$restart_dumpsw = ""b; /* Done restarting, normal dump */ else found = 1; /* Found it but continue restart to lower level */ else if bk_ss_$rlen = 0 then bk_ss_$restart_dumpsw = ""b; /* Done restarting */ else found = 2; /* Didn't find name, beyond it. Bad dir. End restart */ dump_me: if incr_sw then /* incremental dumps ignore ring 0 */ if ix -> br (1).rb2 = "0"b then go to skip_branch; if ix -> br (1).vtoc_error then begin; /* handle vtoc error case */ dcl 1 brst like branch_status aligned; dcl mxl fixed bin (19); dcl cleanup condition; on cleanup ; /* Force non-quick */ np = ptr (bp, ix -> br (1).namerp); /* Get names ptr */ bk_ss_$error = 40; call hcs_$status_long (bk_ss_$hp -> h.dname, np -> name (1).string, 0, addr (brst), null (), code); bk_ss_$error = 0; if code = 0 then do; /* Lucked out */ ix -> br (1).cl = bit (fixed (fixed (brst.current_length, 12), 9), 9); ix -> br (1).dtu = brst.date_time_used; ix -> br (1).dtm = brst.date_time_modified; call hcs_$get_max_length ((bk_ss_$hp -> h.dname), (np -> name (1).string), mxl, code); if code = 0 then ix -> br (1).ml = bit (divide (mxl, sys_info$page_size, 9, 0), 9); end; if code ^= 0 then do; /* Could be bad from max-length */ call backup_map_$fs_error_line (code, "VTOCE error on segment", bk_ss_$hp -> h.dname, np -> name (1).string); go to skip_branch; end; end; if bk_ss_$pvsw & ix -> br (1).dirsw then do; /* skip dirs on pvdump (must still count) */ dircount = dircount + 1; go to skip_branch; end; dtem = fixed (ix -> br (1).dtbm, 52); /* Extract modification times. */ dtsm = fixed (ix -> br (1).dtm, 52); dtd = fixed (ix -> br (1).dtd, 52); /* Extract time last dumped. */ ix -> br (1).dump_me = ""b; /* Clear dump indicator. */ if bk_ss_$datesw then do; /* Are we dumping by date? */ if bk_ss_$dtdsw then /* Are we dumping by dtd as well? */ cutoff_time = min (bk_ss_$date, dtd); /* Get earliest cutoff time. */ else cutoff_time = bk_ss_$date; /* By date, get it. */ go to compare; /* Go compare criteria. */ end; if bk_ss_$dtdsw then do; /* Are we dumping only by dtd? */ cutoff_time = dtd; /* Get cutoff time. */ compare: if ^P_force_dump then /* don't have to dump this branch unless ... */ if max (dtem, dtsm) < cutoff_time then go to skip_branch; end; /* ... it has changed since last time */ /* STORE RECORD TYPE IN PREAMBLE HEADER */ if bk_ss_$enforce_max_access_class | bk_ss_$enforce_min_access_class | bk_ss_$dont_dump_upgraded_dirs | bk_ss_$check_effective_access then call perform_access_checks (); /* only returns if OK ... */ ix -> br (1).dump_me = "1"b; /* Dumpable, set indicator. */ if ix -> br (1).dirsw then do; /* Is this a directory? */ dircount = dircount + 1; /* Count directory branches. */ bk_ss_$hp -> h.record_type = sec_dir; /* Insert record type in header. */ end; else bk_ss_$hp -> h.record_type = sec_seg; /* Insert record type in header. */ blocks = min (fixed (ix -> br (1).cl, 9), divide (sys_info$seg_size_256K + sys_info$page_size - 1, sys_info$page_size, 17, 0)); /* Get current length (in 1024-word blocks) */ nnames = fixed (ix -> br (1).nnames, 17); /* Extract number of names. */ bk_ss_$hp -> h.dtd = clock (); /* Get time this branch processed. */ /* SET UP THE PREAMBLE */ call old_area_ (max_length_header_area - 128, header_areap); /* Reset and reinitialize buffer area. */ call old_alloc_ (br_size, header_areap, hbp);/* Make room for branch in preamble. */ bk_ss_$hp -> h.bp = rel (hbp); /* Insert pointer to it in preamble. */ curl = br_size; hbp -> mover = ix -> mover; /* Compute number of words taken by name array. */ curl = fixed (rel (addr (np -> name (nnames + 1))), 18) - fixed (rel (np), 18); call old_alloc_ (curl, header_areap, hnp); /* Make room for the names. */ hbp -> br (1).namerp = rel (hnp); /* Insert pointer to name list. */ hnp -> mover = np -> mover; if bk_ss_$namesw & bk_ss_$no_primary then do;/* put on tape name user supplied */ bk_ss_$hp -> h.elen = length (rtrim (bk_ss_$ename)); bk_ss_$hp -> h.ename = bk_ss_$ename; end; else do; bk_ss_$hp -> h.elen = length (rtrim (np -> name (1).string)); bk_ss_$hp -> h.ename = np -> name (1).string; end; bk_ss_$hp -> h.nss_info_relp = ""b; /* assume volid's not known */ bk_ss_$error = 11; /* Enable error recovery attempt */ unspec (bks) = ""b; bks.version = status_for_backup_version_2; call hcs_$status_for_backup (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, addr (bks), code); bk_ss_$error = 0; /* Disable error recovery */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "hcs_$status_for_backup", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename); /* Now zero or default all fields */ unspec (bks) = ""b; bks.author = ""; bks.bc_author = ""; end; else do; curl = size (bk_nss_info); call old_alloc_ (curl, header_areap, nssp); bk_ss_$hp -> h.nss_info_relp = rel (nssp); nssp -> bk_nss_info.version = 1; nssp -> bk_nss_info.lvid = bks.lvid; nssp -> bk_nss_info.pvid = bks.pvid; call mdc_$find_volname (bks.pvid, nssp -> bk_nss_info.pvname, nssp -> bk_nss_info.lvname, ignore); if bk_ss_$pvsw & bk_ss_$pvname ^= nssp -> bk_nss_info.pvname then go to skip_branch; end; if bk_ss_$upgrade_to_user_auth then /* dump segment at user's authorization (hopefully >= access class) */ bks.access_class = bk_ss_$user_authorization; if bk_ss_$tapesw then do; bk_ss_$hp -> h.status_version = bks.version; /* pass thru version so reloader knws how much to believe */ bk_ss_$hp -> h.actime = ""b; bk_ss_$hp -> h.actind = ""b; /* with NSS, maxl on page bndry */ bk_ss_$hp -> h.max_length = fixed (ix -> br (1).ml) * sys_info$page_size; bk_ss_$hp -> h.switches = bks.switches; bk_ss_$hp -> h.entrypt_bound = bks.entrypt_bound; addr (bk_ss_$hp -> h.quota) -> author = bks.author; /* is quota only for dir_list recs */ bk_ss_$hp -> h.bitcount_author = bks.bc_author; bk_ss_$hp -> h.switches.multiple_class = bks.switches.multiple_class; bk_ss_$hp -> h.access_class = bks.access_class; bk_ss_$error = 7; /* Enable error recovery for reading ACL. */ if ix -> br (1).dirsw then call hcs_$list_dir_acl (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, header_areap, aclp, null (), bk_ss_$hp -> h.aclc, code); else call hcs_$list_acl (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, header_areap, aclp, null (), bk_ss_$hp -> h.aclc, code); bk_ss_$error = 0; /* Disable error recovery attempts. */ if code ^= 0 then do; call backup_map_$fs_error_line (code, "hcs_$list_acl", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename); if code = error_table_$noentry then go to skip_branch; bk_ss_$hp -> h.aclc = 0; /* Indicate no ACL. */ bk_ss_$hp -> h.aclp = ""b; end; else if bk_ss_$hp -> h.aclc > 0 then /* Are we safe from evaluating garbage? */ bk_ss_$hp -> h.aclp = rel (aclp); /* Yes, insert pointer to it. */ bk_ss_$hp -> h.bitcnt = fixed (ix -> br (1).bc, 24); /* pick up segment bit count */ /* WRITE THE PREAMBLE IF A DIRECTORY -- this is the branch info for a directory */ if ix -> br (1).dirsw then do; if bk_ss_$namesw then cross_dump_en = A_cross_dump_en; else cross_dump_en = np -> name (1).string; call output (bk_ss_$hp, null, 0, code); if code ^= 0 then go to terminate_dump; end; else do; /* Non-directory segment. */ bk_ss_$error = 8; /* Enable error recovery attempt. */ call hcs_$initiate (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, "", 0, 1, bk_ss_$segptr, code); bk_ss_$error = 0; /* Disable error recovery. */ if code ^= 0 then if code ^= error_table_$segknown then do; call backup_map_$fs_error_line (code, "initiate", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename); if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump; /* Still doing anything? */ go to skip_branch; /* Yes, just skip this branch. */ end; else ; else if ^bk_ss_$debugsw then call hphcs_$set_kst_attributes (binary (baseno (bk_ss_$segptr), 18), addr (ksta), (0)); /* unless we use it treat carefully */ bk_ss_$wasnt_known = "1"b; /* We have pointer to segment. */ curl = min (blocks * sys_info$page_size, bk_ss_$hp -> h.max_length); /* get length of segment in words */ /* OUTPUT PREAMBLE (branch info) AND DATA SEGMENT IF NOT A DIRECTORY */ /* NOTE: a ptr to the segment is passed to bk_output which will copy one record */ /* at a time into a one record buffer, and then write the buffer to tape. */ /* Formerly the whole segment was copied at once to the buffer, and then */ /* the whole buffer was written. Now, if a user deletes the segment during */ /* one of the mini-copys, bk_output will write zeroes for the rest of the */ /* segment. (Iff that happens the fault catcher will have reset bk_ss_$wasnt_known.) */ /* It is known that this strategy will cause fewer page faults on the buffer */ /* and in addition reduce backups working set. It may also be advantageous */ /* that page faults from disk are more spread out, rather than coming in bursts. */ /* It may be that a two record buffer would be more efficiently written to tape */ /* while still maintaining a small working set---but the needed metering */ /* has not been pursued. REM */ cross_dump_en = np -> name (1).string; call output (bk_ss_$hp, bk_ss_$segptr, curl, code); /* Write segment out. */ if code ^= 0 then go to terminate_dump; if ^bk_ss_$wasnt_known then /* fault & termination must have occured */ go to terminate_branch; /* forget about this segment */ bk_ss_$wasnt_known = ""b; /* Reset indicator for safety. */ bk_ss_$error = 10; /* Enable error recovery attempt. */ if ^bk_ss_$debugsw then call phcs_$deactivate (bk_ss_$segptr, (0)); /* try to deactivate it */ call hcs_$terminate_noname (bk_ss_$segptr, code); /* Terminate original segment. */ bk_ss_$error = 0; /* Disable error recovery. */ if code ^= 0 then call backup_map_$fs_error_line (code, "hcs_$terminate_noname", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename); end; if ix -> br (1).dirsw /* Is this a directory? */ then ix -> br (1).dtd = bit (bk_ss_$hp -> h.dtd, 52); /* Yes, stash the time the dump started. */ else call set_dtd (bk_ss_$hp -> h.dname, bk_ss_$hp -> h.ename, bk_ss_$hp -> h.dtd, 30); end; if bk_ss_$mapsw then do; if bk_ss_$pvsw & havent_output_dirname then do; /* identify the directory we are in */ call directory_line (hdp, bk_ss_$hp -> h.dlen); havent_output_dirname = "0"b; end; dtu = fixed (ix -> br (1).dtu, 52); if A_cross_dump_dn ^= "" then temp_en = cross_dump_en; else temp_en = np -> name (1).string; call backup_map_$detail_line2 ((temp_en), blocks, RECORD_TYPE (bk_ss_$hp -> h.record_type), bk_ss_$hp -> h.dtd, dtem, dtd, dtu, dtsm); do j = 2 to nnames; /* Write all the entry names. */ if ^bk_ss_$mapsw then go to terminate_branch; jx = addr (np -> name (j)); call backup_map_$name_line (addr (jx -> name (1).string), fixed (jx -> name (1).size, 17)); end; terminate_branch: if ^(bk_ss_$tapesw | bk_ss_$mapsw) then go to terminate_dump; /* Still doing something? */ end; skip_branch: end; /* PROCESS INFERIOR DIRECTORIES */ if bk_ss_$restart_dumpsw & found = 2 then bk_ss_$restart_dumpsw = ""b; /* Finish restart for this level then normal dump */ if bk_ss_$namesw then do; if ^found_object then do; code = error_table_$noentry; call backup_map_$fs_error_line (code, "Searching for object.", bk_ss_$hp -> h.dname, bk_ss_$ename); end; go to terminate_dump; end; if ^bk_ss_$onlysw & dircount > 0 /* dump inferior directories */ then call dir_scan (dircount); dump_rtn: bk_ss_$err_label = sv_label; /* restore error label */ return; /* Return to caller. */ /* */ /* Performs several access checks required by IMFT */ perform_access_checks: procedure (); dcl the_dirname character (168); dcl the_ename character (32); dcl (other_access_class_text, object_access_class_text) character (256); dcl access_class_octal character (32) aligned; dcl object_access_class bit (72) aligned; dcl (code, aim_code) fixed binary (35); dcl user_mode fixed binary (5); the_dirname = bk_ss_$hp -> h.dname; /* makes life simpler */ if bk_ss_$namesw & bk_ss_$no_primary then /* use name provided by user */ the_ename = bk_ss_$ename; else the_ename = np -> name (1).string; /* random branch in a subtree: use primary name */ call hcs_$get_access_class ((the_dirname), (the_ename), object_access_class, code); if code ^= 0 then do; call backup_map_$error_line (code, bk_ss_$myname, "Getting access class of ^a.", pathname_ (the_dirname, the_ename)); go to skip_branch; end; if bk_ss_$enforce_max_access_class then if ^aim_check_$greater_or_equal (bk_ss_$maximum_access_class, object_access_class) then do; call convert_authorization_$to_string_short (bk_ss_$maximum_access_class, other_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (bk_ss_$maximum_access_class, access_class_octal); other_access_class_text = access_class_octal; end; call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (object_access_class, access_class_octal); object_access_class_text = access_class_octal; end; call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname, "Access class of ^a (^[^a^;^ssystem_low^]) exceeds the maximum permitted for this dump (^[^a^;^ssystem_low^]).", pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text, (other_access_class_text ^= ""), other_access_class_text); go to skip_branch; end; if bk_ss_$enforce_min_access_class then if ^aim_check_$greater_or_equal (object_access_class, bk_ss_$minimum_access_class) then do; call convert_authorization_$to_string_short (bk_ss_$minimum_access_class, other_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (bk_ss_$minimum_access_class, access_class_octal); other_access_class_text = access_class_octal; end; call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (object_access_class, access_class_octal); object_access_class_text = access_class_octal; end; call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname, "Access class of ^a (^[^a^;^ssystem_low^]) is below the minimum permitted for this dump (^[^a^;^ssystem_low^]).", pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text, (other_access_class_text ^= ""), other_access_class_text); go to skip_branch; end; if bk_ss_$dont_dump_upgraded_dirs & (ix -> br (1).dirsw) then if ^aim_check_$greater_or_equal (bk_ss_$maximum_dir_access_class, object_access_class) then do; call convert_authorization_$to_string_short (bk_ss_$maximum_dir_access_class, other_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (bk_ss_$maximum_dir_access_class, access_class_octal); other_access_class_text = access_class_octal; end; call convert_authorization_$to_string_short (object_access_class, object_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (object_access_class, access_class_octal); object_access_class_text = access_class_octal; end; call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname, "Access class of ^a (^[^a^;^ssystem_low^]) exceeds the maximum permitted for a directory for this dump (^[^a^;^ssystem_low^]).", pathname_ (the_dirname, the_ename), (object_access_class_text ^= ""), object_access_class_text, (other_access_class_text ^= ""), other_access_class_text); go to skip_branch; end; if bk_ss_$check_effective_access then do; call hcs_$get_user_effmode (the_dirname, the_ename, bk_ss_$user_id, bk_ss_$user_ring, user_mode, code); if code ^= 0 then do; call backup_map_$error_line (code, bk_ss_$myname, "Attempting to determine ^a's access to ^a.", bk_ss_$user_id, pathname_ (the_dirname, the_ename)); go to skip_branch; end; if ^((bit (user_mode, 5) & bit (R_ACCESS_BIN, 5)) = bit (R_ACCESS_BIN, 5)) then do; call backup_map_$error_line (error_table_$moderr, bk_ss_$myname, "^a does not have at least ""^[s^;r^]"" access to ^a.", bk_ss_$user_id, (ix -> br (1).dirsw & (ix -> br (1).bc = ""b)), pathname_ (the_dirname, the_ename)); go to skip_branch; end; if ^aim_check_$greater_or_equal (bk_ss_$maximum_dir_access_class, object_access_class) then do; call convert_authorization_$to_string_short (bk_ss_$user_authorization, other_access_class_text, aim_code); if aim_code ^= 0 then do; /* couldn't convert it: get octal representation */ call convert_aim_attributes_ (bk_ss_$user_authorization, access_class_octal); other_access_class_text = access_class_octal; end; call backup_map_$error_line (error_table_$ai_restricted, bk_ss_$myname, "^a (at authorization ^[^a^;^ssystem_low^]) can not ^[examine^;read^] ^a.", bk_ss_$user_id, (object_access_class_text ^= ""), object_access_class_text, (ix -> br (1).dirsw & (ix -> br (1).bc = ""b)), pathname_ (the_dirname, the_ename)); go to skip_branch; end; end; return; /* here iff everything's OK */ end perform_access_checks; /* */ /* SCAN INFERIOR DIRECTORIES */ dir_scan: procedure (dcount); dcl ( dcount, i, j init (0), save_dlen ) fixed bin, /* Additional temporary storage for dir_scan. */ code fixed bin (35), (ix, jx, np) pointer, /* Declare inside block to speed up execution. */ save_dname character (168) aligned; /* Temporary storage for directory path name. */ dcl 1 save (dcount) aligned, /* One adjustable structure. */ 2 ename character (32), /* temporary storage for directory names */ 2 dtd fixed binary (52); /* Time directory dump began. */ dcl 1 save1 based (jx) aligned, 2 ename character (32), /* temporary storage for directory names */ 2 dtd fixed binary (52); do i = 1 to bc; /* pick up all first directory names */ ix = pointer (bp, bp -> br (i).ix); /* Get effective index. */ if ix -> br (1).dirsw & (ix -> br (1).dump_me | bk_ss_$pvsw) then do; /* Is this a dumpable directory? */ j = j + 1; /* Count directory names. */ jx = addr (save (j)); np = pointer (bp, ix -> br (1).namerp); /* get pointer to directory name array */ jx -> save1.ename = np -> name (1).string; /* Pick up directory entry name. */ jx -> save1.dtd = fixed (ix -> br (1).dtd, 52); /* Copy time directory dump started. */ end; end; save_dlen = bk_ss_$hp -> h.dlen; /* Save current path name length. */ save_dname = bk_ss_$hp -> h.dname; /* Save the name. */ /* DUMP INFERIOR DIRECTORYS */ do i = 1 to j; jx = addr (save (i)); /* Get pointer to structure element. */ call ioa_$rsnnl ("^a^[>^]^a", bk_ss_$hp -> h.dname, bk_ss_$hp -> h.dlen, save_dname, save_dlen ^= 1, jx -> save1.ename); if A_cross_dump_dn = "" then cross_dump_dn, cross_dump_en = ""; else do; cross_dump_dn = pathname_ (A_cross_dump_dn, A_cross_dump_en); cross_dump_en = jx -> save1.ename; end; call backup_dump_recurse (cross_dump_dn, cross_dump_en, "0"b, Sfatal_error, code); if code ^= 0 then do; A_code = code; go to scan_rtn; end; call set_dtd (save_dname, jx -> save1.ename, jx -> save1.dtd, 31); end; scan_rtn: bk_ss_$hp -> h.dlen = save_dlen; /* Restore directory name. */ bk_ss_$hp -> h.dname = save_dname; return; end dir_scan; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ set_dtd: procedure (dirname, ename, dtd, bk_ss_error_value); dcl dirname character (*) aligned parameter; dcl ename character (*) aligned parameter; dcl dtd fixed binary (52) parameter; dcl bk_ss_error_value fixed binary parameter; dcl local_code fixed binary (35); if ^bk_ss_$debugsw then /* don't set DTD without hphcs_ */ if bk_ss_$set_dtd_explicit & bk_ss_$set_dtd then go to SET_DTD; /* caller asked for it */ else if ^bk_ss_$set_dtd_explicit & (bk_ss_$datesw | bk_ss_$dtdsw) then /* otherwise, only set it for incremental dumps */ if bk_ss_$myname ^= "catchup_dump" then /* but never for catchup dumps */ if ^bk_ss_$no_output & bk_ss_$tapesw then do; /* and only if writing a tape */ SET_DTD: bk_ss_$error = bk_ss_error_value; call hphcs_$set_backup_dump_time (dirname, ename, dtd, local_code); bk_ss_$error = 0; if local_code ^= 0 then call backup_map_$fs_error_line (code, "hphcs_$set_backup_dump_time", dirname, ename); end; return; end set_dtd; set_directory_dtd: /* for backup_dump */ entry (P_dirname, P_dtd); dcl P_dirname character (*) aligned parameter; dcl P_dtd fixed binary (52) parameter; begin; dcl dirname character (168) aligned; dcl ename character (32) aligned; call expand_pathname_ ((P_dirname), dirname, ename, (0)); call set_dtd (dirname, ename, P_dtd, 30); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ output: procedure (area_pointer, seg_pointer, seg_count, code);/* Compute preamble length and write record. */ dcl (area_pointer, seg_pointer, p) pointer; dcl seg_count fixed bin, code fixed bin (35), n fixed bin (18); Sfatal_error = "0"b; if A_cross_dump_dn ^= "" then do; /* fake pathname in preamble */ restore_dlen = area_pointer -> h.dlen; restore_dn = area_pointer -> h.dname; restore_elen = area_pointer -> h.elen; restore_en = area_pointer -> h.ename; area_pointer -> h.dname = cross_dump_dn; area_pointer -> h.ename = cross_dump_en; area_pointer -> h.dlen = length (rtrim (area_pointer -> h.dname)); area_pointer -> h.elen = length (rtrim (area_pointer -> h.ename)); end; call old_alloc_ (1, addr (area_pointer -> h.list_area), p); /* Compute length of preamble. */ if p ^= null then n = fixed (rel (p), 18); else if area_pointer = bk_ss_$hp /* Pointer to header area */ then n = max_length_header_area; else n = max_length_list_area; /* Otherwise pointer to list area */ call bk_output$wr_tape (area_pointer, n, seg_pointer, seg_count, code); /* Write the record. */ if code ^= 0 then Sfatal_error = "1"b; if A_cross_dump_dn ^= "" then do; area_pointer -> h.dlen = restore_dlen; area_pointer -> h.dname = restore_dn; area_pointer -> h.elen = restore_elen; area_pointer -> h.ename = restore_en; end; end output; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ directory_line: proc (P_ptr, P_len); dcl P_ptr ptr; dcl P_len fixed bin; if A_cross_dump_dn ^= "" then call backup_map_$directory_line (addr (cross_dump_dn), length (rtrim (cross_dump_dn))); else call backup_map_$directory_line (P_ptr, P_len); end directory_line; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ sort_small: proc (aap, ac); /* Proceedure to shell sort less than 15 branches */ /* Actually sort an array of indices of the branches */ /* Then insert pointers in order of the sorted indices */ dcl (aap, ap, pxk) ptr, ( ac, count, d, i, j, k, n, xj, xk, x (14) ) fixed bin; ap = aap; /* copy args, pointer to branch array */ count = ac; if count = 1 then do; ap -> br (1).ix = rel (addr (ap -> br (1))); return; end; do n = 1 to count; /* loop over all branches */ x (n) = n; /* place index in index list */ end; d = count; /* initialize distance for shell sort */ do; /* do the shell sort */ down: d = 2 * divide (d, 4, 17, 0) + 1; /* set the distance for the sort */ do i = 1 to count - d; k = i + d; /* higher index */ xk = x (k); /* index from index array */ pxk = ptr (ap, ap -> br (xk).namerp); /* pointer for name comparixon */ up: j = k - d; /* lower index */ xj = x (j); /* lower index from index array */ if ptr (ap, ap -> br (xj).namerp) -> name (1).string <= pxk -> name (1).string then go to ok; /* no change if ok */ x (k) = xj; /* swap in index array */ k = j; /* check next lower in steps of size d */ if k > d then go to up; /* if there is a lower element */ ok: x (k) = xk; /* finish, put highest index in its proper place */ end; if d > 1 then go to down; /* sort with smaller distance */ end; do i = 1 to count; /* now thread branches according to index array */ xk = x (i); ap -> br (i).ix = rel (addr (ap -> br (xk))); end; return; end sort_small; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ %include kst_attributes; %include bk_nss_info; %include backup_dir_list; %include backup_fs_times; %include backup_preamble_header; %include backup_record_types; %include bk_ss_; %include branch_status; %include access_mode_values; end backup_dump_recurse;  backup_preattach.pl1 11/15/82 1824.4rew 11/15/82 1505.1 36072 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ backup_preattach: bpa: proc (); /* Hack to preattach bk_ss_$data_iocb */ /* 11/18/80, WOS */ dcl ap pointer; dcl al fixed bin (21); dcl arg char (al) based (ap); dcl (nargs, argno) fixed bin; dcl code fixed bin (35); dcl open_mode fixed bin; dcl attach_desc char (512) varying; dcl iocbp pointer; dcl stream_name char (32); dcl com_err_ entry options (variable); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, pointer, fixed bin (21), fixed bin (35)); dcl iox_$attach_name entry (char (*), pointer, char (*), pointer, fixed bin (35)); dcl iox_$open entry (pointer, fixed bin, bit (1) aligned, fixed bin (35)); dcl iox_$close entry (pointer, fixed bin (35)); dcl iox_$detach_iocb entry (pointer, fixed bin (35)); dcl iox_$destroy_iocb entry (pointer, fixed bin (35)); dcl unique_chars_ entry (bit (*)) returns (char (15)); dcl bk_ss_$data_iocb pointer external static; dcl bk_ss_$preattached bit (1) aligned external static; dcl (error_table_$badopt, error_table_$noarg) fixed bin (35) external static; dcl WHOAMI char (32) internal static options (constant) init ("backup_preattach"); dcl (addr, substr, null) builtin; /* */ call cu_$arg_count (nargs, code); if code ^= 0 then do; call com_err_ (code, WHOAMI); MAIN_RETURN: return; end; if nargs = 0 then do; call com_err_ (error_table_$noarg, WHOAMI, "^/Usage:^-^a open_mode attach_desc^/^2x(or)^-^a -detach", WHOAMI, WHOAMI); goto MAIN_RETURN; end; if nargs = 1 then do; /* Close, or something like that */ call cu_$arg_ptr (1, ap, al, (0)); if (arg = "-close") | (arg = "-detach") then do; if bk_ss_$preattached = "0"b then do; NOT_PREATTACHED: call com_err_ (0, WHOAMI, "Backup I/O is not preattached."); goto MAIN_RETURN; end; bk_ss_$preattached = "0"b; if bk_ss_$data_iocb = null () then goto NOT_PREATTACHED; call iox_$close (bk_ss_$data_iocb, (0)); call iox_$detach_iocb (bk_ss_$data_iocb, (0)); call iox_$destroy_iocb (bk_ss_$data_iocb, (0)); goto MAIN_RETURN; end; else do; call com_err_ (0, WHOAMI, "Unknown control function ^a.", arg); goto MAIN_RETURN; end; end; call cu_$arg_ptr (1, ap, al, (0)); /* Get the opening mode */ if bk_ss_$preattached then do; ALREADY_PREATTACHED: call com_err_ (0, WHOAMI, "Backup I/O is already preattached. Use ^a -detach first.", WHOAMI); goto MAIN_RETURN; end; if arg = "input" then open_mode = Stream_input; else if arg = "output" then open_mode = Stream_output; else do; call com_err_ (0, WHOAMI, "Invalid opening mode ^a. Must be either ""input"" or ""output"".", arg); goto MAIN_RETURN; end; attach_desc = ""; do argno = 2 to nargs; call cu_$arg_ptr (argno, ap, al, (0)); if length (attach_desc) > 0 then attach_desc = attach_desc || " "; attach_desc = attach_desc || arg; end; stream_name = "backup." || unique_chars_ (""b); call iox_$attach_name (stream_name, iocbp, (attach_desc), codeptr (backup_preattach), code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot attach stream."); goto MAIN_RETURN; end; call iox_$open (iocbp, open_mode, "0"b, code); if code ^= 0 then do; call com_err_ (code, WHOAMI, "Cannot open stream."); return; end; bk_ss_$preattached = "1"b; bk_ss_$data_iocb = iocbp; return; %page; %include iox_modes; end backup_preattach;  bk_output.pl1 03/30/87 1135.0r w 03/30/87 1054.1 151614 /****^ *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /****^ HISTORY COMMENTS: 1) change(86-01-01,GWMay), approve(), audit(), install(): old history comments. Coded February 1969, R C Daley. 25 March 1970, R H Campbell. 9/77 by Noel I. Morris to use tape_mult_. 11/9/77 by Steve Herbst Changed to call command_query_ for tape labels 02/28/80 S. Herbst 17 October 1980 by G. Palter to use preattached switches if requested. Fixed to retry correctly after open fails 06/02/81 S. Herbst 84Feb01 by Art Beattie to allow longer tape labels to be used. 1984-03-25, BIM: Use async mode in tape_mult_ 9 May 1985 by G. Palter to not try error_count/unmounts for preattached switches. 2) change(86-06-05,GWMay), approve(86-07-07,MCR7445), audit(86-11-20,GDixon), install(86-11-21,MR12.0-1223): Moved call for "error_count" tally out of the write loop in wrbufout. The result will be that the tape will continue to spin until the entire buffer is emptied rather that synchonizing after each write. This should improve dump time. MCR7320 - added a command loop so that the operator may enter a new tape label id after a bad mount. This way if the wrong tape gets mounted, the operator can deny the mount and give a correct tape id without stopping the dump. END HISTORY COMMENTS */ /* format: style2,idind30,indcomtxt */ bk_output: procedure; dcl uptr ptr; /* ptr to user seg, or junk if we get a fault */ dcl temp fixed bin, /* Temporary storage. */ code fixed bin (35), attach_descrip char (168), buffer pointer, /* Pointer to output line buffer. */ line character (132); /* Output line buffer. */ dcl answer char (64) aligned varying; dcl (primary_dump_tape, secondary_dump_tape) static character (64), /* Tape labels. */ (iocbp1, iocbp2) ptr static, mounted static bit (1) initial (""b), /* Flag to show tape mounted. */ two_tapes bit (1) static, blanks char (4) static init (""), /* To reset tape label */ s character (1) static; /* To make comments plural. */ dcl 1 header static, /* Backup logical record header */ 2 zz1 character (32) initial (" z z z z z z z z z z z z z z z z"), 2 english character (56) initial ("This is the beginning of a backup logical record."), 2 zz2 character (32) initial (" z z z z z z z z z z z z z z z z"), 2 hdrcnt fixed binary, 2 segcnt fixed binary; dcl end_of_tape_encountered static options (constant) char (24) initial ("End of tape encountered."); declare parse_tape_reel_name_ entry (char (*), char (*)), backup_map_$error_line entry options (variable), backup_map_$fs_error_line entry (fixed bin (35), char (*), char (*), char (*)), ( backup_map_$on_line, backup_map_$tapes ) entry (pointer, fixed binary); %include iox_dcls; dcl command_query_ entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl error_table_$action_not_performed fixed bin (35) ext static, error_table_$dev_nt_assnd fixed bin (35) ext static, error_table_$device_end fixed bin (35) ext static; dcl (addr, addrel, divide, length, min, null, mod, rtrim, unspec) builtin; %include query_info; %include iox_modes; %include bk_ss_; %include backup_control; output_init: entry (ntapes, wstat); /* entry to initialize backup output procedure */ dcl ntapes fixed bin; /* 1 or 2 tapes */ if bk_ss_$no_output then do; /* No output */ wstat = 0; /* Error code to zero */ go to exit; /* Quit */ end; buffer = addr (line); /* Set up pointer to output line buffer. */ if bk_ss_$preattached then do; /* caller has requested we use a specific I/O switch */ mounted = "1"b; /* make sure I/O gets done */ two_tapes = "0"b; /* act as if only a single tape is being made */ s = " "; iocbp1 = bk_ss_$data_iocb; wstat = 0; end; else if mounted then wstat = 0; /* reset status code */ else do; /* Mount a new set of tapes. */ if ntapes > 1 & ^bk_ss_$sub_entry then do; /* Decide how many tapes to use. */ two_tapes = "1"b; /* Use two. */ s = "s"; /* Make comments plural. */ end; else if ntapes = 1 then do; two_tapes = ""b; /* Use one. */ s = " "; /* Make comments singular. */ end; call mount (wstat); /* mount first dump tape(s) */ end; if bk_ss_$mapsw then /* Are we writing a map? */ if wstat = 0 then do; /* Yes, did we succeed in attaching the tape(s)? */ if two_tapes then /* Are we writing two tapes? */ call ioa_$rsnnl ("Primary tape label: ^a, secondary tape label: ^a.", line, temp, primary_dump_tape, secondary_dump_tape); else call ioa_$rsnnl ("Tape label: ^a.", line, temp, primary_dump_tape); call backup_map_$tapes (buffer, temp); /* Write the comment in the map. */ end; go to exit; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ output_finish: entry; /* to terminate backup dump */ if bk_ss_$no_output then go to exit; /* No output so quit. */ buffer = addr (line); /* Set up pointer to output line buffer. */ if bk_ss_$preattached then ; /* nothing to do here */ else if bk_ss_$holdsw then do; call iox_$control (iocbp1, "error_count", addr (temp), code); if code ^= 0 then do; /* All OK? */ flush_error: call backup_map_$fs_error_line (code, "bk_output", "", ""); unmo: call unmount; /* Unmount the tape anyway. */ end; if mounted then if two_tapes then do; /* Is the other tape mounted? */ call iox_$control (iocbp2, "error_count", addr (temp), code); if code ^= 0 then go to flush_error; /* OK? */ end; end; else call unmount; /* unmount any reel(s) still mounted */ go to exit; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ wr_tape: entry (lblptr, lblcnt, segptr, segcnt, wstat); /* to write next backup record on tape */ dcl lblptr pointer, /* pointer to preamble area */ lblcnt fixed binary, /* length of preamble in words */ segptr pointer, /* pointer to segment (if any) */ segcnt fixed binary, /* length of segment (if any) in words */ wstat fixed bin (35); /* status code (returned) */ uptr = segptr; /* copy this arg so we can mung it if err */ if bk_ss_$no_output then do; /* No output */ wstat = 0; /* Zero error code */ go to exit; end; if ^mounted then do; wstat = error_table_$dev_nt_assnd; go to exit; end; wstat = 0; buffer = addr (line); /* Set up pointer to output line buffer. */ header.hdrcnt = lblcnt; /* pick up preamble length */ header.segcnt = segcnt; /* and segment length */ retry: call wrout (addr (header), 32); /* write out backup logical record header */ if code = error_table_$device_end then go to enderr; /* Check end of reel */ if code ^= 0 then go to tsterr; temp = header.hdrcnt + 32 + 255; /* adjust to write preamble thru next higher block */ temp = temp - mod (temp, 256) - 32; /* 32 words are already written. */ call wrout (lblptr, temp); /* write out preamble thru next higher 256-word block */ if code = error_table_$device_end then go to enderr; /* Check end of reel */ if code ^= 0 then go to tsterr; if header.segcnt > 0 then do; /* Is there any segment to write? */ temp = header.segcnt; call wrbufout (uptr, temp); /* write out segment thru next higher 256-word block */ if code = error_table_$device_end then go to enderr; /* Check end of reel */ if code ^= 0 then go to tsterr; end; exit: return; /* exit to caller */ enderr: call backup_map_$on_line (addr (end_of_tape_encountered), length (end_of_tape_encountered)); go to unm; /* Go get new reel */ tsterr: call backup_map_$fs_error_line (code, "bk_output", "", ""); unm: if bk_ss_$preattached then do; /* preattached => not using tapes => can't unmount anything */ wstat = code; go to exit; end; call unmount; /* unmount current tape(s) */ call output_init (-1, wstat); /* mount next reel(s) */ if wstat = 0 then go to retry; go to exit; /* go to exit to caller on operator message */ get_label: procedure (type, label, Squit_the_dump); /* Procedure to read label typed on console. */ dcl type character (*), /* Type of tape (primary or secondary). */ label character (64), /* The label. */ Squit_the_dump bit (1) aligned; Squit_the_dump = "0"b; unspec (query_info) = "0"b; query_info.version = query_info_version_4; query_info.suppress_name_sw = "1"b; query_info.question_iocbp, query_info.answer_iocbp = null; call command_query_ (addr (query_info), answer, bk_ss_$myname, "Type ^a dump tape label:", type); label = answer; if label = "quit" | label = "q" then Squit_the_dump = "1"b; else do; if ^bk_ss_$debugsw then /* caller wants privilege */ label = rtrim (label) || ",sys"; end; return; end get_label; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ mount: procedure (mount_status); /* internal procedure to mount first or next reel(s) */ dcl mount_status fixed bin (35); dcl Squit_the_dump bit (1) aligned; mount_status = 0; mounted = "0"b; Squit_the_dump = "0"b; iocbp1, iocbp2 = null; do while (^mounted & ^Squit_the_dump); if bk_ss_$sub_entry then /* get first tape label from tape_entry */ call bk_ss_$control_ptr -> backup_control.tape_entry (primary_dump_tape); else /* else read it from the terminal */ call get_label ("primary", primary_dump_tape, Squit_the_dump); call mount_tape (Squit_the_dump, iocbp1, "bk_output_1", primary_dump_tape, mount_status); end; /* Do we need another tape? */ if two_tapes & mounted & mount_status = 0 then do; mounted = "0"b; do while (^mounted & ^Squit_the_dump); call get_label ("secondary", secondary_dump_tape, Squit_the_dump); call mount_tape (Squit_the_dump, iocbp2, "bk_output_2", secondary_dump_tape, mount_status); end; end; return; mount_tape: proc (Squit, Piocb, switch_name, tape_id, code); dcl Squit bit (1) aligned, Piocb ptr, switch_name char (11), tape_id char (64), code fixed bin (35); code = 0; if Squit then do; code = error_table_$action_not_performed; call backup_map_$error_line (code, "bk_output", "Aborted tape mount."); if iocbp1 ^= null then do; call iox_$close (iocbp1, (0)); call iox_$detach_iocb (iocbp1, (0)); end; return; end; call parse_tape_reel_name_ (tape_id, attach_descrip); call iox_$attach_name (switch_name, Piocb, "tape_mult_ " || attach_descrip || " -write", null (), code); /* null refptr to use user-supplied tape_mult_ */ if code ^= 0 then call backup_map_$fs_error_line (code, "bk_output", tape_id, ""); else do; call iox_$open (Piocb, Stream_output, "0"b, code); if code = 0 then mounted = "1"b; else do; call backup_map_$fs_error_line (code, "bk_output", tape_id, ""); code = 0; call iox_$detach_iocb (Piocb, code); if code ^= 0 then call backup_map_$fs_error_line (code, "bk_output", tape_id, ""); end; end; if code = 0 then call iox_$modes (Piocb, "async", (""), (0)); return; end mount_tape; end mount; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ wrbufout: proc (wrptr, wrcnt); /* internal proc to write user seg to tape */ dcl wrptr ptr; dcl wrcnt fixed bin; dcl ttbuf (words_to_write) fixed bin (35) aligned based; dcl zzbuf (1024) fixed bin (35) aligned based; dcl xptr ptr; dcl words_to_go fixed bin; dcl words_to_write fixed bin; dcl save_err_label label; dcl EC fixed bin (35); /* control order puts count of errors here */ save_err_label = bk_ss_$err_label; /* remember err recovery location */ bk_ss_$err_label = wbo_clean; /* and set up to recover here */ words_to_go = wrcnt; wbo_retry: /* come here from wbo_clean */ xptr = wrptr; do while (words_to_go > 0); words_to_write = min (1024, words_to_go); /* one page at most */ /* then copy a page of users seg */ if wrptr ^= bk_ss_$sp then do; /* if not already recovering from an error */ if words_to_write ^= 1024 then /* if not copying whole page */ unspec (bk_ss_$sp -> zzbuf) = ""b; /* clear the buffer */ bk_ss_$error = 9; /* then copy the user's page */ bk_ss_$sp -> ttbuf = xptr -> ttbuf;/* if fault then will go to wbo_clean */ bk_ss_$error = 0; /* make faults fatal again */ end; words_to_write = 256 * divide (words_to_write + 255, 256, 17, 0); /* write mod 256 */ call iox_$put_chars (iocbp1, bk_ss_$sp, words_to_write * 4, code); if two_tapes & code = 0 /* two_tapes is only true when not preattached */ then call iox_$put_chars (iocbp2, bk_ss_$sp, words_to_write * 4, code); if code ^= 0 then go to wbo_ret; xptr = addrel (xptr, words_to_write); /* step thru user's seg */ words_to_go = words_to_go - words_to_write; /* account for stuff just written */ end; wbo_ret: if ^bk_ss_$preattached & (code = 0) /* preattached => not using tapes => no error_count order */ then do; call iox_$control (iocbp1, "error_count", addr (EC), code); if two_tapes & code = 0 then call iox_$control (iocbp2, "error_count", addr (EC), code); end; bk_ss_$err_label = save_err_label; /* restore error recovery location */ return; /* and return */ wbo_clean: /* This handles faults taken on user's seg */ unspec (bk_ss_$sp -> zzbuf) = ""b; /* clear it */ wrptr = bk_ss_$sp; /* Forget user seg, set flag thatwr're recovering */ bk_ss_$err_label = save_err_label; /* We are no longer interested in faults */ go to wbo_retry; /* Go write zeroes onto tape as needed */ end wrbufout; /* -------------------------------------------------------- */ wrout: procedure (wrptr, wrcnt); /* internal procedure to write on current tape(s) */ dcl wrptr pointer, /* write workspace pointer */ wrcnt fixed binary; /* no. of words to write */ call iox_$put_chars (iocbp1, wrptr, wrcnt * 4, code); if two_tapes then if code = 0 then /* Even if two don't bother if previous in error. */ call iox_$put_chars (iocbp2, wrptr, wrcnt * 4, code); /* Write second tape. */ end wrout; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ unmount: procedure; /* internal procedure to unmount current reel(s) */ if ^mounted then return; call iox_$close (iocbp1, code); if code ^= 0 then call backup_map_$fs_error_line (code, "bk_output", primary_dump_tape, ""); call iox_$detach_iocb (iocbp1, code); if code ^= 0 then call backup_map_$fs_error_line (code, "bk_output", primary_dump_tape, ""); if two_tapes then do; /* Is another tape attached? */ call iox_$close (iocbp2, code); if code ^= 0 then /* Give error comment if close not OK. */ call backup_map_$fs_error_line (code, "bk_output", secondary_dump_tape, ""); call iox_$detach_iocb (iocbp2, code); if code ^= 0 then /* Give error comment if detach not OK. */ call backup_map_$fs_error_line (code, "bk_output", secondary_dump_tape, ""); end; call backup_map_$tapes (addr (blanks), 4); /* Reset label info in map header */ mounted = "0"b; iocbp1, iocbp2 = null; end unmount; end bk_output;  list_err.pl1 11/15/82 1824.4rew 11/15/82 1505.2 174267 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ list_err: proc; /* This program will scan the error file and list, by user within group */ /* which programs MULTICS was not able to access for backup purposes. */ dcl erfil char(32); dcl argptr ptr; dcl arglen fixed bin; dcl arg_string char (arglen) based (argptr); /* ios_declarations */ dcl ios_$attach entry (char(*), char(*), char(*), char(*), bit(72) aligned); dcl hcs_$status_ entry (char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35)); dcl 1 branch aligned, (2 type bit(2), 2 nnames bit (16), 2 nrp bit (18), 2 dtm bit (36), 2 dtu bit (36), 2 mode bit (5), 2 pad1 bit (13), 2 records bit (18)) unaligned; dcl ioa_ entry options (variable); dcl date_time_$fstime entry (bit(36), char(*)); dcl ios_$read entry (char(*), ptr, fixed bin, fixed bin, fixed bin, bit(72) aligned); dcl ioa_$ioa_stream entry options (variable); dcl ios_$detach entry (char(*), char(*), char(*), bit(72) aligned); dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35)); dcl com_err_ entry options (variable); dcl get_wdir_ entry returns (char(168)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin(35)); dcl expand_path_ entry (ptr, fixed bin(17), ptr, ptr, fixed bin(35)); dcl cu_$arg_count entry (fixed bin); /* data items */ dcl (tproj, tname, name_hold) char (32) varying, chase fixed bin(1), (eptr, nreap) ptr, string char(24), nargs fixed bin, (tprog, namep) char(168), dirctp char(168) aligned, real_proj char (tp_len) based (addr (tproj)), real_name char (tn_len) based (addr (tname)), (tp_len, tn_len, tleng, str_len, entree) fixed bin (8), (msg_start, msg_end, msg_length, line_len) fixed bin (8), (scode, code) fixed bin (35), fulpath char(168), sp_line char (120), (die, ab) fixed bin (1), (bufptr, pnamep, dirp, enamep) ptr, nl char (1) aligned static init (" "), nareap fixed bin (24), pnamel fixed bin (17), working_dir char (168), (stch1, stch2, stch3) fixed bin, /* used to segment the input line */ EOF bit (1), /* end of file indicator */ chstr char (4) aligned, /* check for a normal line */ outstr char (168) aligned init ("OUT"), error_table_$noentry external fixed bin (35), error_table_$no_dir external fixed bin (35), (tmesg, tpath) char (168), (status, ostatus) bit (72) aligned, /* did the read or write go OK? */ nelemt fixed bin (17), /* number of elements read in */ (temp1, temp2, temp3) char (100), /* line segmentation areas */ lin char (400) aligned; /* input line */ /* built in functions */ dcl (addr, init, null, before, fixed, length, index, substr) builtin; /* I/O status bits */ dcl 1 sbits aligned based (addr (status)), (2 code bit (36), 2 pad bit (9), 2 eof bit (1), /* end of file bit */ 2 pd2 bit (29)) unal; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Initialize the end-of-file switch to zero. Check the number of arguments passed. If this number is */ /* greater or less than one, the wrong no. of arguments have been passed to this program. In this case */ /* an error message is sent and the program suicides. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ setup: name_hold = ""; EOF = "0"b; call cu_$arg_count (nargs); if nargs ^= 1 then do; call ioa_ ("list_err: Wrong number of arguments."); return; end; call cu_$arg_ptr (1, argptr, arglen, code); erfil = arg_string; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Set up the parameters for a call to expand_path_: a ptr to the path name, the path name length, */ /* a ptr to a place to put the expanded directory name, and a ptr to a place to put the expanded entry name.*/ /* Set up the buffer ptr for ios_$read, set off the "strange_line" switch and blank out the temporary */ /* storage areas for the message and the path name. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ pnamep = addr (erfil); pnamel = length (erfil); dirp = addr (dirctp); enamep = addr (namep); bufptr = addr (lin); ab = 0; tmesg = " "; tpath = " "; erfil = before (erfil, " "); fulpath = (">udd>SysDaemon>error_file>"||erfil); fulpath = before (fulpath, " "); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Attempt to expand the path name of the erfil to an absolute path name. If the attempt fails, a request */ /* is sent to the user to check the path name and try again and the program suicides. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call expand_path_ (pnamep, pnamel, dirp, enamep, code); if code ^= 0 then do; call com_err_ (code, "list_err", "Error in input file name."); return; end; fulpath = (before (dirctp, " ")||">"||erfil); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Using the absolute path name, attempt to attach a stream in order to read the erfil. If the attach fails*/ /* then the processing cannot continue and the program suicides, issuing the appropriate message. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call ios_$attach ("my_input", "file_", fulpath, "r", status); if sbits.code ^= "0"b then do; code = fixed (sbits.code); call com_err_ (code, "list_err", "Attach failed."); go to suicide; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* THIS IS THE START OF THE MAIN LOOP WHICH CYCLES THROUGH THE ERFIL, PROCESSING ONE ENTRY AT A TIME. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ do while (EOF = "0"b); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Blank out the buffer which holds the input line and read a new input line into it. If there was an */ /* error in the read, put out an IO error message and try the next one. Otherwise pick up the line length */ /* from the nelemt parameter of ios_$read. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ read: lin = " "; call ios_$read ("my_input", bufptr, 0, 168, nelemt, status); EOF = sbits.eof; if sbits.code ^= "0"b & EOF = "0"b then do; code = fixed (sbits.code); call com_err_ (code, "list_err", "IO error. Please retry."); go to suicide; end; line_len = nelemt; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Divide the input line into the message and the path name. If the message is Entry not found, ignore */ /* this particular line and go to get the next one. If there is a different message, save it in tmesg then */ /* pick up the path name and save it in tpath. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ line_div: entree = index (lin, "Entry not found."); if entree = 0 then do; msg_start = index (lin, ":"); msg_end = index (lin, ">"); if msg_start ^= 0 then do; msg_length = (msg_end - msg_start) -3; tmesg = substr (lin, (msg_start + 2), msg_length); tpath = substr (lin, msg_end, (line_len - msg_end)); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Check the directory for the standard user_dir_dir. If this is some other directory, then we don't */ /* know what to do with it and the whole line will be written unparsed into a segment called strange line. */ /* If, however this is a user_dir_dir directory, we will pick out the user and the project names and put */ /* them in tname and tproj respectively. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ chstr = substr (tpath, 2, 4); if chstr = "user" then do; norm: tleng = length (tpath); temp1 = substr (tpath, 15, (tleng - 14)); stch1 = index (temp1, ">"); if stch1 = 0 then do; stch1 = index (temp1, " "); tproj = substr (temp1, 1, (stch1-1)); tname = "no_userid"; end; else do; tproj = substr (temp1, 1, (stch1 - 1)); str_len = length (temp1); temp2 = substr (temp1, (stch1 + 1), (str_len - (stch1 + 1))); stch2 = index (temp2, ">"); if stch2 = 0 then stch2 = index (temp2, " "); tname = substr (temp2, 1, (stch2 - 1)); end; end; else do; tname = "strange"; tproj = "line"; ab = 1; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* If the current name is different from the previous one, detach the stream of the current */ /* output segment. Pick up the length of the new name and project and adjust the size of the */ /* name and project variables accordingly. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if tname ^= name_hold then do; old_seg: call ios_$detach ("outstr", "", "", ostatus); new_seg: tp_len = index (tproj, " "); /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Attempt to attach a stream for processing this segment. If the attach is successful, see if this */ /* segment is being attached for the first time. If it is a new segment, output as the first line, a */ /* header explaining that the system was unable to backup the segment. If this is an old segment, bypass */ /* header output. If the attempt to attach failed, go to get the next erfil entry for processing. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ working_dir = ">udd>SysDaemon>error_file"; call hcs_$status_minf (working_dir, ("EF."||tname||"."||tproj), 1b, 01b, nareap, scode); if scode = error_table_$no_dir then do; call com_err_ (scode, "list_err", "No directory >udd>SysDaemon>error_file."); return; end; call ios_$attach ("outstr", "file_", (">udd>SysDaemon>error_file>"||"EF."||tname||"." ||tproj), "w", status); if sbits.code ^= "0"b then do; call com_err_ (ostatus, "list_err", "Attach failed ^a ^a", tname, tproj); return; end; if ab ^= 1 then do; nreap = null; chase = 0; eptr = addr(branch); call hcs_$status_ (">udd>SysDaemon>error_file", erfil, chase, eptr, nreap, code); call date_time_$fstime (branch.dtm, string); call ioa_$ioa_stream ("outstr", "The system was unable to access these entries for backup at ^a.", string); end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Set up an output buffer containing the full line in case it is needed. If the strange line switch is on */ /* output the full line in the segment called strange^line. Otherwise, output the name, proj, message and */ /* path name in that order. Set off the strange line switch. Store the current name in name_hold for */ /* comparison with the next name picked up in tname. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ line_out: sp_line = substr (lin, 1, 120); if ab = 1 then call ioa_$ioa_stream ("outstr", sp_line); else call ioa_$ioa_stream ("outstr", "^a^x^a", tmesg, tpath); ab = 0; name_hold = tname; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* THIS IS THE END OF THE MAIN LOOP. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Clear all the work areas in preparation for the next line to be processed. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ re_init: temp1 = " "; temp2 = " "; temp3 = " "; tprog = " "; tname = " "; tproj = " "; tmesg = " "; tpath = " "; sbits.eof = "0"b; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Make sure that both the input and the output streams are detached before quitting and then quit. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup: call ios_$detach ("my_input", "", "", status); call ios_$detach ("outstr", "", "", ostatus); suicide: end;  mail_errfiles.pl1 10/28/88 1411.9r w 10/28/88 1302.3 143667 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ mail_errfiles: proc; /* ENTRY DECLARATIONS */ dcl get_wdir_ entry returns (char (168)); /* wdir of err segs */ dcl (temp_string1, temp_string) char(32); dcl hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); /* names of err segs */ dcl hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); /* mailbox accessable ? */ dcl delete_$path entry (char (*) aligned, char (*), bit (6), char (*), fixed bin (35)); dcl continue_to_signal_ entry (fixed bin(35)); dcl find_condition_info_ entry (ptr, ptr, fixed bin(35)); dcl ioa_$ioa_stream entry options (variable); dcl com_err_ entry options(variable); dcl mailbox_$close entry(fixed bin,fixed bin(35)); dcl mailbox_$get_mode_index entry(fixed bin,bit(*)aligned,fixed bin(35)); dcl mailbox_$open entry(char(*)aligned,char(*)aligned,fixed bin,fixed bin(35)); dcl mail entry options(variable); /* new mail, ring 1 mailboxes */ dcl old_mail entry options(variable); /* old mail, "mailbox" segments */ dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); /* mail went OK */ dcl dprint_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)); dcl get_system_free_area_ entry returns (ptr); /* for hcs_$star */ dcl hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); /* find mailbox of err causer */ dcl hcs_$delentry_seg entry (ptr, fixed bin (35)); /* no access, scratch err seg */ /* BUILTIN FUNCTIONS */ dcl (addr, after, before, null, substr) builtin; /* BASED STRUCTURES */ dcl 1 box based (p) aligned, /* mailbox structure */ 2 lock bit (36) aligned, 2 nchr fixed bin, 2 nmsg fixed bin, 2 lins fixed bin, 2 secret fixed bin, 2 pad (3) fixed bin, 2 b, 3 yte (1000) bit (9) unaligned; dcl 1 in based (p) aligned, /* used by initiate_seg */ 2 put (1000)bit (9) unaligned; % include dprint_arg; dcl 1 entries (encount) aligned based (eptr), /* for hcs_$star */ 2 type bit (2) unaligned, 2 nname bit (16) unaligned, 2 nindex bit (18) unaligned; /* MISCELLANEOUS DATA ITEMS AND POINTERS */ dcl names (0:100) char (32) aligned based (nptr); /* EF seg names from list_err */ dcl areap ptr init (null); /* ptr to sys free area */ dcl encount fixed bin (17); /* no of err seg names */ dcl mseg_index fixed bin(17) init(0); /* index of ring 1 mailbox */ dcl (eptr, delptr, nptr) ptr init (null); /* miscellaneous pointers */ dcl xmode bit(36) aligned; /* extended access on ring 1 mailbox */ dcl star_arg char (6) aligned init ("EF.**"); /* indicates all segs beg w EF. */ dcl mode fixed bin (5); /* access mode */ dcl bmode bit (36) based (addr (mode)); /* for testing mode */ dcl ind fixed bin; /* index of no of EF. segs */ dcl dptr ptr init (null); /* ptr to dprint buffer */ dcl dir_name char(168) aligned int static /* directory in which to look for errfiles */ init(">udd>SysDaemon>error_file"); dcl code fixed bin (35); /* std error code ind */ dcl dirp char(168) aligned; /* mailbox dirname */ dcl p ptr init (null); dcl enamep char(32) aligned; /* mailbox entry name */ dcl ec fixed bin (35); /* std sys err code */ dcl bitct fixed bin (24); /* bitct of err causers mailbox */ dcl (this_seg, cur_seg) char (70); /* name of seg in my directory */ dcl cur_name char (22) aligned; /* err causers name */ dcl error_table_$noentry fixed bin (35) ext; /* in case no mailbox */ dcl error_table_$no_dir fixed bin (35) ext; /* sm dir in pth nm not spec */ dcl error_table_$no_info fixed bin (35) ext; /* not enuf acc to rtn any info */ dcl cur_proj char (9) aligned; /* err causers proj */ dcl my_path char (168) aligned; /* pathname of seg in my wdir */ dcl any_other condition; /* BEGIN PROGRAM EXECUTION */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Initialize all the components of the dprint_arg structure */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ dpap = addr (dprint_arg_buf); /* set ptr to the dprint_ args */ dpap -> dprint_arg.version = 1; /* the version no is one */ dpap -> dprint_arg.copies = 1; /* only one copy */ dpap -> dprint_arg.delete = 1; /* dprint and delete the seg */ dpap -> dprint_arg.queue = 3; /* no hurry, so print in Q 3 */ dpap -> dprint_arg.pt_pch = 1; /* print it don't punch it */ dpap -> dprint_arg.notify = 1; /* don't bother to notify */ dpap -> dprint_arg.output_module = 1; /* tell again to print not punch*/ dpap -> dprint_arg.class = "printer"; /* make it perfectly clear */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Get the name of the wdir containing the backup dump exceptions processed by list_err */ /* Pick up any segment names beginning with EF. and store them in the variable 'names where they will */ /* be processed one at a time. if there are no EF. segments today then quit till tomorrow */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ areap = get_system_free_area_ (); call hcs_$star_ (dir_name, star_arg, 11b, areap, encount, eptr, nptr, code); if code ^= 0 then do; call com_err_ (code, "mail_errfiles", "Error in obtaining error segments."); go to fin; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* For each un backed up segment, pick up the name, strip off the EF. prefis and parse out */ /* the name and the project. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ do ind = 1 to encount; this_seg = nptr -> names (ind-1); my_path = before(dir_name," ")||">"||this_seg; cur_seg = after (this_seg, "EF."); temp_string = cur_seg; do while (index (temp_string, ".") ^= 0); temp_string1 = before (temp_string, "."); temp_string = after (temp_string, "."); end; cur_name = temp_string1; cur_proj = temp_string; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Check to see if this is the segment named EF.strange^line which is the storage place that list_err */ /* uses for all lines in the backup dump which it cannot recognize as normal processing. */ /* If this is the strange^line segment it is bypassed and left in the directory so that it can be */ /* dprinted and examined for any serious problems. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if cur_name = "strange" then go to fin; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Look for a ring 1 mailbox to mail this segment to. If mail cannot be sent to a ring 1 mailbox for any */ /* reason, either because no such mailbox exists or because of insufficient access, try sending to an old */ /* mailbox. If there is not enough information available to say whether an old mailbox exists, */ /* then assume that the receiver doesn't want to know about his un backed up segments and delete the */ /* segment from the wdir. If there is no mailbox or if some directory in the pathname is missing, then */ /* dprint the segment and go get the next one if any. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ on condition(any_other) call default_handler; dirp = ">udd>"||before (cur_proj, " ")||">"||before (cur_name, " "); enamep = before(cur_name," ")||".mbx"; call mailbox_$open(dirp,enamep,mseg_index,code); if mseg_index=0 then do; /* can't send to new mailbox */ try_old: enamep = "mailbox"; call hcs_$initiate_count (dirp, enamep, "", bitct, 1, p, ec); if p=null then do; if ec = error_table_$no_info then go to del_seg; else if ec = error_table_$noentry | ec = error_table_$no_dir then do; print_it: dpap -> dprint_arg.dest = cur_proj; dpap -> dprint_arg.heading = cur_name; call dprint_ (dir_name, ("EF."||before(cur_name, " ")||"."||cur_proj), dpap, code); go to fin; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* If there is a null pointer where the mailbox pointer should be then call com_err_ to say why and go */ /* to get the next entry. If there is a valid pointer, check to see if we have access. If we have been */ /* refused access assume the potential receiver doesn't want to hear from us and delete the segment */ /* and go get the next one. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ call com_err_ (ec, "mail_errfiles", "Null pointer returned to mailbox ^a>^a",dirp,enamep); go to fin; end; call hcs_$fs_get_mode (p, mode, code); if ^substr (bmode, 33, 1) | ^substr (bmode, 35, 1) then do; call hcs_$terminate_noname(p,code); del_seg: call delete_$path (dir_name, this_seg, "000100"b, "mail_errfiles", code); if code ^= 0 then call com_err_ (code, "mail_errfiles", "Unsuccessful delete attempt of seg", "^a", my_path); go to fin; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* When we finally have access, see first if this is a real mailbox. If it is not, go dprint */ /* the segment instead. If this is a real mailbox, mail the segment at last, and go get the next */ /* one , if any. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ if bitct > 0 then if p -> box.secret ^= 2962 then do; call hcs_$terminate_noname (p, code); go to print_it; end; call old_mail (my_path, before(cur_name, " "), before(cur_proj, " ")); call hcs_$terminate_noname (p, ec); p = null; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* There is a ring 1 mailbox. Check extended access and if insufficient, go back and try old mail. */ /* If we have append extended access (first bit), send mail and close the mailbox. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ else do; call mailbox_$get_mode_index(mseg_index,xmode,ec); if ec^=0 | ^substr(xmode,1,1) then do; call mailbox_$close(mseg_index,code); go to try_old; end; call mail (my_path,before(cur_name," "),before(cur_proj," ")); call mailbox_$close(mseg_index,code); end; fin: end; default_handler: proc; dcl 1 cond_info aligned, 2 mcptr ptr, 2 version fixed bin, 2 condition_name char(32) varying, 2 infop ptr, 2 wcptr ptr, 2 loc_ptr ptr, 2 flags aligned, 3 crawlout bit(1) unal, 3 pad1 bit(35) unal, 2 pad_word bit(36) aligned, 2 user_loc ptr, 2 pad(4) bit(36) aligned; call find_condition_info_ (null, addr(cond_info), code); if code ^= 0 then do; call ioa_$ioa_stream ("error_output", "Error: Unknown signal has been received."); return; end; if cond_info.condition_name = "alrm" then do; continue: call continue_to_signal_ (code); return; end; if cond_info.condition_name = "cput" then go to continue; if cond_info.condition_name = "linkage_error" then go to continue; if cond_info.condition_name = "mme2" then go to continue; if cond_info.condition_name = "quit" then go to continue; if cond_info.condition_name = "command_error" then go to continue; if cond_info.condition_name = "finish" then go to continue; if cond_info.condition_name = "stack" then go to continue; if cond_info.condition_name = "program_interrupt" then return; call hcs_$terminate_noname (p, code); go to fin; end default_handler; /* This is the end */ end;  sort_branches.pl1 11/15/82 1824.4rew 11/15/82 1505.3 37413 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ sort_branches: procedure(root, a_count); /* Procedure to sort branches in order of thier primary names. */ /* This proc uses a singleton sort. It should be able to sort about 2**18 items . If it bombs out on a lesser number there is a programming error. */ dcl root ptr, pp ptr, (i, j, k, l, m, n, q, xi, xj, xk, xl, xq) fixed bin, (vxi, vxj, vxk, vxq, bp) ptr, Cut fixed bin int static init(12), stacki(18) fixed bin, stackj(18) fixed bin, a_count fixed bin, count fixed bin; % include backup_dir_list; dcl (addr, divide, null, ptr, rel) builtin; /* Set up arrays of pointers to names and indices of pointers */ if root = null then go to sort_ret; bp = root; /* get pointer to first branch structure */ count = a_count; /* copy the count of branches */ begin; dcl x (count) fixed bin; do n = 1 to count; x(n) = n; /* place index into index list */ end; n = n - 1; i, m = 1; j = n; /* Now sort */ /* Start by getting and ordering first middle and last elements in current list */ /* Arrange indices accordingly since only they get sorted and set test value to middle value */ sloop: k = i; l = j; q = divide(i+j, 2, 17, 0); xi = x(i); xj = x(j); xq = x(q); vxi = ptr(bp, bp->br(xi).namerp); vxj = ptr(bp, bp->br(xj).namerp); vxq = ptr(bp, bp->br(xq).namerp); if vxq->name(1).string < vxi->name(1).string then if vxj->name(1).string < vxi->name(1).string then if vxq->name(1).string < vxj->name(1).string then do; x(i) = xq; x(q) = xj; x(j) = xi; vxq = vxj; end; else do; x(i) = xj; x(j) = xi; end; else do; x(i) = xq; x(q) = xi; vxq = vxi; end; else if vxj->name(1).string < vxq->name(1).string then if vxi->name(1).string < vxj->name(1).string then do; x(q) = xj; x(j) = xq; vxq = vxj; end; else do; x(q) = xi; x(i) = xj; x(j) = xq; vxq = vxi; end; /* Now order into lists above and below the test value */ lloop: l = l - 1; xl = x(l); if ptr(bp, bp->br(xl).namerp)->name(1).string > vxq->name(1).string then go to lloop; kloop: k = k + 1; xk = x(k); if ptr(bp, bp->br(xk).namerp)->name(1).string < vxq->name(1).string then go to kloop; if k<=l then do; x(k) = xl; x(l) = xk; go to lloop; end; /* now put the longer list on the stack, and try to sort the smaller.*/ if l-iCut then go to sloop; if i=1 then if ibr(xk).namerp); bubble: l = k - 1; xl = x(l); if ptr(bp, bp->br(xl).namerp)->name(1).string <= vxk->name(1).string then go to ok; x(k) = xl; x(l) = xk; k = l; go to bubble; ok: end; /* Start work on the next list */ m = m - 1; if m=0 then go to thread; i = stacki(m); j = stackj(m); go to test; thread: /* store branch pointers in the store of the sorted primary names */ do i = 1 to count; /* loop over all branches */ xi = x(i); /* get index to next branch ordered by name */ bp->br(i).ix = rel(addr(bp->br(xi))); /* place rel pointer in appropriate branch */ end; end; /* end begin block in which x array is declared */ sort_ret: return; end;  start_dump.pl1 10/28/88 1411.9r w 10/28/88 1302.3 209349 /****^ *********************************************************** * * * 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(86-06-09,GWMay), approve(85-12-23,MCR7320), audit(86-11-19,GDixon), install(86-11-21,MR12.0-1223): Added ability to abort upon return of non-zero code from backup_dump. This will allow the dumper to abort tape errors and not continue with the next entry in the control file. The reason this should be done is to protect against data loss. 2) change(87-05-10,Gilcrease), approve(87-07-31,MCR7686), audit(88-02-01,Farley), install(88-02-02,MR12.2-1019): Update dprint_msg version. END HISTORY COMMENTS */ /* This is the Multics dumper driver. */ start_dump: proc; /* Initial coding by T.P. Skinner. */ /* Modified 3 June 1970, R H Campbell. */ /* IPC revision 25 March 1970, N I Morris. */ /* Restart path comparison fixed BIM 12/82 */ /* The Multics dumper driver is called at the time the system is brought up and will run the dumper until the end_dump command is given. If the alarm clock fails to operate properly, the operator may manually start an increment by issuing the wakeup_dump command. */ /* Changed to handle -no_primary, bugs fixed 09/24/79 S. Herbst */ /* MCR 4311 Fix error messages 02/08/80 S. Herbst */ /* Add -dprint and -no_dprint 03/19/80 S. Herbst */ /* Changed to detach tape on cleanup 02/25/81 S. Herbst */ /* Changed to prevent calling end_dump first with dumper uninitialized 07/01/81 S. Herbst */ /* Changed dprinting to see -ds, -he, and -rqt 12/01/81 S. Herbst */ /* Fixed restart option (again), Keith Loepere, 1/30/85. */ dcl (m, n, i) fixed bin; /* Temporary storage. */ dcl (line, p, sp, ap) ptr; /* .. */ dcl string based char (n); /* The argument in the command line. */ dcl substring based char (n) aligned; /* For non-copying "substr (dump_dir, 1, n)". */ dcl dump_in_progress static bit (1); /* Flag to prevent recursive entry to wakeup_dump. */ dcl dumper_initialized static bit (1) init ("0"b); /* Flag to prevent calling end_dump first */ dcl type static fixed bin, /* Code for type of dump. */ pid fixed bin (35), /* Our process ID. */ (map_name, err_name) char (32), /* Name of map "file_". */ device char (16), mode char (6), dump_dir char (168), efpath char (168) aligned, dir char (168) aligned, dir_name char (168), error_string char (32), rings (3) fixed bin (6), rb (3) fixed bin (5), unique_chars_ entry (bit (*) aligned) returns (char (15) aligned); /* Get new map name. */ dcl static_map_name char (32) int static; /* saved for end_dump */ dcl time_now fixed bin (52), /* Time this pass started. */ char1 char (1) based; dcl chname static fixed bin (71); /* IPC event channel name. */ dcl code fixed bin; /* Error code. */ dcl efl_name char (32); dcl errsw bit (1) aligned; dcl cleanup condition; dcl start_dump$wakeup_dump external; /* Entry to wake up dumper. */ dcl backup_map_$beginning_line entry (fixed bin (52), ptr, fixed bin), backup_dump$abort_on_tape_errors entry (fixed bin), backup_util$get_real_name entry (ptr, ptr, fixed bin, fixed bin), bk_output$output_finish entry; dcl (error_table_$noarg, error_table_$no_dir, error_table_$argerr, error_table_$ioname_not_found, error_table_$namedup) ext fixed bin (35); dcl bk_arg_reader_$dump_arg_reader entry (fixed bin, ptr, fixed bin); dcl timer_manager_$alarm_wakeup entry (fixed bin (71), bit (2), fixed bin (71)), timer_manager_$reset_alarm_wakeup entry (fixed bin (71)), copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed binary), clock_ entry (fixed bin (52)), /* Get current time. */ convert_date_to_binary_ entry (char (*), fixed bin (52), fixed bin), cu_$arg_list_ptr entry (ptr), /* Arg list location */ cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin), /* Get pointer to an argument */ cv_dec_ entry (char (*) aligned) returns (fixed bin (35)), get_group_id_$get_process_id_ entry (fixed bin (35)), ios_$attach entry (char (*), char (*), char (*), char (*), bit (72) aligned), ios_$detach entry (char (*), char (*), char (*), bit (72) aligned), ios_$get_at_entry_ entry (char (*), char (*), char (*), char (*), fixed bin), ios_$order entry (char (*), char (*) aligned, ptr, bit (72) aligned), ios_$read entry (char (*), ptr, fixed bin, fixed bin, fixed bin, bit (72) aligned), ios_$seek entry (char (*), char (*), char (*), fixed bin, bit (72) aligned), (ipc_$create_ev_chn, ipc_$delete_ev_chn) entry (fixed bin (71), fixed bin), ipc_$decl_ev_call_chn entry (fixed bin (71), ptr, ptr, fixed bin, fixed bin), dprint_ entry (char (*) aligned, char (*), ptr, fixed bin), (com_err_, ioa_, ioa_$rs, listen_$start) entry options (variable); dcl hphcs_$pxss_set_timax entry (fixed bin (35), fixed bin (35)); dcl hcs_$append_branchx entry (char (*) aligned, char (*), fixed bin (5), (3) fixed bin (6), char (*) aligned, fixed bin (1), fixed bin (1), fixed bin (24), fixed bin), hcs_$set_ring_brackets entry (char (*) aligned, char (*), (3) fixed bin (5), fixed bin), hcs_$add_acl_entries entry (char (*) aligned, char (*), ptr, fixed bin, fixed bin), get_group_id_$tag_star returns (char (32) aligned), cu_$level_get returns (fixed bin), get_wdir_ returns (char (168) aligned); dcl 1 sysd_acl aligned, 2 aclname char (32) init ("*.SysDaemon.*"), 2 aclmode bit (36) init ("101"b), 2 zeropad bit (36) init (""b), 2 aclcode fixed bin (35) init (0); dcl (addr, index, length, max, null, unspec, substr) builtin; %include bk_ss_; %include dprint_arg; %include io_status; /* */ type = 0; /* Normal entry, indicate "start_dump" called. */ bk_ss_$myname = "start_dump"; bk_ss_$datesw = ""b; /* Reset "dump all since given date" */ bk_ss_$dtdsw = "1"b; /* Default. Dump all changed since last dumped */ go to examine_arguments; /* Go get arguments. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ catchup_dump: entry; /* Exception entry to make cutoff-time pass. */ type = 2; /* Indicate catchup dump in progress. */ bk_ss_$myname = "catchup_dump"; bk_ss_$dtdsw = ""b; /* Reset "dump all changed since last dumped" */ bk_ss_$datesw = "1"b; /* Use "dump all changed since given date" */ call convert_date_to_binary_ ("2400.", bk_ss_$date, code); /* Get midnight of this date */ bk_ss_$date = bk_ss_$date - 172800000000; /* Default. Dump all changed since midnight 2 days ago. */ go to examine_arguments; /* Go get arguments. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ complete_dump: entry; /* Entry to do complete dump */ type = 1; /* Set up complete_dump code. */ bk_ss_$myname = "complete_dump"; bk_ss_$dtdsw, bk_ss_$datesw = ""b; /* Reset and ignore dates. We are dumping all. */ examine_arguments: call cu_$arg_list_ptr (ap); /* Get arg ptr for sub */ on cleanup call bk_output$output_finish; /* detach tape if released */ bk_ss_$control_name = ""; /* Reset for later test */ bk_ss_$operator = ""; bk_ss_$tapesw = "1"b; bk_ss_$holdsw = "1"b; bk_ss_$wakeup_interval = 3600000000; /* Default, one hour (in micro seconds) */ code = 0; error_string = "Control file path required."; m = 1; /* First arg */ call cu_$arg_ptr (m, p, n, code); /* Get first arg - should be control file name */ if code ^= 0 then do; arg_error: call com_err_ (code, bk_ss_$myname, error_string); go to final; end; if n = 0 then do; /* Must have first argument */ noarg: code = error_table_$noarg; go to arg_error; end; if p -> char1 = "-" then go to arg_reader; /* use argument reader if leading hyphen */ if substr (p -> string, n-4, 5) ^= ".dump" then bk_ss_$control_name = p -> string || ".dump"; else bk_ss_$control_name = p -> string; /* Got control file name */ error_string = "Operator name required."; m = 2; /* Second arg */ call cu_$arg_ptr (m, p, n, code); /* Get operator */ if code ^= 0 then go to arg_error; if n = 0 then go to noarg; /* Must have operator */ if p -> char1 = "-" then go to arg_reader; /* use standard argument reading routine */ bk_ss_$operator = p -> string; /* Got bk_ss_$operator */ error_string = ""; m = 3; /* Get third arg */ call cu_$arg_ptr (m, p, n, code); /* Get number of tapes if any */ if code ^= 0 then if code ^= error_table_$noarg then go to arg_error; else do; /* Set up default */ bk_ss_$ntapes = 1; /* Default is one tape */ code = 0; go to args_done; end; if p -> char1 = "-" then go to arg_reader; /* Go to standard reading routine */ if p -> string = "2" then bk_ss_$ntapes = 2; else bk_ss_$ntapes = 1; /* Not more than 2 tapes */ if bk_ss_$myname = "complete_dump" then m = 4; /* Set up to read next arg */ else do; /* Set timer interval if not complete dump */ call cu_$arg_ptr (4, p, n, code); /* Get wakeup interval in minutes */ if code ^= 0 then if code ^= error_table_$noarg then go to arg_error; else do; /* Use default wakeup interval */ code = 0; go to args_done; end; if p -> char1 = "-" then go to arg_reader; /* Do standart reading */ bk_ss_$wakeup_interval = cv_dec_ ((p -> string)); if bk_ss_$wakeup_interval <= 0 then go to interval_error; if bk_ss_$wakeup_interval > 360 then do; interval_error: call ioa_ ("^a: Improper wakeup interval, ^d", bk_ss_$myname, bk_ss_$wakeup_interval); go to final; end; bk_ss_$wakeup_interval = bk_ss_$wakeup_interval * 60000000; /* in micro seconds */ m = 5; /* set up to read next arg */ end; arg_reader: call bk_arg_reader_$dump_arg_reader (m, ap, code); /* Get any other arguments */ if code ^= 0 then go to final; args_done: if bk_ss_$restart_dumpsw & ^bk_ss_$no_primary then call backup_util$get_real_name (addr (bk_ss_$restart_path), addr (bk_ss_$restart_path), bk_ss_$restart_plen, code); /* Name may be longer or different */ if bk_ss_$control_name = "" | bk_ss_$operator = "" then do; code = error_table_$argerr; /* Must have dump control file and operator */ call com_err_ (code, bk_ss_$myname, "Missing control file or operator name"); go to final; end; sp = addr (status); /* Get pointer to status structure. */ line = addr (dump_dir); /* Get pointer to IO buffer. */ call ios_$attach ("dump_control", "file_", bk_ss_$control_name, "r", sp -> status_bits); /* Control segment. */ if status.code ^= 0 then do; /* Was an error encountered? */ call com_err_ (status.code, bk_ss_$myname, "ios_$attach for ^a", bk_ss_$control_name); go to final; /* Quit. */ end; if type ^= 1 then do; /* Is this a complete dump? */ call ipc_$create_ev_chn (chname, code); /* Create an event channel. */ if code ^= 0 then do; call com_err_ (code, bk_ss_$myname, "ipc_$create_ev_chn"); go to final; end; /* Make channel into call channel. */ call ipc_$decl_ev_call_chn (chname, addr (start_dump$wakeup_dump), null, 1, code); if code ^= 0 then do; /* OK? */ call com_err_ (code, bk_ss_$myname, "ipc_$decl_ev_call_chn"); go to final; /* Give up. */ end; end; if (^bk_ss_$debugsw) & (type = 2) then do; call get_group_id_$get_process_id_ (pid); /* Get our process ID. */ call hphcs_$pxss_set_timax (pid, 7000000); /* Help us along with priority. */ end; dump_in_progress = "1"b; /* Set flag to prevent recursion. */ dumper_initialized = "1"b; /* and we're off and runnning... */ go to over; /* Start dump pass. */ /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ wakeup_dump: entry; /* Enter here on alarm or operator wakeup. */ sp = addr (status); /* Get pointer for I/O system status. */ if dump_in_progress then do; /* Is a dump pass being done now? */ call ioa_ ("wakeup_dump: Dump pass presently in progress; this call ignored."); call listen_$start; /* Make sure we don't die. */ go to restart_IO; /* Ignore call. */ end; call timer_manager_$reset_alarm_wakeup (chname); /* Reset the alarm in case of manual invocation */ bk_ss_$myname = "wakeup_dump"; dump_in_progress = "1"b; /* Set flag. */ line = addr (dump_dir); /* Get pointer to directory name. */ call ioa_ ("^/Dumper waking up."); over: call clock_ (time_now); /* Read the clock. */ call ios_$seek ("dump_control", "read", "first", 0, sp -> status_bits); /* Reset read pointer. */ if status.code ^= 0 then do; /* OK? */ call com_err_ (status.code, bk_ss_$myname, "ios_$seek for ^a", bk_ss_$control_name); go to stop; /* Give up. */ end; map_name, static_map_name = unique_chars_ (""b) || ".dump.map"; /* Make up new map name. */ rings (1), rings (2), rings (3) = max ((cu_$level_get ()), 4); dir = get_wdir_ (); call hcs_$append_branchx (dir, map_name, 01011b, rings, (get_group_id_$tag_star ()), 0, 0, 0, code); if (code = 0) | (code = error_table_$namedup) then call hcs_$add_acl_entries (dir, map_name, addr (sysd_acl), 1, code); call ios_$attach ("map", "file_", map_name, "w", sp -> status_bits); if status.code ^= 0 then do; /* All OK? */ call com_err_ (status.code, bk_ss_$myname, "ios_$attach for ^a", map_name); go to stop; end; call ioa_$rs ("Dump control file: ^a, operator: ^a.", dump_dir, n, bk_ss_$control_name, bk_ss_$operator); bk_ss_$mapsw = "1"b; /* Make sure map is enabled. */ call backup_map_$beginning_line (time_now, line, n); /* Write the ID line. */ next: call ios_$read ("dump_control", line, 0, length (dump_dir), n, sp -> status_bits); if status.code ^= 0 then do; /* OK? */ call com_err_ (status.code, bk_ss_$myname, "ios_$read for ^a", bk_ss_$control_name); go to done; /* Give up. */ end; n = n - 1; /* Remove NL from consideration. */ call ioa_ ("^/^a", line -> substring); /* Space and type root name. */ /* Is this a path name or comment? */ if substr (dump_dir, 1, length (">")) = ">" then do; bk_ss_$save_path = line -> substring; /* save the pathname */ bk_ss_$save_plen = n; /* and its length */ bk_ss_$pathsw = "1"b; /* and signal its presence */ if bk_ss_$restart_dumpsw then do; /* Restarting this dump */ if ^bk_ss_$no_primary then call backup_util$get_real_name (addr (bk_ss_$save_path), addr (bk_ss_$save_path), bk_ss_$save_plen, code); if substr (bk_ss_$save_path, 1, bk_ss_$save_plen) ^= substr (bk_ss_$restart_path, 1, bk_ss_$save_plen) then go to check_end; /* save path contained within restart path */ if bk_ss_$save_plen < bk_ss_$restart_plen then if substr (bk_ss_$restart_path, bk_ss_$save_plen + 1, 1) ^= ">" then go to check_end; /* if save path ^= restart path, then restart path must be = save path || > || */ end; /* D U M P S P E C I F I E D S U B T R E E */ call backup_dump$abort_on_tape_errors (code); if code ^= 0 then go to ended; end; check_end: if ^ status.bits.end_of_data then /* Any more lines? */ go to next; done: call finish_maps (0); /* Detach and dprint map and error file. */ bk_ss_$mapsw = ""b; /* Clear switch to suppress comment from bk_output. */ if type = 2 then do; /* Is this exceptional case? */ if bk_ss_$no_contin then go to ended; /* DONE. Do not continue */ bk_ss_$holdsw = ""b; /* Dismount tape when finished */ if bk_ss_$tapesw then /* Detach only if tape is present */ call bk_output$output_finish (); /* Detach the tape. */ call ioa_ ("^/Catchup_dump has finished; start_dump will be called."); /* Announce completion. */ type = 0; /* Reset to normal incremental operation. */ bk_ss_$myname = "start_dump"; bk_ss_$dtdsw = "1"b; bk_ss_$holdsw = "1"b; bk_ss_$datesw = ""b; /* Turn off date check */ if ^bk_ss_$debugsw then call hphcs_$pxss_set_timax (pid, 0); /* Reset timax */ go to over; /* Start next pass immediately. */ end; call ioa_ ("^/Dump finished."); if type ^= 1 then do; /* Is this either type of incremental dump? */ call timer_manager_$alarm_wakeup (time_now + bk_ss_$wakeup_interval, "00"b, chname); call ioa_ ("Dumper going to sleep.^/"); restart_IO: call ios_$order ("user_i/o", "start", null, sp -> status_bits); /* Ensure tty does not lock up. */ if status.code ^= 0 then /* OK? */ call com_err_ (status.code, bk_ss_$myname, "ios_$order on user_i/o"); /* No, give error comment. */ dump_in_progress = ""b; /* Indicate dump no longer active. */ bk_ss_$myname = ""; /* done for now */ return; end; go to ended; /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ end_dump: entry; /* Finish up dumping. */ bk_ss_$myname = "end_dump"; if ^dumper_initialized then do; call com_err_ (0, bk_ss_$myname, "Dumper not initialized; ""end_dump"" ignored."); return; end; sp = addr (status); /* Gotta set it again. */ ended: bk_ss_$mapsw = ""b; /* Clear map enabling switch for following comment. */ bk_ss_$holdsw = ""b; /* Dismount tape when finished */ if bk_ss_$tapesw then /* Detach only if tape present */ call bk_output$output_finish (); call finish_maps (1); /* Detach and dprint map and error file. */ stop: call ios_$detach ("dump_control", "", "", sp -> status_bits); /* Detach control segment. */ if status.code ^= 0 then /* Terminated OK? */ call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", bk_ss_$control_name); /* Give comment. */ if type ^= 1 then do; /* Is this incremental? */ call ipc_$delete_ev_chn (chname, code); /* Remove the event channel. */ if code ^= 0 then do; /* OK? */ call com_err_ (code, bk_ss_$myname, "ipc_$delete_ev_chn"); go to final; /* Give up. */ end; end; final: bk_ss_$myname = ""; /* reset name */ dumper_initialized = "0"b; /* can't call end_dump twice in a row */ return; /* terminate processing */ /* ------------------------------------------------------ */ finish_maps: proc (detsw); dcl detsw fixed bin; /* 0 if det err file only on complete, 1 if always. */ dcl (have_error_file, have_map) bit (1) aligned init ("0"b); sp = addr (status); dir = get_wdir_ (); call ios_$detach ("map", "", "", sp -> status_bits); if status.code ^= 0 then /* All OK? */ if status.code ^= error_table_$ioname_not_found then call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", map_name); /* Give comment. */ else; else have_map = "1"b; if detsw = 0 then if type ^= 1 then go to skip_errfile; /* Detach error file sometimes only. */ call ios_$get_at_entry_ ("err_file", device, err_name, mode, status.code); /* see if error file made */ if status.code ^= 0 then if status.code ^= error_table_$ioname_not_found then call com_err_ (status.code, bk_ss_$myname, "ios_$get_at_entry_ for err_file"); else; else do; call ios_$detach ("err_file", "", "", sp -> status_bits); if status.code ^= 0 then if status.code ^= error_table_$ioname_not_found then call com_err_ (status.code, bk_ss_$myname, "ios_$detach for ^a", err_name); else; else do; have_error_file = "1"b; i = index (dir, " "); /* make full name */ efpath = substr (dir, 1, i-1) || ">" || err_name; rb (1), rb (2), rb (3) = max ((cu_$level_get ()), 4); call hcs_$set_ring_brackets (efpath, "", rb, code); if code ^= 0 then call com_err_ (code, bk_ss_$myname, "hcs_$set_ring_brackets for err file"); end; end; /* Queue maps for printing. */ skip_errfile: if ^bk_ss_$dprintsw then return; dpap = addr (dprint_arg_buf); /* Set up args to dprint */ unspec (dprint_arg) = "0"b; dprint_arg.version = dprint_arg_version_9; dprint_arg.copies = 1; dprint_arg.delete = 1; dprint_arg.queue = bk_ss_$dprint_queue; dprint_arg.pt_pch = 1; dprint_arg.notify = 0; dprint_arg.output_module = 1; dprint_arg.lmargin = 0; dprint_arg.line_lth = -1; dprint_arg.page_lth = -1; dprint_arg.top_label = ""; dprint_arg.bottom_label = ""; dprint_arg.form_name = ""; dprint_arg.chan_stop_path = ""; if bk_ss_$dprint_heading_setsw then dprint_arg.heading = bk_ss_$dprint_heading; else dprint_arg.heading = " for " || substr (bk_ss_$control_name, 1, length (dprint_arg.heading) - length (" for ")); if bk_ss_$dprint_request_type_setsw then dprint_arg.request_type = bk_ss_$dprint_request_type; else dprint_arg.request_type = ""; if have_error_file then do; efl_name = err_name; dir_name = dir; if ^bk_ss_$debugsw then call copy_seg_ (dir_name, efl_name, ">udd>SysDaemon>error_file", efl_name, bk_ss_$myname, errsw, code); if code ^= 0 & code ^= error_table_$no_dir then call com_err_ (code, bk_ss_$myname, "copy of error file"); if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination; else dprint_arg.destination = "ERROR FILE"; call dprint_ (dir, err_name, dpap, code); if code ^= 0 then call com_err_ (code, bk_ss_$myname, "Unable to dprint ^a>^a", dir, err_name); end; if ^have_map then return; if type = 0 then do; /* Is this a normal incremental dump? */ dprint_arg.destination = "INCREMENTAL"; DPRINT: if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination; call dprint_ (dir, static_map_name, dpap, code); if code ^= 0 then call com_err_ (code, bk_ss_$myname, "Unable to dprint ^a>^a", dir, static_map_name); end; else if type = 2 then do; /* Is this a catchup dump? */ if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination; else dprint_arg.destination = "CATCHUP MAP"; go to DPRINT; end; else do; /* This is a complete dump. */ if bk_ss_$dprint_destination_setsw then dprint_arg.destination = bk_ss_$dprint_destination; else dprint_arg.destination = "COMPLETE MAP"; dprint_arg.copies = bk_ss_$ntapes; /* Want a map for each set. */ go to DPRINT; end; end finish_maps; end start_dump;  copy_dump_tape.pl1 07/16/87 1351.7r 07/15/87 1558.3 975609 /****^ ******************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * ******************************************** */ /****^ HISTORY COMMENTS: 1) change(87-01-05,GDixon), approve(87-04-15,MCR7617), audit(87-06-22,RBarstad), install(87-07-15,MR12.1-1040): Completely rewritten, combining copy and compare functions into a single command. END HISTORY COMMENTS */ copy_dump_tape: proc options(variable); dcl ME char(17), /* command called*/ abort_sw bit(1), /* on: -abort */ code fixed bin(35), 1 compared aligned like copied,/* count compares*/ 1 copied aligned, /* count copied */ 2 segs fixed bin, /* entries */ 2 msfs fixed bin, /* msfs */ 1 cpbf aligned like inbf, /* copy record */ 1 cphe aligned like inhe based (cpbf.hp), 1 cphe_name aligned like inhe_name based (cpbf.hp), 1 cplast aligned like inlast,/* last rec read */ /* from copy */ /* tape. */ 1 inbf aligned, /* input record */ 2 blrh, /* backup dump */ 3 zz1 char(32), /* record head */ 3 english char(56), 3 zz2 char(32), 3 sizes, 4 hl fixed bin(21), 4 segl fixed bin(21), 2 hp ptr, /* header ptr */ 2 segp ptr, /* segment ptr */ 1 inhe aligned like h based (inbf.hp), /* header */ 1 inhe_name aligned based (inbf.hp), 2 dname char(168) varying, 2 ename char(32) varying, 1 inlast aligned, /* last seg read */ 2 path unal, /* from in tape.*/ 3 dir char (168), 3 ent char (32), 2 sizes, 3 he fixed bin(35), 3 seg fixed bin(35), 1 input aligned, /* input medium */ 2 header like in_out.header, 2 vol (20) like in_out.vol, /* tape names */ 1 map aligned, /* map file */ 2 header like in_out.header, 1 map_prev aligned, /* map file */ 2 header like in_out.header, 1 mbf aligned like inbf based(addr(inbf)), /* master record */ 1 mhe aligned like h based (mbf.hp), /* header */ 1 mhe_name aligned like inhe_name based (mbf.hp), 1 mlast aligned like inlast,/* last record */ /* read from */ /* master tape. */ maximize_devices_sw bit(1), /* on: -maxdv */ operation_now fixed bin, /* cur function */ operation_wanted fixed bin, /* wanted fcn */ 1 output aligned, /* output medium */ 2 header like in_out.header, 2 vol (20) like in_out.vol, /* tape names */ 1 select aligned, /* copy selected */ 2 header like in_out.header, /* files only */ 2 listp ptr, /* path list */ 2 select_sw bit(1), /* on: -select */ /* without opt,*/ /* -select used*/ /* by compare ep*/ state fixed bin, /* result of */ /* read_seg fcn */ trace fixed bin; /* -trace XXX */ dcl 1 in_out aligned based (in_outp), 2 header, 3 name char(8) varying, /* log file name */ 3 iocbp ptr, /* IOCB ptr */ 3 target_iocbp ptr, 3 mode fixed bin, /* opening mode */ 3 recx fixed bin, /* cur rec */ 3 vfile, /* input file */ 4 path char(168) unal, 4 expath char(168) unal, 4 charpos fixed bin(35), /* pos of last */ /* char read */ 3 tape, /* input tapes. */ 4 voln fixed bin, /* total */ 4 volx fixed bin, /* current */ 4 track fixed bin, /* track */ 4 density fixed bin, /* density */ 2 vol (20), 3 name char(32), /* vol names */ 3 device char(32), /* device used */ in_outp ptr, /* ptr to input */ /* or output */ severity fixed bin based (severityp), severityp ptr; dcl (addr, bin, char, clock, dim, divide, hbound, index, lbound, length, ltrim, max, maxlength, min, mod, null, ptr, rtrim, search, string, substr, unspec, verify) builtin; dcl cleanup condition; dcl absolute_pathname_ entry (char(*), char(*), fixed bin(35)), absolute_pathname_$add_suffix entry (char(*), char(*), char(*), fixed bin(35)), backup_map_$beginning_line entry (fixed bin(52), ptr, fixed bin), backup_map_$detail_line2 entry (char(32) aligned, fixed bin(9), char(10) aligned, fixed bin(52), fixed bin(52), fixed bin(52), fixed bin(52), fixed bin(52)), backup_map_$detach_for_cdt entry (fixed bin(35)), backup_map_$directory_line entry (ptr, fixed bin), backup_map_$heading_line entry, backup_map_$init_for_cdt entry (char(128) var), backup_map_$name_line entry (ptr, fixed bin), backup_map_$tapes entry (ptr, fixed bin), backup_map_$terminal_line entry (fixed bin(52), fixed bin), backup_util$idline entry (char(*), char(*), ptr, fixed bin), convert_ipc_code_ entry options(variable), cu_$arg_list_ptr entry returns(ptr), date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var), get_line_length_$switch entry (ptr, fixed bin(35)) returns(fixed bin), get_shortest_path_ entry (char(*)) returns(char(168)), ioa_ entry() options(variable), iox_$attach_name entry (char(*), ptr, char(*), ptr, fixed bin(35)), iox_$attach_ptr entry (ptr, char(*), ptr, fixed bin(35)), iox_$close entry (ptr, fixed bin(35)), iox_$control entry (ptr, char(*), ptr, fixed bin(35)), iox_$destroy_iocb entry (ptr, fixed bin(35)), iox_$detach_iocb entry (ptr, fixed bin(35)), iox_$find_iocb entry (char(*), ptr, fixed bin(35)), iox_$get_chars entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), iox_$get_line entry (ptr, ptr, fixed bin(21), fixed bin(21), fixed bin(35)), iox_$modes entry (ptr, char(*), char(*), fixed bin(35)), iox_$move_attach entry (ptr, ptr, fixed bin(35)), iox_$open entry (ptr, fixed bin, bit(1) aligned, fixed bin(35)), iox_$position entry (ptr, fixed bin, fixed bin(35), fixed bin(35)), iox_$put_chars entry (ptr, ptr, fixed bin(21), fixed bin(35)), ipc_$block entry (ptr, ptr, fixed bin(35)), ipc_$create_ev_chn entry (fixed bin(71), fixed bin(35)), ipc_$delete_ev_chn entry (fixed bin(71), fixed bin(35)), pathname_ entry (char(*), char(*)) returns(char(168)), rcp_$assign_device entry (char (*), ptr, fixed bin (71), char (*), bit (36) aligned, fixed bin (35)), rcp_$check_assign entry (bit (36) aligned, ptr, char (*), fixed bin, fixed bin (35)), rcp_$copy_list entry (ptr, fixed bin (21), fixed bin (35)), rcp_$unassign entry (bit (36) aligned, bit (*), char (*), fixed bin (35)), ssu_$get_invocation_count entry (ptr, fixed bin, fixed bin), ssu_$get_temp_segment entry (ptr, char(*), ptr), unique_chars_ entry (bit(*)) returns(char(15)); dcl BLOCK_SIZE fixed bin int static options(constant) init(256), BLRH_DELIMITER char(32) int static options(constant) init( " z z z z z z z z z z z z z z z z"), BLRH_ENGLISH char(56) int static options(constant) init("This is the beginning of a backup logical record."), (DESTROY init(1), KEEP init(2)) fixed bin int static options(constant), (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), FOR_MOVE_ATTACH fixed bin int static options(constant) init(-1), (REJECTS init(-1), OFF init(0), COPY init(1), COMPARE init(2), COPY_AND_COMPARE init(3)) fixed bin int static options(constant), (OK init(0), READ_AGAIN init(1), NOMORE init(2)) fixed bin int static options(constant), compare_dump_tape_severity_ fixed bin ext static init (0), copy_dump_tape_map_ char(168) varying ext static init(""), copy_dump_tape_severity_ fixed bin ext static init (0), copy_dump_tape_tapes char(300) varying ext static init(""), (error_table_$bad_opt, error_table_$device_end, error_table_$end_of_info, error_table_$inconsistent, error_table_$noarg, error_table_$not_detached, error_table_$resource_reserved, error_table_$resource_unavailable, error_table_$too_many_names, error_table_$wrong_no_of_args) fixed bin(35) ext static; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ENTRY POINT IDENTIFICATION: */ /* 1) Identify command entrypoint. */ /* 2) Set operation code. */ /* 3) Identify command severity variable. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ ME = "copy_dump_tape"; operation_wanted = COPY; severityp = addr(copy_dump_tape_severity_); copy_dump_tape_tapes = ""; copy_dump_tape_map_ = ""; go to COPY_COMPARE; compare_dump_tape: entry options(variable); ME = "compare_dump_tape"; operation_wanted = COMPARE; severityp = addr(compare_dump_tape_severity_); go to COPY_COMPARE; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* INVOCATION TYPE AND ARGUMENTS: */ /* 1) Set severity variable to indicate success. */ /* 2) Initialize variables used in cleanup handler, and establish handler. */ /* 3) Create standalone ssu_ invocation for argument processing. */ /* 4) Initialize argument handling routines. */ /* 5) Process input arguments, reporting any errors as they are encountered. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ COPY_COMPARE: severity = 0; sci_ptr = null; call initialize_args(); on cleanup call cleanup_invocation(); call ssu_$standalone_invocation (sci_ptr, ME, "1.0", cu_$arg_list_ptr(), exit_proc, code); call check_invocation_type (ALLOW_COMMAND); call process_args(); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* PROCESSING: */ /* 1) If -select was given, process the select file to build a select tree. */ /* 2) If -map was given, open the map file. */ /* 3) If tapes are being used for input or output, survey tape drives */ /* assigned to the process. */ /* 4) If copying, attach input/output files, do the copying, detach */ /* input/output files. If output was to tape, report which tapes were */ /* actually written on. */ /* 5) If comparing, attach master/copy files, do the comparing, detach */ /* input/output files. */ /* 6) If copying and comparing, report discrepancy between number of segs */ /* copied vs number compared. */ /* 7) If -trace, report any -select pathnames that were not matched. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ if select.vfile.path ^= "" then do; call ioa_ (""); call attach (addr(select), Stream_input); call skip_seg$init(); call ssu_$print_message (sci_ptr, 0, "^a: ^d select lines processed.", hhmmm(), select.recx); call detach (addr(select), DESTROY); end; if map.vfile.path ^= "" then do; call ioa_ (""); call attach (addr(map), Stream_output); copy_dump_tape_map_ = map.vfile.expath; end; if input.tape.voln > 0 | output.tape.voln > 0 then call tape_drive$survey(); if mod (operation_wanted, 2) = COPY then do; operation_now = COPY; call header("BEGIN COPYING", input, output); call attach (addr(input), Stream_input); call attach (addr(output), Stream_output); call map_seg$init (output); call copy_segs(); if output.tape.voln > 0 then do; output.tape.voln = output.tape.volx; call ioa_ (""); call ssu_$print_message (sci_ptr, 0, "NOTE: Files were copied onto ^d ^a tape^[s^]:^v( ^a^)^/", output.tape.voln, output.header.name, output.tape.voln>1, output.tape.voln, output.vol.name); copy_dump_tape_tapes = output.vol(1).name; do output.tape.volx = 2 to output.tape.voln; copy_dump_tape_tapes = copy_dump_tape_tapes || " "; copy_dump_tape_tapes = copy_dump_tape_tapes || output.vol(output.tape.volx).name; end; end; end; if operation_wanted >= COMPARE then do; operation_now = COMPARE; call header ("BEGIN COMPARING", input, output); call attach (addr(input), Stream_input); call attach (addr(output), Stream_input); call compare_segs(); end; if operation_wanted = COPY_AND_COMPARE then do; operation_now = COPY_AND_COMPARE; if copied.segs ^= compared.segs | copied.msfs ^= compared.msfs then do; severity = max(severity, 3); call ioa_ (""); call error (sci_ptr, -1, "^a: FATAL ERROR: Copy/Compare Count Discrepancy. Copied: ^5d segment^[s,^;, ^] ^5d msf^[s^] Compared: ^5d segment^[s,^;, ^] ^5d msf^[s^]", hhmmm(), copied.segs, copied.segs^=1, copied.msfs, copied.msfs^=1, compared.segs, compared.segs^=1, compared.msfs, compared.msfs^=1); end; end; call skip_seg$term(); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* REVOCATION AND EXIT: */ /* This point is reached when normal processing completes successfully, */ /* or when the error$fatal routine is called to abnormally end processing. */ /* */ /* 1) Report status of all processing. */ /* 2) Cleanup the standalone invocation. */ /* 3) Return to command processor. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ EXIT: call ioa_ (""); call ssu_$print_message (sci_ptr, 0, "^a: ^[Copy^;Compare^;Copy and compare^] ^" || "[completed successfully.^; ^;completed successfully, except for unmatched lines in select file (severity 2 error). ^;failed due to comparison errors (severity 3 error). ^;failed due to fatal error (severity 4 error).^]^2/", hhmmm(), operation_wanted, severity+1); call cleanup_invocation(); return; exit_proc: proc; severity = max(severity, 4); go to EXIT; end exit_proc; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ATTACH to TAPE or STORAGE SYSTEM FILE: */ /* 1) Name and get pointer to I/O switch. */ /* 2) Attach and open switch. Tapes are attached by mount_next_tape_vol. */ /* 3) Report the attachment. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ attach: proc (iop, mode); dcl iop ptr, 1 io aligned like input based(iop), mode fixed bin; dcl atd char(300) varying, code fixed bin(35), count fixed bin, io_switch_name char(32); io.mode = mode; io.recx = 0; call ssu_$get_invocation_count (sci_ptr, count, 0); io_switch_name = rtrim(ME) || "." || ltrim(char(count)) || "." || io.header.name; if mode = FOR_MOVE_ATTACH then call iox_$find_iocb (io_switch_name, io.target_iocbp, code); else call iox_$find_iocb (io_switch_name, io.iocbp, code); if io.vfile.path ^= "" then do; atd = "vfile_ " || rtrim(io.vfile.expath); if mode = Stream_input then atd = atd || " -old"; call iox_$attach_ptr (io.iocbp, (atd), null, code); call error$fatal (sci_ptr, code, "^/FATAL ERROR: Attaching ^a file ^a.", io.header.name, io.vfile.expath); call iox_$open (io.iocbp, mode, ""b, code); call error$fatal (sci_ptr, code, "^/FATAL ERROR: Opening ^a file ^a for ^a.", io.header.name, io.vfile.expath, iox_modes(mode)); call ssu_$print_message (sci_ptr, 0, "^a: Attached ^a for ^a to file:^/ ^a.^[^/ (^a)^]", hhmmm(), io.header.name, iox_modes(mode), io.vfile.expath, trace ^= OFF, atd); io.vfile.charpos = 0; end; else if io.tape.voln > 0 then do; io.tape.volx = 0; if mount_next_tape_vol (io) then; else call error$fatal (sci_ptr, -1, "FATAL ERROR: Unable to attach^[ first^] ^a tape ^a.", io.tape.voln>1, io.header.name, io.vol(1).name); end; end attach; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ARGUMENT PROCESSING: */ /* Declare variables and subroutines needed for argument processing. */ /* */ /* CHECK INVOCATION TYPE: */ /* 1) Initialize error handling subroutines. */ /* 2) Determine whether invoked as command or af. */ /* 3) Is this type of invocation allowed? */ /* 4) Initialize af return argument, and index of current argument. */ /* */ /* SEE OTHER ARGUMENT PROCESSING PROGRAMS: */ /* get_arg, get_ctl_arg, get_opt, get_num_opt */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl af_sw bit(1) aligned, /* on: active fnc*/ arg char(argl) based(argp), argl fixed bin(21), /* current arg */ argp ptr, argn fixed bin, /* arg count */ argx fixed bin, /* arg index */ num_opt fixed bin, /* numeric option*/ opt char(optl) based(optp), optl fixed bin(21), /* current option*/ optp ptr, ret char(retl) varying based(retp), retl fixed bin(21), /* af return val */ retp ptr, sci_ptr ptr; /* ssu_ info ptr */ dcl ssu_$abort_subsystem entry() options(variable), ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21)), ssu_$destroy_invocation entry (ptr), ssu_$print_message entry() options(variable), ssu_$return_arg entry (ptr, fixed bin, bit(1) aligned, ptr, fixed bin(21)), ssu_$standalone_invocation entry (ptr, char(*), char(*), ptr, entry, fixed bin(35)); dcl (ALLOW_COMMAND init(1), ALLOW_AF init(2), ALLOW_COMMAND_AF init(3)) fixed bin int static options(constant); check_invocation_type: proc (allowed); dcl allowed fixed bin; dcl (error_table_$active_function, error_table_$not_act_fnc) fixed bin(35) ext static; call error$init(); call ssu_$return_arg (sci_ptr, argn, af_sw, retp, retl); if allowed = ALLOW_COMMAND & af_sw then call error$fatal (sci_ptr, error_table_$active_function); else if allowed = ALLOW_AF & ^af_sw then call error$fatal (sci_ptr, error_table_$not_act_fnc); else if allowed = ALLOW_COMMAND_AF then; if af_sw then ret = ""; argx = 0; end check_invocation_type; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CLEANUP: */ /* 1) Close attachment (via syn_) of map switch used by backup_map_ subrs. */ /* 2) Unassign any reserved tape drives we assigned to the process. */ /* 3) Silently close/detach all opened I/O switches. */ /* 4) Destroy the ssu_ invocation (releasing temp segs obtained thru ssu_). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ cleanup_invocation: proc; call map_seg$term(); call tape_drive$term(); call detach (addr(input), DESTROY); call detach (addr(output), DESTROY); call detach (addr(map), DESTROY); call detach (addr(select), DESTROY); if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr); end cleanup_invocation; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* COMPARE A SEGMENT FROM MASTER with SEGMENT FROM COPY MEDIUM: */ /* 1) Initialize error detect remembering switch. If any comparisons fail, */ /* report the error, and let the error routine remember that one */ /* occurred. */ /* 2) Compare pathnames of the two segments from backup logical record */ /* headers. */ /* 3) Compare length of backup logical record headers. */ /* 4) Compare header words. */ /* 5) Compare segment lengths. */ /* 6) Compare segment words. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ compare_seg: proc (bf1, bf2, segx) returns (bit(1)); dcl 1 (bf1, bf2) aligned like inbf, segx fixed bin; dcl first_disagreement fixed bin(18), words_disagreeing fixed bin(18), wordx fixed bin(18); dcl 1 he1 aligned like h based (bf1.hp), 1 he2 aligned like h based (bf2.hp), 1 he1_name aligned like inhe_name based (bf1.hp), 1 he2_name aligned like inhe_name based (bf2.hp), he1_words (bf1.hl) fixed bin(35) based (bf1.hp), he2_words (bf2.hl) fixed bin(35) based (bf2.hp), seg1_words (bf1.segl) fixed bin(35) based (bf1.segp), seg2_words (bf2.segl) fixed bin(35) based (bf2.segp); call error$init(); if he1_name.dname ^= he2_name.dname | he1_name.ename ^= he2_name.ename then call error (sci_ptr, -1, "^a: Segment ^d -- Pathname Discrepancy. Master: ^a Copy: ^a", hhmmm(), segx, rtrim(pathname_((he1.dname), (he1.ename)), " >"), rtrim(pathname_((he2.dname), (he2.ename)), " >")); else if dim(he1_words,1) ^= dim(he2_words,1) then call error (sci_ptr, -1, "^a: Segment ^d -- Record Header Length Discrepancy. Master: ^5d words for ^a Copy: ^5d words for ^a", hhmmm(), segx, dim(he1_words,1), rtrim(pathname_((he1.dname), (he1.ename)), " >"), dim(he2_words,1), rtrim(pathname_((he2.dname), (he2.ename)), " >")); else if unspec(he1_words) ^= unspec(he2_words) then do; words_disagreeing = 0; first_disagreement = 0; do wordx = lbound(he1_words,1) to hbound(he1_words,1); if he1_words(wordx) ^= he2_words(wordx) then do; words_disagreeing = words_disagreeing + 1; if words_disagreeing = 1 then first_disagreement = wordx; end; end; call error (sci_ptr, -1, "^a: Segment ^d -- Record Header Discrepancy, ^d word^[s^]. --FIRST DISCREPANCY-- Master: word(^d) = ^w, for ^a Copy: word(^d) = ^w, for ^a", hhmmm(), segx, words_disagreeing^=1, words_disagreeing, first_disagreement, he1_words(first_disagreement), rtrim(pathname_((he1.dname), (he1.ename)), " >"), first_disagreement, he2_words(first_disagreement), rtrim(pathname_((he2.dname), (he2.ename)), " >")); end; else if dim(seg1_words,1) ^= dim(seg2_words,1) then call error (sci_ptr, -1, "^a: Segment ^d -- Segment Length Discrepancy. Master: ^5d words for ^a Copy: ^5d words for ^a", hhmmm(), segx, dim(seg1_words,1), rtrim(pathname_((he1.dname), (he1.ename)), " >"), dim(seg2_words,1), rtrim(pathname_((he2.dname), (he2.ename)), " >")); else if unspec(seg1_words) ^= unspec(seg2_words) then do; words_disagreeing = 0; first_disagreement = 0; do wordx = lbound(seg1_words,1) to hbound(seg1_words,1); if seg1_words(wordx) ^= seg2_words(wordx) then do; words_disagreeing = words_disagreeing + 1; if words_disagreeing = 1 then first_disagreement = wordx; end; end; call error (sci_ptr, -1, "^a: Segment ^d -- Segment Contents Discrepancy, ^d word^[s^]. --FIRST DISCREPANCY-- Master: word(^d) = ^w, for ^a Copy: word(^d) = ^w, for ^a", hhmmm(), segx, words_disagreeing^=1, words_disagreeing, first_disagreement, seg1_words(first_disagreement), rtrim(pathname_((he1.dname), (he1.ename)), " >"), first_disagreement, seg2_words(first_disagreement), rtrim(pathname_((he2.dname), (he2.ename)), " >")); end; if error$occurred() then do; severity = max(severity, 3); return (FALSE); end; else return (TRUE); end compare_seg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* COMPARE ALL SEGMENTS ON COPY with SEGMENTS ON MASTER: */ /* 1) Get temp segments to hold dir entry header, and entry contents */ /* (segment) from master and copy tapes. */ /* 2) Initialize variables for "last entry read". This is needed since a */ /* backup tape can end with a complete segment while backup_dump thinks */ /* the segment was incomplete. Therefore, it rewrites the segment at */ /* the beginning of the next tape. Such duplicate entries are ignored */ /* via the "last entry read" variables. */ /* 3) Read master and copy segs in a loop until input is exhausted. */ /* Reading occurs in two steps: first read the header; then read the */ /* segment contents if header says this segment participates in the */ /* comparison. Some master segments may be omitted from comparison, */ /* because they aren't selected by the -select file. */ /* 4) If master entry wasn't selected, then skip it. */ /* 5) If master selected, compare the two segs. Count segs comparing equal. */ /* 6) Report how many entries and msfs were successfully compared. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ compare_segs: proc (); dcl (compare_continues, need_copy, need_master) bit(1), (error_count, extra_masters) fixed bin, MAX_ERRORS fixed bin int static options(constant) init(20); if mbf.hp = null then call ssu_$get_temp_segment (sci_ptr, "master header", mbf.hp); if mbf.segp = null then call ssu_$get_temp_segment (sci_ptr, "master segment", mbf.segp); call ssu_$get_temp_segment (sci_ptr, "copy header", cpbf.hp); call ssu_$get_temp_segment (sci_ptr, "copy segment", cpbf.segp); mlast.path = ""; mlast.sizes = 0; cplast.path = ""; cplast.sizes = 0; error_count, extra_masters = 0; compare_continues = TRUE; need_master = TRUE; need_copy = TRUE; do while (compare_continues); if need_copy then do; READ_COPY: if read_seg$header(cpbf, cplast, output) then do; state = read_seg$contents (cpbf, cplast, output); if state = READ_AGAIN then go to READ_COPY; else if state = OK then need_copy = FALSE; end; end; if need_master then do; if read_seg$header(mbf, mlast, input) then need_master = FALSE; end; if need_master & need_copy then /* When input */ compare_continues = FALSE; /* ends from */ /* both, compare */ /* is done. */ else if need_master then do; /* copy has seg */ /* not on master*/ compared.segs = compared.segs + 1; if (cphe.record_type = sec_dir | cphe.record_type = ndc_directory) & cphe.bitcnt > 0 then compared.msfs = compared.msfs + 1; call error (sci_ptr, -1, "^a: Segment ^d -- Copy contains segment not on master media. Copy: ^a", hhmmm(), compared.segs, rtrim(pathname_((cphe.dname), (cphe.ename))," >")); error_count = error_count + 1; if abort_sw then compare_continues = FALSE; else if error_count > MAX_ERRORS then compare_continues = FALSE; else need_copy = TRUE; end; else if skip_seg (mbf, cpbf, need_copy) then do; state = read_seg$skip_contents(mbf, mlast, input); need_master = TRUE; /* master seg */ end; /* not selected */ else if need_copy then do; /* master has seg*/ /* not on copy */ state = read_seg$skip_contents (mbf, mlast, input); need_master = state = NOMORE; if ^need_master then do; extra_masters = extra_masters + 1; call error (sci_ptr, -1, "^a: Segment ^d -- Master contains segment not on copy media. Master: ^a", hhmmm(), compared.segs+extra_masters, rtrim(pathname_((mhe.dname),(mhe.ename))," >")); error_count = error_count + 1; if abort_sw then compare_continues = FALSE; else if error_count > MAX_ERRORS then compare_continues = FALSE; else need_master = TRUE; end; end; else do; /* read rest of */ /* master */ state = read_seg$contents(mbf, mlast, input); if state ^= OK then /* master seg */ need_master = TRUE; /* incomplete. */ else do; /* compare segs */ if compare_seg(mbf, cpbf, compared.segs+1) then do; compared.segs = compared.segs + 1; if (mhe.record_type = sec_dir | mhe.record_type = ndc_directory) & mhe.bitcnt > 0 then compared.msfs = compared.msfs + 1; need_master, need_copy = TRUE; end; else do; error_count = error_count + 1; if abort_sw then compare_continues = FALSE; else if error_count > MAX_ERRORS then compare_continues = FALSE; else if mhe_name.dname <= cphe_name.dname & mhe_name.ename <= cphe_name.ename then need_master = TRUE; else need_copy = TRUE; end; end; end; end; call detach (addr(input), KEEP); call detach (addr(output), KEEP); call ioa_ (""); call ssu_$print_message (sci_ptr, 0, "^a: Compared ^d entr^[ies^;s^], including ^d multisegment file^[s^].^[ ^d comparison error^[ was^;s were^] found.^]^/", hhmmm(), compared.segs, compared.segs^=1, compared.msfs, compared.msfs^=1, error_count>0, error_count, error_count=1); if error_count > 0 then severity = max(severity,3); return; end compare_segs; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* COPYING ENTRIES: */ /* 1) Get temp segments to hold dir entry header, and entry contents */ /* (segment). */ /* 2) Initialize variables for last entry read. */ /* 3) Initialize map file. */ /* 4) Read segs in a loop until input is exhausted. */ /* 5) If entry just read is same as last entry, then skip it. This can */ /* occur if an entry just fits on the end of one tape, but was rewritten */ /* at the beginning of the next tape. */ /* 6) If not same as last entry, then write it onto the output. Put segment */ /* into the map. Count number of segs actually copied. */ /* 7) Report how many entries and msfs were copied. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ copy_segs: proc (); call ssu_$get_temp_segment (sci_ptr, "input header", inbf.hp); call ssu_$get_temp_segment (sci_ptr, "input segment", inbf.segp); inlast.path = ""; inlast.sizes = 0; state = READ_AGAIN; do while (read_seg$header(inbf, inlast, input) & state^=NOMORE); if skip_seg (inbf, inbf, FALSE) then state = read_seg$skip_contents(inbf, inlast, input); else do; state = read_seg$contents(inbf, inlast, input); if state = READ_AGAIN then; else if state = NOMORE then; else do; if write_seg(inbf, output) then do; call map_seg (inbf); copied.segs = copied.segs + 1; if (inhe.record_type = sec_dir | inhe.record_type = ndc_directory) & inhe.bitcnt > 0 then copied.msfs = copied.msfs + 1; end; else do; call error$fatal (sci_ptr, -1, "^a: FATAL ERROR: Too few output tapes to hold all copied files.", hhmmm()); end; end; end; end; call detach (addr(input), KEEP); call detach (addr(output), KEEP); call ioa_(""); call ssu_$print_message (sci_ptr, 0, "^a: Copied ^d entr^[ies^;y^], including ^d multisegment file^[s^].^/", hhmmm(), copied.segs, copied.segs^=1, copied.msfs, copied.msfs^=1); end copy_segs; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CLOSE/DETACH I/O SWITCHES: */ /* 1) Check if switch was even found (or if already destroyed). */ /* 2) If switch was used used for iox_$move_attach, move back the original */ /* attachment. */ /* 3) Otherwise, close an opened switch; detach an attached switch. */ /* 4) If disposition = DESTROY, then destroy the I/O switch. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ detach: proc (iop, disp); dcl iop ptr, disp fixed bin; dcl 1 io aligned based (iop), 2 header like in_out.header, 2 vol (0 refer (io.header.voln)) like in_out.vol; if io.iocbp = null then; else if io.mode = FOR_MOVE_ATTACH then do; call iox_$detach_iocb (io.iocbp, code); call iox_$move_attach (io.target_iocbp, io.iocbp, code); call iox_$destroy_iocb (io.target_iocbp, code); io.iocbp = null; end; else do; if io.iocbp -> iocb.open_descrip_ptr ^= null then do; if io.vfile.path ^= "" then do; call iox_$close (io.iocbp, code); call error (sci_ptr, code, "^/Closing ^a file: ^a", io.header.name, io.vfile.expath); end; else do; call iox_$close (io.iocbp, code); call error (sci_ptr, code, "^/^a: Closing ^a tape: ^a", hhmmm(), io.header.name, io.vol(io.tape.volx).name); end; end; if io.iocbp -> iocb.attach_descrip_ptr ^= null then do; if io.vfile.path ^= "" then do; call iox_$detach_iocb (io.iocbp, code); call error (sci_ptr, code, "^/Detaching ^a file: ^a", io.header.name, io.vfile.expath); end; else do; call iox_$detach_iocb (io.iocbp, code); call error (sci_ptr, code, "^/^a: Detaching ^a tape: ^a", hhmmm(), io.header.name, io.vol(io.tape.volx).name); if disp = KEEP then call ssu_$print_message (sci_ptr, 0, "^a: Dismounted ^a tape: ^a", hhmmm(), io.header.name, io.vol(io.tape.volx).name); end; end; end; if io.iocbp ^= null then if disp = DESTROY then do; call iox_$destroy_iocb (io.iocbp, code); io.iocbp = null; end; end detach; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ERROR REPORTING ROUTINES: */ /* 1) Nonfatal errors set a switch, which can be tested via error_occurred */ /* function. */ /* 2) Fatal errors abort the subsystem by calling the exit_proc, which */ /* branches to the EXIT label to exit the command. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl error_occurred_sw bit(1); error: proc options (variable); dcl code fixed bin(35) based (codep), codep 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); dcl CODE_ARG fixed bin int static options(constant) init(2), (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); call cu_$arg_ptr (CODE_ARG, codep, 0, 0); if code = 0 then return; if code = -1 then code = 0; error_occurred_sw = TRUE; call cu_$generate_call (ssu_$print_message, cu_$arg_list_ptr()); return; error$init: entry; error_occurred_sw = FALSE; return; error$occurred: entry returns (bit(1)); return (error_occurred_sw); error$fatal: entry options(variable); call cu_$arg_ptr (CODE_ARG, codep, 0, 0); if code = 0 then return; if code = -1 then code = 0; error_occurred_sw = TRUE; call ioa_ (""); call cu_$generate_call (ssu_$abort_subsystem, cu_$arg_list_ptr()); end error; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ARGUMENT GETTING FUNCTIONS: */ /* get_arg: Get next argument. */ /* get_arg_count: Get number of arguments. */ /* get_ctl_arg: Get next argument, which must be a control argument. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_arg: proc returns (bit(1)); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, argp, argl); return (TRUE); end; else return (FALSE); end get_arg; get_arg_count: proc returns (fixed bin); return (argn); end get_arg_count; get_ctl_arg: proc returns (bit(1)); dcl index builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), error_table_$bad_arg fixed bin(35) ext static; if get_arg() then if index(arg, "-") = 1 then return (TRUE); else call error$fatal (sci_ptr, error_table_$bad_arg, "^a.^/A control argument was expected.", arg); return (FALSE); end get_ctl_arg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* EXTRACT FINAL ENTRYNAME from pathname */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_entry: proc (path) returns (char(32)); dcl path char(168); dcl code fixed bin(35), dir char(168), ent char(32); dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35)); call expand_pathname_ (path, dir, ent, code); return (ent); end get_entry; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CONTROL ARG OPERAND GETTING FUNCTIONS: */ /* get_num_opt: Gets next arg, treats it as an integer operand, checks */ /* that its value is valid. */ /* get_opt: Gets next arg. */ /* */ /* Both allow the caller to specify whether the operand is required (an */ /* opt_desc is provided) or optional (opt_desc=""). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ get_num_opt: proc (arg_name, opt_desc, default_value, allowed_values) returns (bit(1)); dcl arg_name char(*), opt_desc char(*), default_value fixed bin, allowed_values (*) fixed bin; dcl valx fixed bin; dcl (convert, dim, hbound, lbound) builtin; dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), (error_table_$bad_arg, error_table_$noarg) fixed bin(35) ext static; if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, optp, optl); if verify (opt, "0123456789") > 0 then go to BAD_OPT; num_opt = convert (num_opt, opt); do valx = lbound(allowed_values,1) to hbound(allowed_values,1) while (num_opt ^= allowed_values(valx)); end; if valx <= hbound(allowed_values,1) then return (TRUE); else do; BAD_OPT: call error (sci_ptr, error_table_$bad_arg, "^a ^a ^a must be followed by a^[n^] ^a.^[ Default value is:^- ^d^;^s^]^[ Allowed ^[value is^;values are^]:^-^( ^d^)^]", arg_name, opt, arg_name, vowel(opt_desc), opt_desc, default_value ^= -1, default_value, ^(dim(allowed_values,1)=1 & default_value=allowed_values(1)), dim(allowed_values,1)=1, allowed_values); return (FALSE); end; end; else if opt_desc ^= "" then do; call error (sci_ptr, error_table_$noarg, "^/^a must be followed by a^[n^] ^a.^[ Default value is:^- ^d^;^s^]^[ Allowed ^[value is^;values are^]:^-^( ^d^)^]", arg_name, vowel(opt_desc), opt_desc, default_value ^= -1, default_value, ^(dim(allowed_values,1)=1 & default_value=allowed_values(1)), dim(allowed_values,1)=1, allowed_values); return (FALSE); end; end get_num_opt; get_opt: proc (arg_name, opt_desc) returns (bit(1)); dcl arg_name char(*), opt_desc char(*); dcl (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant), error_table_$noarg fixed bin(35) ext static; if argx < argn then do; argx = argx + 1; call ssu_$arg_ptr (sci_ptr, argx, optp, optl); if index(opt, "-") = 1 then do; /* options cannot*/ argx = argx - 1; /* look like */ go to NO_OPT; /* control args */ end; else return (TRUE); end; else NO_OPT: if opt_desc ^= "" then do; call error (sci_ptr, error_table_$noarg, "^/^a must be followed by a^[n^] ^a.", arg_name, vowel(opt_desc), opt_desc); return (FALSE); end; return (FALSE); end get_opt; vowel: proc (str) returns (bit(1)); /* does opt_desc */ /* begin with a */ /* vowel? */ dcl str char(*), (FALSE init("0"b), TRUE init("1"b)) bit(1) int static options(constant); if search ("aeiouAEIOU", substr(str,1,1)) > 0 then return (TRUE); else return (FALSE); end vowel; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* MAJOR OPERATION HEADER: */ /* Pretty-print a header describing: */ /* 1) the name of the operation about to begin; */ /* 2) the input media; */ /* 3) the output media. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ header: proc (op, in, out); dcl op char(*), 1 in aligned like input, 1 out aligned like output; dcl (from, to) char(32) varying, indent fixed bin; dcl SP char(1) int static options(constant) init(" "); call ioa_ (""); call ssu_$print_message (sci_ptr, 0, "^a: ^a...", hhmmm(), op); call label (from, "from", in); call label (to, "to", out); indent = max (length(from), length(to)) + length(SP); call medium (from, indent, in); call medium (to, indent, out); return; label: proc (lab, name, out); /* compute value */ /* of media label*/ dcl lab char(32) varying, name char(*), 1 out aligned like output; lab = " "; lab = lab || name; lab = lab || " "; lab = lab || out.header.name; if out.vfile.path ^= "" then lab = lab || " file:"; else if out.tape.voln = -1 then lab = lab || " sink:"; else if out.tape.voln ^= 1 then lab = lab || " tapes:"; else lab = lab || " tape:"; end label; medium: proc (lab, indent, out); /* print medium */ /* label & value */ dcl lab char(32) varying, indent fixed bin, 1 out aligned like output; dcl code fixed bin(35), len fixed bin, maxlen fixed bin, printed fixed bin, x fixed bin; if out.vfile.path ^= "" then call ioa_ ("^a^vt ^a", lab, indent, out.vfile.expath); else if out.tape.voln = -1 then call ioa_ ("^a^vt ^a", lab, indent, "discard"); else if out.tape.voln > 0 then do; len = indent-1; maxlen = get_line_length_$switch (null, code); if code ^= 0 then maxlen = 79; printed = 0; do x = 1 to out.tape.voln; if len + length(SP) + length(out.vol(x).name) > maxlen then do; call ioa_ ("^a^vt^vs^v( ^a^)", lab, indent, printed, x-1-printed, out.vol(*).name); printed = x-1; lab = ""; end; end; call ioa_ ("^a^vt^vs^v( ^a^)", lab, indent, printed, x-1-printed, out.vol(*).name); end; end medium; end header; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* CURRENT TIME: in form of ^Hd^99v.9MH (ie, HHMM.M). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ hhmmm: proc returns (char(6) varying); dcl 1 time_form aligned, 2 hhmm char(4) unal, 2 ss pic "99" unal, result char(6) varying; dcl time builtin; string(time_form) = substr(time(),1,length(string(time_form))); result = time_form.hhmm; result = result || "."; result = result || ltrim(char(divide(time_form.ss, 6, 1, 0))); return (result); end hhmmm; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* INITIALIZATION. */ /* 1) Initialize variables holding argument values. */ /* 2) Initialize other program data variables. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ initialize_args: proc; dcl UNSET char(1) int static options(constant) init("~"), UNSPECIFIED ptr int static options(constant) init(null); in_outp = UNSPECIFIED; if operation_wanted = COMPARE then input.header.name = "master"; else input.header.name = "input"; input.iocbp = null; input.target_iocbp = null; input.mode = 0; input.recx = 0; input.vfile.path, input.vfile.expath = ""; input.vfile.charpos = 0; input.tape.voln, input.tape.volx = 0; input.tape.track, input.tape.density = 0; input.vol(*) = ""; output = input; if operation_wanted = COMPARE then output.header.name = "copy"; else output.header.name = "output"; select = output, by name; select.name = "select"; select.listp = null; select.select_sw = FALSE; map = output, by name; map.name = "map"; map.vfile.path = UNSET; map_prev = map; map_prev.name = "map_prev"; abort_sw = FALSE; maximize_devices_sw = FALSE; trace = OFF; inbf.blrh.zz1, inbf.blrh.zz2 = BLRH_DELIMITER; inbf.blrh.english = BLRH_ENGLISH; inbf.blrh.hl, inbf.blrh.segl = 0; inbf.hp, inbf.segp = null; cpbf = inbf; copied, compared = 0; pp = addr(pp); /* Used in an */ /* include file */ call tape_drive$init(); end initialize_args; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ADD A MAP ENTRY for a segment. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl map_last_dir char(168); map_seg: proc (bf); dcl 1 bf aligned like inbf, bp ptr, 1 b aligned like br based(bp), 1 he aligned like h based (bf.hp), nn fixed bin, np ptr, nx fixed bin, 1 n (nn) aligned based (np), 2 l fixed bin(17) uns unal, 2 pad bit(19) unal, 2 string char(32) unal, 1 seg aligned, 2 type char(10), 2 blocks fixed bin(9), 2(dtem, dtd, dtu, dtcm) fixed bin(52); dcl TYPE_STRING (0:20) char(10) aligned int static options(constant) init ( "link", "segment", "directory", "directory", (15)*, "segment", "directory"); dcl sys_info$page_size fixed bin external static, sys_info$seg_size_256K fixed bin external static; if map.vfile.path = "" then return; if map_last_dir ^= he.dname then do; map_last_dir = he.dname; call backup_map_$directory_line (addr(he.dname), he.dlen); end; seg.type = TYPE_STRING (he.record_type); bp = ptr (addr(he), he.bp); seg.blocks = min (bin (bp -> br (1).cl, 9), divide (sys_info$seg_size_256K + sys_info$page_size - 1, sys_info$page_size, 17, 0)); seg.dtem = bin (b.dtbm, 52, 0); seg.dtd = bin (b.dtd, 52, 0); seg.dtu = bin (b.dtu, 52, 0); seg.dtcm = bin (b.dtm, 52, 0); call backup_map_$detail_line2 (he.ename, seg.blocks, seg.type, clock(), seg.dtem, seg.dtd, seg.dtu, seg.dtcm); np = ptr (addr(he), b.namerp); nn = bin (b.nnames, 17); if he.record_type ^= ndc_directory_list then do nx = 2 to nn; call backup_map_$name_line (addr(n.string(nx)), (n.l(nx))); end; end map_seg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* BACKUP MAP INITIALIZATION: */ /* 1) Return if -map not given. */ /* 2) The backup_map_ subr does all its output on the map I/O switch, so */ /* attach it as a synonym for the switch our map file is attached thru. */ /* 3) Put description of output medium in map header line, along with */ /* current date, and name of -select file. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ map_seg$init: proc (out); dcl 1 out aligned like output; dcl date_time_string char(40) varying, map_header char(300) varying, map_line char(300), out_header char(128) varying; if map.vfile.path = "" then return; call iox_$attach_name ("map", map_prev.iocbp, "syn_ " || map.iocbp -> iocb.name, null, code); if code = error_table_$not_detached then do; call attach (addr(map_prev), FOR_MOVE_ATTACH); call iox_$move_attach (map_prev.iocbp, map_prev.target_iocbp, code); call error$fatal (sci_ptr, code, "^/FATAL ERROR: Moving attachment of map switch."); call iox_$attach_name ("map", map_prev.iocbp, "syn_ " || map.iocbp -> iocb.name, null, code); end; call error$fatal (sci_ptr, code, "^/FATAL ERROR: Attaching map switch as synonym for ^a.", map.iocbp -> iocb.name); if out.vfile.path ^= "" then out_header = "File: " || get_entry (out.vfile.path); else if out.tape.voln > 1 then out_header = "Tape: " || out.vol(1).name; else out_header = "discard sink"; call backup_map_$init_for_cdt (out_header); date_time_string = date_time_$format ("date_time", clock(), "", ""); call backup_util$idline (map.vfile.expath, (date_time_string), addr(map_line), length(map_line)); map_line = out_header; call backup_map_$tapes (addr(map_line), length(rtrim(map_line))); map_header = rtrim(ME); map_header = map_header || " version 1.0"; if select.vfile.path ^= "" then do; map_header = map_header || " -select "; map_header = map_header || select.vfile.expath; end; map_line = map_header; call backup_map_$beginning_line (clock(), addr(map_line), length(map_line)); map_last_dir = ""; end map_seg$init; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* BACKUP MAP NEW OUTPUT TAPE: */ /* 1) Change name of output tape in the map. */ /* 2) Repeat directory name at top of new map page. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ map_seg$new_tape: proc (out); dcl 1 out aligned like output; dcl map_line char(300); if map.vfile.path = "" then return; if out.tape.voln > 0 then do; map_line = "Tape: " || out.vol(out.tape.volx).name; call backup_map_$tapes (addr(map_line), length(rtrim(map_line))); end; call backup_map_$heading_line(); map_last_dir = ""; end map_seg$new_tape; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* BACKUP MAP TERMINATION: */ /* 1) Detach synonym for map switch. */ /* 2) Close the map file. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ map_seg$term: proc; dcl code fixed bin(35); if map.vfile.path = "" then; else do; if map_prev.iocbp ^= null then do; call backup_map_$terminal_line (clock(), 0); call backup_map_$detach_for_cdt (code); call detach (addr(map_prev), DESTROY); call detach (addr(map), DESTROY); end; end; end map_seg$term; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* MOUNT NEXT TAPE: */ /* 1) Detach current input or output tape. */ /* 2) If no more tapes exist, return FALSE. */ /* 3) Otherwise, select drive on which to mount tape (if -maxdv given). */ /* 4) Attach and open the tape, via tape_mult_. For stream_output */ /* openings, set mode to asynchronous. This means we must do an */ /* error_count operation after every backup logical record, to ensure */ /* that it gets completely written to tape. */ /* 5) Report time to tape mount to the user. */ /* 6) Find out for sure (from RCP) which tape drive the tape was mounted on */ /* (if -maxdv given). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ mount_next_tape_vol: proc (io) returns (bit(1)); dcl 1 io aligned like input; dcl atd char(256) varying, code fixed bin(35); if io.iocbp -> iocb.open_descrip_ptr ^= null then call detach (addr(io), KEEP); if io.tape.volx >= io.tape.voln then return (FALSE); io.tape.volx = io.tape.volx + 1; if io.vol(io.tape.volx).device ^= "" then call tape_drive$select_another_device (io); else call tape_drive$select_a_device (io); atd = "tape_mult_ " || rtrim(io.vol(io.tape.volx).name); if io.mode = Stream_output | (^maximize_devices_sw & io.header.name = "output" & operation_wanted = COPY_AND_COMPARE) then atd = atd || " -write"; if io.vol(io.tape.volx).device ^= "" then do; atd = atd || " -device "; atd = atd || rtrim(io.vol(io.tape.volx).device); end; atd = atd || " -density "; atd = atd || ltrim(char(io.tape.density)); atd = atd || " -track "; atd = atd || ltrim(char(io.tape.track)); atd = atd || " -error_tally"; call ssu_$print_message (sci_ptr, 0, "^a: Mounting ^a tape ^a^[ on ^a^;^s^].^[^/ (^a)^]", hhmmm(), io.header.name, io.vol(io.tape.volx).name, io.vol(io.tape.volx).device ^= "", io.vol(io.tape.volx).device, trace ^= OFF, atd); call iox_$attach_ptr (io.iocbp, (atd), null, code); call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Attaching ^a tape ^a for ^[reading^;writing^].", hhmmm(), io.header.name, io.vol(io.tape.volx).name, io.mode=Stream_input); call iox_$open (io.iocbp, io.mode, ""b, code); call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Opening ^a tape ^a for ^[reading^;writing^].", hhmmm(), io.header.name, io.vol(io.tape.volx).name, io.mode=Stream_input); if io.mode = Stream_output then do; call iox_$modes (io.iocbp, "async", "", code); call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Setting aync mode on ^a tape: ^a", hhmmm(), io.header.name, io.vol(io.tape.volx).name); end; call tape_drive$find_device (io.vol(io.tape.volx)); call ssu_$print_message (sci_ptr, 0, "^a: Finished mounting ^a tape: ^a", hhmmm(), io.header.name, io.vol(io.tape.volx).name); return (TRUE); end mount_next_tape_vol; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* PROCESS ARGUMENTS */ /* 1) Match argument to ctl_arg name and operands. */ /* 2) Validate that proper input and output media are specified. */ /* 3) Complete specification of map pathname if -map is given. */ /* */ /* NOTE: Several control arguments affect either input or output media, */ /* depending upon whether -input_XXX or -output_XXX control arg was */ /* most recently given. in_outp records this choice. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ process_args: proc; dcl UNSET char(1) int static options(constant) init("~"), UNSPECIFIED ptr int static options(constant) init(null), VAL_7_9 (2) fixed bin int static options(constant) init(7, 9), VAL_8_16_62 (3) fixed bin int static options(constant) init(800, 1600, 6250); dcl opt_desc char(32); if get_arg_count() = 0 then call error$fatal (sci_ptr, error_table_$wrong_no_of_args, "^/Usage: ^a INPUT_SPEC OUTPUT_SPEC^[ {-compare}^] {-control_args}", ME, operation_wanted = COPY); CTL_ARG_LOOP: do while (get_ctl_arg ()); if arg = "-input_volume" | arg = "-ivol" then do; in_outp = addr(input); SET_REEL: in_out.tape.voln = 0; in_out.vol(*) = ""; input.tape.track = 9; input.tape.density = 1600; in_out.vfile.path = ""; opt_desc = in_out.header.name || " tape volume name"; if get_opt (arg, opt_desc) then do; in_out.tape.voln = 1; in_out.vol(1).name = opt; end; do while (get_opt ("", "")); if in_out.tape.voln >= hbound(in_out.vol,1) then call error (sci_ptr, error_table_$too_many_names, "^a ^a.^/Only ^d names may be given.", arg, opt, hbound(in_out.vol,1)); else do; in_out.tape.voln = in_out.tape.voln + 1; in_out.vol(in_out.tape.voln).name = opt; end; end; end; else if arg = "-input_file" | arg = "-if" then do; in_outp = addr(input); SET_PATH: in_out.tape.voln = 0; in_out.vol(*) = ""; in_out.tape.track, in_out.tape.density = 0; in_out.vfile.path = ""; opt_desc = in_out.header.name || " file pathname"; if get_opt (arg, opt_desc) then do; if in_out_selected() then do; in_out.vfile.path = opt; call absolute_pathname_ (in_out.vfile.path, in_out.vfile.expath, code); call error (sci_ptr, code, "^a ^a", arg, opt); if code = 0 then in_out.vfile.expath = get_shortest_path_ (in_out.vfile.expath); end; end; end; else if arg = "-output_volume" | arg = "-ovol" then do; in_outp = addr(output); go to SET_REEL; end; else if arg = "-output_file" | arg = "-of" then do; in_outp = addr(output); go to SET_PATH; end; else if (arg = "-output_discard" | arg = "-od") & mod(operation_wanted,2) = COPY then do; in_outp = addr(output); in_out.tape.voln = -1; in_out.vol(*) = ""; in_out.tape.track, in_out.tape.density = 0; in_out.vfile.path = ""; end; else if (arg = "-master_volume" | arg = "-mvol") & operation_wanted = COMPARE then do; in_outp = addr(input); go to SET_REEL; end; else if (arg = "-copy_volume" | arg = "-cvol") & operation_wanted = COMPARE then do; in_outp = addr(output); go to SET_REEL; end; else if arg = "-track" | arg = "-tk" then do; if get_num_opt (arg, "tape track specification", 9, VAL_7_9) then do; if in_out_selected() then in_out.tape.track = num_opt; end; end; else if arg = "-density" | arg = "-den" then do; if get_num_opt (arg, "tape density specification", 1600, VAL_8_16_62) then do; if in_out_selected() then in_out.tape.density = num_opt; end; end; else if arg = "-abort" then abort_sw = TRUE; else if arg = "-no_abort" | arg = "-nabort" then abort_sw = FALSE; else if arg = "-trace" then do; if get_opt ("", "") then do; if opt = "rejects" | opt = "reject" | opt = "rej" then trace = REJECTS; else if opt = "off" then trace = OFF; else if opt = "copy" | opt = "cp" then trace = COPY; else if opt = "compare" | opt = "cmp" then trace = COMPARE; else if opt = "all" | opt = "a" then trace = COPY_AND_COMPARE; else call error (sci_ptr, error_table_$bad_opt, "^a ^a^/Allowed trace types are: off rejects, rej copy, cp compare, cmp all, a", arg, opt); end; else if operation_wanted = COMPARE then trace = COMPARE; else trace = COPY; end; else if arg = "-no_trace" | arg = "-ntrace" then trace = OFF; else if arg = "-maximize_devices" | arg = "-maxdv" then maximize_devices_sw = TRUE; else if arg = "-no_maximize_devices" | arg = "nmaxdv" then maximize_devices_sw = FALSE; else if arg = "-select" | arg = "-slct" then do; opt_desc = select.header.name || " file pathname"; if operation_wanted = COMPARE then /* -select path */ /* optional for */ /* old compare ep*/ if get_opt ("", "") then go to SET_SELECT; else select.select_sw = TRUE; else if get_opt (arg, opt_desc) then do; SET_SELECT: select.vfile.path = opt; call absolute_pathname_ (select.vfile.path, select.vfile.expath, code); call error (sci_ptr, code, "^a ^a", arg, opt); if code = 0 then select.vfile.expath = get_shortest_path_ (select.vfile.expath); end; end; else if arg = "-no_select" | arg = "-nslct" then do; select.vfile.path = ""; select.select_sw = FALSE; end; else if (arg = "-compare" | arg = "-cmp") & mod(operation_wanted,2) = COPY then operation_wanted = COPY_AND_COMPARE; else if (arg = "-no_compare" | arg = "-ncmp") & mod(operation_wanted,2) = COPY then operation_wanted = COPY; else if arg = "-map" & mod(operation_wanted,2) = COPY then do; map.vfile.path = ""; /* Use default */ /* map path */ if get_opt ("", "") then do; /* optional path */ map.vfile.path = opt; call absolute_pathname_$add_suffix (map.vfile.path, "map", map.vfile.expath, code); call error (sci_ptr, code, "^a ^a", arg, opt); if code = 0 then map.vfile.expath = get_shortest_path_ (map.vfile.expath); end; end; else if (arg = "-no_map" | arg = "-nmap") & mod(operation_wanted,2) = COPY then do; map.vfile.path = UNSET; end; else call error (sci_ptr, error_table_$bad_opt, "^a", arg); end CTL_ARG_LOOP; if error$occurred() then /* stop now if */ call error$fatal (sci_ptr, -1); /* ctl arg errs */ if input.tape.voln = 0 & input.vfile.path = "" then call error$fatal (sci_ptr, error_table_$noarg, " An input specification must be given by -input_volume or -input_file control arguments."); if output.tape.voln = 0 & output.vfile.path = "" then call error$fatal (sci_ptr, error_table_$noarg, " An output specification must be given by -output_volume, -output_file or -output_discard control arguments."); if input.tape.density = 0 then input.tape.density = 1600; if input.tape.track = 0 then input.tape.track = 9; if output.tape.density = 0 then output.tape.density = 1600; if output.tape.track = 0 then output.tape.track = 9; if output.tape.voln = -1 & operation_wanted = COPY_AND_COMPARE then call error$fatal (sci_ptr, error_table_$inconsistent, "^/-compare is inconsistent with -output_discard."); if map.vfile.path = UNSET then map.vfile.path = ""; else if map.vfile.path = "" then do; if output.vfile.path ^= "" then map.vfile.path = get_entry(output.vfile.path); else if output.tape.voln > 0 then map.vfile.path = output.vol(1).name; else if select.vfile.path ^= "" then map.vfile.path = get_entry (select.vfile.path); else map.vfile.path = unique_chars_(""b); call absolute_pathname_$add_suffix (map.vfile.path, "map", map.vfile.expath, code); call error$fatal (sci_ptr, code, "Adding map suffix to -output_file or -output_volume name ^a.", map.vfile.path); map.vfile.expath = get_shortest_path_ (map.vfile.expath); end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ARG CONSISTENCY CHECKER: */ /* 1) Check for -input_XXX or -output_XXX having been specified, prior to */ /* receiving -track or -density. */ /* 2) If neither -input_XXX nor -output_XXX was given, diagnose error. */ /* 3) Otherwise return TRUE to caller. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ in_out_selected: proc returns (bit(1)); if in_outp = UNSPECIFIED then do; call error (sci_ptr, error_table_$inconsistent, "^/^a must follow -input_volume, -input_file, -output_volume, -output_file, or^/-output_discard.", arg); return (FALSE); end; return (TRUE); end in_out_selected; end process_args; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* READ LINE FROM FILE: */ /* 1) Read line from -select file. Remove trailing NL. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl line char(300) varying; read_line: proc (inp) returns (bit(1)); dcl inp ptr, 1 in aligned like select based(inp); dcl code fixed bin(35); dcl 1 line_buffer aligned based(addr(line)), 2 l fixed bin(21), 2 data char(300); dcl HT_SP char(2) int static options(constant) init(" "), NL char(1) int static options(constant) init(" "); RE_READ: call iox_$get_line (in.iocbp, addr(line_buffer.data), length(line_buffer.data), line_buffer.l, code); if code = 0 then do; /* remove NL */ in.recx = in.recx + 1; line = substr (line, 1, length(line) - length(NL)); line = ltrim(line, HT_SP); line = rtrim(line, HT_SP); if line = "" then go to RE_READ; /* blank line */ return (TRUE); end; else if code = error_table_$end_of_info then do; line = ""; return (FALSE); end; else call error$fatal (sci_ptr, code, "^/FATAL ERROR: Reading line ^d from ^a file ^a.", in.recx, in.name, in.vfile.expath); end read_line; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* READ BACKUP LOGICAL RECORD HEADER: */ /* Read the header and segment attributes of next segment from input */ /* medium. If it is a segment we are interested in, then we will read */ /* segment contents later; otherwise, we will iox_$position (skip) over the */ /* segment contents. */ /* */ /* 1) Decide whether input is from vfile_ or tape. */ /* 2) If from vfile_, read size fields from backup logical record header */ /* (blrh), followed by the attributes of the segment. */ /* 3) If from tape, read backup logical record header itself from tape, */ /* followed by the attributes of the segment. If current tape is */ /* exhausted, mount next tape and try reading blrh again. */ /* 4) Return TRUE if another header exists, FALSE if input is exhausted. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ read_seg$header: proc (bf, last, in) returns(bit(1)); dcl 1 bf aligned like inbf, 1 he aligned like h based (bf.hp), 1 last aligned like inlast, 1 in aligned like input; dcl 1 blrh aligned like inbf.blrh based, 1 blrh_sizes aligned like inbf.blrh.sizes based, readl fixed bin(21), readneed fixed bin(21); dcl size builtin; if in.vfile.path ^= "" then do; /* read from file*/ call iox_$get_chars (in.iocbp, addr(bf.blrh.sizes), size(blrh_sizes) * CHARS_PER_WORD, readl, code); if code = 0 & readl = size(blrh_sizes) * CHARS_PER_WORD then do; in.vfile.charpos = in.vfile.charpos + readl; bf.blrh.zz1, bf.blrh.zz2 = BLRH_DELIMITER; bf.blrh.english = BLRH_ENGLISH; call iox_$get_chars (in.iocbp, addr(he), bf.blrh.hl * CHARS_PER_WORD, readl, code); if code = 0 & readl = bf.blrh.hl * CHARS_PER_WORD then do; in.vfile.charpos = in.vfile.charpos + readl; return (TRUE); end; end; if code = error_table_$end_of_info then return (FALSE); else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Reading header of record ^d of ^a file:^/ ^a.", hhmmm(), in.recx+1, in.header.name, in.vfile.expath); end; else if in.iocbp -> iocb.open_descrip_ptr = null then return (FALSE); /* all input */ /* tapes */ /* exhausted */ else do; /* read from tape*/ REREAD: call iox_$get_chars (in.iocbp, addr(bf.blrh), size(blrh) * CHARS_PER_WORD, readl, code); if code = 0 & readl = size(blrh) * CHARS_PER_WORD then do; if bf.blrh.zz1 ^= BLRH_DELIMITER | bf.blrh.zz2 ^= BLRH_DELIMITER | bf.blrh.english ^= BLRH_ENGLISH then call error$fatal (sci_ptr, -1, "^a: FATAL ERROR: Reading header of record ^d of ^a file:^/ ^a. Record did not begin with a proper backup logical record header. Header.zz1: ^a Header.english: ^a Header.zz2: ^a", hhmmm(), in.recx, in.header.name, in.vol(in.tape.volx).name, bf.blrh.zz1, bf.blrh.english, bf.blrh.zz2); /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* blrh + he, and seg are written in 256-word blocks, so we must round up */ /* the amount we read to the next 256-word boundary. At this point, */ /* blrh-words have already been read. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ readneed = bf.blrh.hl + size(blrh) + BLOCK_SIZE - 1; readneed = readneed - mod(readneed, BLOCK_SIZE) - size(blrh); call iox_$get_chars (in.iocbp, addr(he), readneed * CHARS_PER_WORD, readl, code); if code = 0 & readl = readneed * CHARS_PER_WORD then do; if last.dir ^= "" & last.path.dir = he.dname & last.path.ent = he.ename & last.sizes.he = bf.blrh.hl & last.sizes.seg= bf.blrh.segl then do; call ssu_$print_message (sci_ptr, 0, "^a: Skipping duplicate ^a segment:^/ ^a", hhmmm(), in.header.name, rtrim(pathname_(last.path.dir, last.path.ent), " >")); readneed = bf.blrh.segl + BLOCK_SIZE - 1; readneed = readneed - mod(readneed, BLOCK_SIZE); call iox_$position (in.iocbp, 3, readneed * CHARS_PER_WORD, code); if code = 0 then go to REREAD; end; return (TRUE); end; end; if code = error_table_$end_of_info then do; if mount_next_tape_vol (in) then go to REREAD; else return (FALSE); end; else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Reading header of record ^d of ^a tape: ^a.", hhmmm(), in.recx+1, in.header.name, in.vol(in.tape.volx).name); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* READ SEGMENT CONTENTS: */ /* 1) If input from vfile, read segment contents based upon sizes from blrh. */ /* 2) If input from tape, read segment contents based upon sizes from blrh. */ /* Record pathname of segment as the last one which was read completely */ /* from tape. */ /* 3) In either case, there are three possible outcomes: reading segment */ /* contents was successful (OK); input was exhausted (NOMORE); segment */ /* contents was incomplete on this tape, need to read header from next */ /* tape (READ_AGAIN). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ read_seg$contents: entry (bf, last, in) returns (fixed bin); if in.vfile.path ^= "" then do; /* read from file*/ if bf.blrh.segl > 0 then do; call iox_$get_chars (in.iocbp, bf.segp, bf.blrh.segl * CHARS_PER_WORD, readl, code); if code = 0 & readl = bf.blrh.segl * CHARS_PER_WORD then do; in.vfile.charpos = in.vfile.charpos + readl; in.recx = in.recx + 1; return (OK); end; end; else do; in.recx = in.recx + 1; return (OK); end; if code = error_table_$end_of_info then return (NOMORE); else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Reading contents of record ^d of ^a file:^/ ^a.", hhmmm(), in.recx+1, in.header.name, in.vfile.expath); end; else do; /* read from tape*/ if bf.blrh.segl > 0 then do; readneed = bf.blrh.segl + BLOCK_SIZE - 1; readneed = readneed - mod(readneed, BLOCK_SIZE); call iox_$get_chars (in.iocbp, bf.segp, readneed * CHARS_PER_WORD, readl, code); if code = 0 & readl = readneed * CHARS_PER_WORD then do; SETREAD: in.recx = in.recx + 1; last.path.dir = he.dname; last.path.ent = he.ename; last.sizes.he = bf.blrh.hl; last.sizes.seg= bf.blrh.segl; return (OK); end; end; else go to SETREAD; if code = error_table_$end_of_info then do; if mount_next_tape_vol (in) then return (READ_AGAIN); else return (NOMORE); end; else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Reading contents of record ^d of ^a tape: ^a", hhmmm(), in.recx+1, in.header.name, in.vol(in.tape.volx).name); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* SKIP SEGMENT CONTENTS: */ /* 1) If input from vfile, skip segment contents based upon sizes from blrh. */ /* 2) If input from tape, skip segment contents based upon sizes from blrh. */ /* Record pathname of segment as the last one which was read completely */ /* from tape. */ /* 3) In either case, there are three possible outcomes: skipping segment */ /* contents was successful (OK); input was exhausted (NOMORE); segment */ /* contents was incomplete on this tape, need to read header from next */ /* tape (READ_AGAIN). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ read_seg$skip_contents: entry (bf, last, in) returns (fixed bin); if in.vfile.path ^= "" then do; /* read from file*/ if bf.blrh.segl > 0 then do; readl = bf.blrh.segl * CHARS_PER_WORD; call iox_$position (in.iocbp, 2, in.vfile.charpos + readl, code); if code = 0 then do; in.vfile.charpos = in.vfile.charpos + readl; in.recx = in.recx + 1; return (OK); end; end; else do; in.recx = in.recx + 1; return (OK); end; if code = error_table_$end_of_info then return (NOMORE); else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Skipping contents of record ^d of ^a file:^/ ^a", hhmmm(), in.recx+1, in.header.name, in.vfile.expath); end; else do; /* read from tape*/ if bf.blrh.segl > 0 then do; readneed = bf.blrh.segl + BLOCK_SIZE - 1; readneed = readneed - mod(readneed, BLOCK_SIZE); call iox_$position (in.iocbp, 3, readneed * CHARS_PER_WORD, code); if code = 0 then do; SETSKIP: in.recx = in.recx + 1; last.path.dir = he.dname; last.path.ent = he.ename; last.sizes.he = bf.blrh.hl; last.sizes.seg= bf.blrh.segl; return (OK); end; end; else go to SETSKIP; if code = error_table_$end_of_info then do; if mount_next_tape_vol (in) then return (READ_AGAIN); else return (NOMORE); end; else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Skipping contents of record ^d of ^a tape: ^a", hhmmm(), in.recx+1, in.header.name, in.vol(in.tape.volx).name); end; end read_seg$header; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* PERFORM -select SELECTIONS: */ /* skip_seg chooses which records from the master tape should be selected */ /* for copying onto copy tape, or for comparision with contents of copy */ /* tape. */ /* */ /* SELECT INITIALIZATION: */ /* 1) Get temp segment to hold -select data. */ /* 2) Read lines from -select file, and add them to -select data list. */ /* */ /* PARSE SELECT LINES: */ /* 1) Lines beginning with ^ identify entries NOT to be selected. */ /* 2) Lines ending with >** identify entire subtrees to be selected or */ /* rejected. */ /* */ /* SELECT TERMINATION: */ /* 1) Report lines in -select data which were not matched by entries on the */ /* master tape. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ skip_seg$init: proc; dcl 1 list aligned based (select.listp), 2 n fixed bin, 2 x fixed bin, 2 e (0 refer (list.n)), 3 path char(168) varying, 3 type fixed bin(17) unal, 3 dont_select fixed bin(1) uns unal, 3 subtree bit(1) unal, 3 matched bit(1) unal, 3 added_as_msf bit(1) unal, 3 pad1 bit(14) unal; dcl (UNKNOWN init(-1), LINK init(0), SEG init(1), DIR init(2), MSF init(3)) fixed bin int static options(constant), TYPE_NAME (-1:3) char(7) varying int static options(constant) init( "UNKNOWN", "LINK", "SEG", "DIR", "MSF"); call ssu_$get_temp_segment (sci_ptr, "select_paths", select.listp); list.n, list.x = 0; do while (read_line(addr(select))); call add_to_select_list (line, UNKNOWN, FALSE, FALSE); end; return; add_to_select_list: proc (line, type, matched, added_as_msf); dcl line char(*) varying, type fixed bin, matched bit(1), added_as_msf bit(1); dcl 1 en aligned like list.e; list.n = list.n + 1; if substr (line, 1, length("^")) = "^" then do; en.path = substr (line, 2); en.dont_select = 1; end; else do; en.path = line; en.dont_select = 0; end; en.type = type; en.matched = matched; en.added_as_msf = added_as_msf; en.pad1 = ""b; en.subtree = FALSE; if length (en.path) >= length (">**") then if substr(en.path, length(en.path)-length(">**")+1, length(">**")) = ">**" then do; en.path = substr(en.path, 1, length(en.path)-length(">**")); en.subtree = TRUE; end; list.e(list.n) = en; end add_to_select_list; skip_seg$term: entry; dcl header_needed bit(1); if select.vfile.path = "" then return; header_needed = TRUE; do list.x = lbound(list.e,1) to hbound(list.e,1); if ^list.e(list.x).matched then do; if header_needed then do; call ioa_ (""); call error (sci_ptr, -1, "^a: Unmatched Select Entries:", hhmmm()); header_needed = FALSE; end; call ioa_ ("^[^^^; ^]^a^[>**^]", list.e(list.x).dont_select=1, list.e(list.x).path, list.e(list.x).subtree); severity = 2; end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* MATCH SEGS AGAINST -select FILE SPECS: */ /* There are several cases of selection, which are dealt with separately. */ /* 1) -select was not specified */ /* => all master segs are matched. */ /* 2) compare_dump_tape -select was given without a SELECT_PATH (an */ /* obsolete feature implemented for compatibility sake) */ /* => master seg whose path matches copy seg path is "selected"; */ /* other master segs are not matched. */ /* 3) copy_dump_tape -select SELECT_PATH */ /* compare_dump_tape -select SELECT_PATH */ /* => use specs in SELECT_PATH to determine match status of master */ /* segs. */ /* */ /* Type 3 selection will be explained below, since it is somewhat complex. */ /* If -trace XXX is given, then selected or rejected master seg paths are */ /* printed. The first set of code below sets up that tracing. */ /* */ /* The following selection results are possible: */ /* SELECTED: master seg path exactly matches path in -select file. */ /* SELECTED_SUBTREE: master seg path is in the subtree below one of the */ /* paths in the -select file, and subtree selection was specified for */ /* that path. */ /* SUPERIOR_DIR: master seg is an entry superior in the hierarchy tree to */ /* one of the paths in the -select file. */ /* REJECTED: master seg path exactly matches a ^path in -select file. */ /* REJECTED_SUBTREE: master seg path is in the subtree below one of the */ /* ^paths in the -select file, subtree selection was specified, and the */ /* master seg did not match a later path in the -select file. NOTE: */ /* order of paths in -select file is important; they should be sorted by */ /* pathname. */ /* REJECTED_SUPERIOR_DIR: master seg is an entry superior in the hierarchy */ /* tree to one of the ^paths in the -select file and the master seg did */ /* not match a later path in the -select file. */ /* UNMATCHED: master seg did not fit one of the criteria above. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl (UNMATCHED init(0), SUPERIOR_DIR init(1), REJECTED_SUPERIOR_DIR init(2), SELECTED init(3), REJECTED init(4), SELECTED_SUBTREE init(5), REJECTED_SUBTREE init(6)) fixed bin int static options(constant), STATE_NAME (0:6) char(16) varying int static options(constant) init( "unmatched", "superior dir", "rejected sup dir", "selected", "rejected", "selected subtree", "rejected subtree"); skip_seg: entry (mbf, cpbf, need_copy) returns(bit(1)); dcl 1 mbf aligned like inbf, 1 cpbf aligned like inbf, need_copy bit(1); dcl 1 seg aligned, 2 path char(168) varying, 2 type fixed bin, 2 state fixed bin; dcl 1 cphe_name aligned like inhe_name based (cpbf.hp), 1 mhe aligned like h based (mbf.hp), 1 mhe_name aligned like inhe_name based (mbf.hp); if select.vfile.path ^= "" | trace = REJECTS | trace = operation_now | trace = COPY_AND_COMPARE then do; seg.path = rtrim(pathname_ ((mhe.dname), (mhe.ename)), " >"); if mhe.record_type = LINK then seg.type = LINK; else if mhe.record_type = sec_seg | mhe.record_type = ndc_segment then seg.type = SEG; else if mhe.record_type = ndc_directory | mhe.record_type = ndc_directory_list | mhe.record_type = sec_dir then seg.type = DIR; if seg.type = DIR & mhe.bitcnt > 0 then seg.type = MSF; end; seg.state = UNMATCHED; /* assume master */ /* seg unmatched*/ if select.vfile.path = "" then /* not selecting */ state = SELECTED; /* skip nothing */ else if select.select_sw then do; /* -select given */ /* without path */ if need_copy then /* copy media */ state = UNMATCHED; /* exhausted? */ else if mbf.blrh.hl = cpbf.blrh.hl & /* see if two */ mbf.blrh.segl = cpbf.blrh.segl & /* segs are the */ mhe_name.dname = cphe_name.dname & /* same. */ mhe_name.ename = cphe_name.ename then state = SELECTED; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* TYPE 3 SELECTION: */ /* 1) Loop through each -select file pathname specification, comparing it */ /* with the master seg path. */ /* 2) Check master seg path as superior to select file path, equal to it, */ /* or inferior to it. If any test is true, then apply any ^path criteria */ /* for that select file path. */ /* 3) For equal paths, assign the type of the master seg (LINK, SEG, DIR, */ /* MSF) to the select path entry. If the type = DIR, mark the select */ /* path for subtree selection, since dir select paths are really dir */ /* subtree select paths. */ /* 4) For an MSF in a selected directory which does not have subtree */ /* specified (now an impossibility because of (3), but I'll leave this */ /* code in anyway), add the MSF dir to the selection list so its */ /* components will be properly copied. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ else do; do list.x = lbound(list.e,1) to hbound(list.e,1); if length(seg.path) < length(list.e(list.x).path) & seg.path = substr(list.e(list.x).path,1, min(length(list.e(list.x).path), length(seg.path))) & seg.type = DIR then seg.state = SUPERIOR_DIR + list.e(list.x).dont_select; else if list.e(list.x).path = seg.path then do; seg.state = SELECTED + list.e(list.x).dont_select; list.e(list.x).matched = TRUE; if list.e(list.x).type = UNKNOWN then list.e(list.x).type = seg.type; else if list.e(list.x).type = MSF & mhe.record_type = ndc_directory_list then; else if list.e(list.x).type ^= seg.type then call error$fatal (sci_ptr, -1, "^a: FATAL ERROR: Type Mismatch Discrepancy. Path: ^a Master:^23tType ^a Select Item(^d):^23tType ^a^[, added as an MSF^].", hhmmm(), seg.path, TYPE_NAME(seg.type), list.x, TYPE_NAME(list.e(list.x).type), list.e(list.x).added_as_msf); if list.e(list.x).type = DIR then list.e(list.x).subtree = TRUE; end; else if list.e(list.x).path = mhe_name.dname & (list.e(list.x).type = DIR | list.e(list.x).type = MSF) & seg.type ^= DIR then do; seg.state = SELECTED + list.e(list.x).dont_select; if list.e(list.x).type = DIR & /* Add MSF to */ ^list.e(list.x).subtree & /* list to be */ list.e(list.x).dont_select=0 & /* sure all comps*/ seg.type = MSF then /* get copied. */ call add_to_select_list (seg.path, MSF, TRUE, TRUE); end; else if length(seg.path) > length(list.e(list.x).path) then if list.e(list.x).path = substr(seg.path,1,length(list.e(list.x).path)) & list.e(list.x).type = DIR & list.e(list.x).subtree then seg.state = SELECTED_SUBTREE + list.e(list.x).dont_select; end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* /* TRACE SELECTIONS: /* Trace the selection mechanism, listing either selected entries, rejected */ /* entries or all entries. The trace entry includes the selection result */ /* (one of the STATE_NAME values). */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ if trace = operation_now then do; if seg.state = UNMATCHED | seg.state = REJECTED | seg.state = REJECTED_SUPERIOR_DIR | seg.state = REJECTED_SUBTREE then; else call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a", maxlength(STATE_NAME(1)), STATE_NAME(seg.state), seg.type = MSF, maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type), maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type), get_shortest_path_((seg.path))); end; else if trace = REJECTS then do; if seg.state = UNMATCHED | seg.state = REJECTED | seg.state = REJECTED_SUPERIOR_DIR | seg.state = REJECTED_SUBTREE then call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a", maxlength(STATE_NAME(1)), STATE_NAME(seg.state), seg.type = MSF, maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type), maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type), get_shortest_path_((seg.path))); end; else if trace = COPY_AND_COMPARE then do; call ioa_ (" ^va ^[^va^2s^;^2s^va^] ^a", maxlength(STATE_NAME(1)), STATE_NAME(seg.state), seg.type = MSF, maxlength(RECORD_TYPE(1)), TYPE_NAME(seg.type), maxlength(RECORD_TYPE(1)), RECORD_TYPE(mhe.record_type), get_shortest_path_((seg.path))); end; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* RETURN SELECTION RESULT as a TRUE/FALSE value. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ if seg.state = REJECTED_SUPERIOR_DIR | seg.state = REJECTED | seg.state = REJECTED_SUBTREE | seg.state = UNMATCHED then return (TRUE); else return (FALSE); end skip_seg$init; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* TAPE DRIVE MAXIMIZATION: */ /* -maximize_devices (-maxdv) has two goals: to ensure that all devices */ /* available to the process get used equally during a copy/compare */ /* operation; and to ensure that a tape written (copied) on one drive is */ /* read (compared) on a different drive. This involves several operations, */ /* that will be described below. */ /* */ /* The tape_drives structure is the central database for these */ /* operations. It includes the number of drives reserved/assigned to the */ /* process, a round-robin device selector, and event channel for device */ /* operations, and for each device: device name, volume name last mounted */ /* on the device, track and density specs, assignment rcp_id and a flag */ /* indicating whether copy_dump_tape assigned a reserved device to the */ /* process. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ dcl 1 tape_drives aligned, 2 count fixed bin, /* no devices */ 2 dvx fixed bin, /* cur device */ 2 event_wait_list like event_wait_channel, 2 device (6), 3 name char(32), 3 vol char(32), 3 track fixed bin, 3 density bit(36), 3 rcp_id bit(36), 3 assigned_by_us bit(1) aligned; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* ASSIGN RESERVED TAPE DRIVE: */ /* This is called to assign a tape drive already reserved to the process. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$assign: proc (dx); dcl dx fixed bin; dcl code fixed bin(35), 1 ev_info aligned like event_wait_info, statex fixed bin, 1 ti aligned like tape_info; tape_drives.device(dx).assigned_by_us = FALSE; ti.version_num = tape_info_version_3; ti.usage_time = 0; ti.wait_time = 0; ti.system_flag = FALSE; ti.device_name = substr(tape_drives.device(dx).name,1,length(ti.device_name)); ti.model = 0; ti.tracks = 0; ti.density = ""b; ti.speed = ""b; ti.unused_qualifier = ""b; ti.volume_name = ""; ti.write_flag = FALSE; ti.position_index = 0; ti.volume_type = 0; ti.volume_density = 0; ti.opr_auth = FALSE; call rcp_$assign_device (DEVICE_TYPE(TAPE_DRIVE_DTYPEX), addr(ti), tape_drives.event_wait_list.channel_id(1), "", tape_drives.device(dx).rcp_id, code); if code = error_table_$resource_unavailable | code = error_table_$resource_reserved then; else call error (sci_ptr, code, "^/^a: Assigning tape drive ^a.", hhmmm(), tape_drives.device(dx).name); ASSIGN_CHECK: call rcp_$check_assign (tape_drives.device(dx).rcp_id, addr(ti), "", statex, code); go to ASSIGN(statex); ASSIGN(0): tape_drives.device(dx).assigned_by_us = TRUE; return; ASSIGN(1): call ipc_$block (addr(tape_drives.event_wait_list), addr(ev_info), code); if code ^= 0 then do; call convert_ipc_code_ (code); call error$fatal (sci_ptr, code, "While blocking for tape_drive$assign."); end; go to ASSIGN_CHECK; ASSIGN(2): /* long wait. */ return; ASSIGN(3): /* fatal error */ call error (sci_ptr, code, "^/^a: Assigning tape drive ^a.", hhmmm(), tape_drives.device(dx).name); return; end tape_drive$assign; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* VOLUME MOUNTED ON TAPE DRIVE: */ /* This finds out which device a given tape volume was actually mounted */ /* upon. Prior to availability of "tape_mult_ VOL -device DEV", there was */ /* no way to tell RCP which device to mount the tape on. Even with the -dv */ /* attach arg, there is no absolute assurance. So this procedure surveys */ /* RCP data to find out which device it was actually mounted on. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$find_device: proc (vol); dcl 1 vol aligned like in_out.vol; dcl code fixed bin(35), (da, dx) fixed bin; vol.device = ""; if tape_drives.count = 0 then return; call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code); do da = 1 to rli.head.num_attach while (vol.device=""); attach_ptr = addr(rli.attaches(da)); if attach.dtypex = TAPE_DRIVE_DTYPEX then if vol.name = attach.volume_name then do; vol.device = attach.device_name; do dx = 1 to tape_drives.count while (tape_drives.device(dx).name ^= attach.device_name); end; if dx <= tape_drives.count then tape_drives.device(dx).vol = vol.name; end; end; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* SELECT A TAPE DRIVE: */ /* This procedure selects a drive on which to mount a given volume. If */ /* the volume was mounted before during copying, then */ /* $select_another_device is called to select a different device during */ /* comparing. Otherwise, $select_a_device is called to select a device on */ /* a round-robin basis. */ /* */ /* Selection is done by: */ /* 1) Surveying attached devices to see which devices are already occupied */ /* for mounts. */ /* 2) Scanning the remaining devices (round-robin) to find one with */ /* compatible track/density attributes. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$select_another_device: entry (io); dcl 1 io aligned like input; dcl densityx fixed bin, selected_dx fixed bin, unwanted_device char(32); unwanted_device = io.vol(io.tape.volx).device; go to SELECT_JOIN; tape_drive$select_a_device: entry (io); unwanted_device = "~"; go to SELECT_JOIN; SELECT_JOIN: if tape_drives.count = 0 then return; call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code); tape_drives.device(*).vol = ""; do da = 1 to rli.head.num_attach; attach_ptr = addr(rli.attaches(da)); if attach.dtypex = TAPE_DRIVE_DTYPEX then do; do dx = 1 to tape_drives.count while (tape_drives.device(dx).name ^= attach.device_name); end; if dx <= tape_drives.count then tape_drives.device(dx).vol = attach.volume_name; end; end; if io.tape.density = 800 then densityx = 3; else if io.tape.density = 1600 then densityx = 4; else if io.tape.density = 6250 then densityx = 5; else densityx = 4; tape_drives.dvx = mod(tape_drives.dvx+1, tape_drives.count); /* start point */ selected_dx = 0; do dx = tape_drives.dvx+1 to tape_drives.count while (selected_dx = 0), 1 to tape_drives.dvx while (selected_dx = 0); if tape_drives.device(dx).name = unwanted_device | tape_drives.device(dx).vol ^= "" | tape_drives.device(dx).track ^= io.tape.track | ^substr(tape_drives.device(dx).density, densityx, 1) then; else selected_dx = dx; end; if selected_dx ^= 0 then io.vol(io.tape.volx).device = tape_drives.device(selected_dx).name; return; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* SURVEY TAPE DRIVES: */ /* This procedure finds out which drives are reserved or assigned to the */ /* process. */ /* 1) Those just reserved to the process get assigned to it, so */ /* their track/density attributes become known (the attributes are not */ /* listed in the device_resvs structure). */ /* 2) Then all assigned devices are recorded in the tape_drives structure. */ /* 3) Finally, the user is told which devices are available for use. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$survey: entry; if ^maximize_devices_sw then return; tape_drives.count = 0; tape_drives.dvx = -1; tape_drives.device.name = ""; tape_drives.device.vol = ""; tape_drives.device.track = 0; tape_drives.device.density = ""b; tape_drives.device.rcp_id = ""b; tape_drives.device.assigned_by_us = FALSE; call ipc_$create_ev_chn (tape_drives.event_wait_list.channel_id(1), code); call error$fatal (sci_ptr, code, "Creating an event wait channel."); tape_drives.event_wait_list.n_channels = 1; call ssu_$get_temp_segment (sci_ptr, "tape survey", rli_ptr); rli.head.version_num = rli_version_4; call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code); call error (sci_ptr, code, "Getting tape survey data."); if code ^= 0 then return; do da = 1 to rli.head.num_device_resv; device_resv_ptr = addr(rli.device_resvs(da)); if substr(device_resv.device_name,1,length("tap")) = "tap" then do; if tape_drives.count < hbound(tape_drives.device,1) then do; tape_drives.count, dx = tape_drives.count + 1; tape_drives.device(dx).name = device_resv.device_name; end; end; end; if tape_drives.count > 0 then do; /* assign resv */ do dx = 1 to tape_drives.count; /* devs to get */ /* attributes */ do da = 1 to rli.head.num_dassign while (rli.dassigns(da).device_name ^= tape_drives.device(dx).name); end; if da > rli.head.num_dassign then /* not already */ call tape_drive$assign (dx); /* assigned? */ end; /* I'll do it. */ call rcp_$copy_list (rli_ptr, WORDS_PER_SEGMENT, code); end; /* new rcp info */ do da = 1 to rli.head.num_dassign; /* fill in */ dassign_ptr = addr(rli.dassigns(da)); /* tape_drives */ if dassign.dtypex = TAPE_DRIVE_DTYPEX then do; /* for assigned */ do dx = 1 to tape_drives.count /* drives. */ while (tape_drives.device(dx).name ^= dassign.device_name); end; if dx > tape_drives.count & dx <= hbound(tape_drives.device,1) then tape_drives.count = dx; if tape_drives.count >= dx then do; tape_drives.device(dx).name = dassign.device_name; tape_drives.device(dx).track = dassign.qualifiers(1); tape_drives.device(dx).density = unspec(dassign.qualifiers(2)); end; end; end; call ioa_(""); if tape_drives.count > 0 then call ssu_$print_message (sci_ptr, 0, "^a: ^d tape drive^[s^] assigned to process:^/ ^v( ^a^)", hhmmm(), tape_drives.count, tape_drives.count^=1, tape_drives.count, tape_drives.device.name); else call error (sci_ptr, -1, "No tape drives are currently assigned to or reserved for the process. The -maximize_devices operation will not occur."); return; %include rcp_list_info; end tape_drive$find_device; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* TAPE DRIVE INITIALIZATION: */ /* Initialize the tape_drives structure. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$init: proc; tape_drives.count = 0; tape_drives.dvx = -1; tape_drives.event_wait_list.channel_id = -1; tape_drives.device(*).name, tape_drives.device(*).vol = ""; tape_drives.device(*).track = 0; tape_drives.device(*).density, tape_drives.device(*).rcp_id, tape_drives.device(*).assigned_by_us = ""b; end tape_drive$init; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* TAPE DRIVE TERMINATION: */ /* 1) Unassigned reserved devices assigned by us. */ /* 2) Delete the event channel used for RCP operations. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$term: proc; dcl code fixed bin(35), dx fixed bin; do dx = 1 to tape_drives.count; if tape_drives.device(dx).assigned_by_us then call tape_drive$unassign (dx); end; if tape_drives.event_wait_list.channel_id(1) ^= -1 then call ipc_$delete_ev_chn (tape_drives.event_wait_list.channel_id(1), code); end tape_drive$term; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* TAPE DRIVE UNASSIGN: */ /* Unassign a tape drive assigned by copy_dump_tape. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ tape_drive$unassign: proc (dx); dcl dx fixed bin; dcl code fixed bin(35); call rcp_$unassign (tape_drives.device(dx).rcp_id, ""b, "", code); call error (sci_ptr, code, "^/^a: Unassigning tape drive ^a.", hhmmm(), tape_drives.device(dx).name); tape_drives.device(dx).assigned_by_us = FALSE; end tape_drive$unassign; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* WRITE BACKUP LOGICAL RECORD HEADER and SEGMENT: */ /* 1) Decide whether output is to vfile_ or tape. */ /* 2) If to vfile, write out blrh sizes, the segment attributes in the */ /* remainder of blrh, and the segment contents. */ /* 3) If to tape, write out the blrh with segment attributes, and the */ /* segment contents. The blrh and contents must each be written as a */ /* group of 256 word blocks, so that blrh's begin on a 256-char tape */ /* record boundary. After brlh/contents are written, do an error_count */ /* control request to synchronize output, forcing any unwritten tape */ /* buffers onto tape to ensure the segment actually gets written to */ /* tape. */ /* 4) When end-of-volume is found on one output tape, switch to the next */ /* tape and rewrite entire blrh/contents on new tape. */ /* 5) Both types return TRUE if the segment is successfully written, FALSE */ /* if it isn't. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ write_seg: proc (bf, out) returns(bit(1)); dcl 1 bf aligned like inbf, 1 he aligned like h based (bf.hp), 1 out aligned like output; dcl count fixed bin(21); dcl 1 blrh aligned like inbf.blrh based, 1 blrh_sizes aligned like inbf.blrh.sizes based, writel fixed bin(21); dcl size builtin; if out.vfile.path ^= "" then do; /* write file */ call iox_$put_chars (out.iocbp, addr(bf.blrh.sizes), size(blrh_sizes) * CHARS_PER_WORD, code); if code = 0 then do; call iox_$put_chars (out.iocbp, addr(he), bf.blrh.hl * CHARS_PER_WORD, code); if code = 0 then do; if bf.blrh.segl > 0 then do; call iox_$put_chars (out.iocbp, bf.segp, bf.blrh.segl * CHARS_PER_WORD, code); if code = 0 then do; out.recx = out.recx + 1; return (TRUE); end; end; else do; out.recx = out.recx + 1; return (TRUE); end; end; end; if code = error_table_$end_of_info then return (FALSE); else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Writing ^a file ^a, record ^d.", hhmmm(), out.header.name, out.vfile.expath, out.recx+1); end; else if out.tape.voln > 0 then do; /* write tape */ REWRITE: call iox_$put_chars (out.iocbp, addr(bf.blrh), size(blrh) * CHARS_PER_WORD, code); if code = 0 then do; /* * * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* blrh + he, and seg are written in 256-word blocks, so we must round up */ /* the amount we write to the next 256-word boundary. At this point, */ /* blrh-words have already been written. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * * */ writel = bf.blrh.hl + size(blrh) + BLOCK_SIZE - 1; writel = writel - mod(writel, BLOCK_SIZE) - size(blrh); call iox_$put_chars (out.iocbp, addr(he), writel * CHARS_PER_WORD, code); if code = 0 then do; if bf.blrh.segl > 0 then do; writel = bf.blrh.segl + BLOCK_SIZE - 1; writel = writel - mod(writel, BLOCK_SIZE); call iox_$put_chars (out.iocbp, bf.segp, writel * CHARS_PER_WORD, code); end; end; end; if code = 0 then do; call iox_$control (out.iocbp, "error_count", addr(count), code); if code = 0 then do; out.recx = out.recx + 1; return (TRUE); end; end; if code = error_table_$end_of_info | code = error_table_$device_end then do; if mount_next_tape_vol (out) then do; call map_seg$new_tape (out); go to REWRITE; end; else return (FALSE); end; else call error$fatal (sci_ptr, code, "^/^a: FATAL ERROR: Writing ^a tape ^a, record ^d.", hhmmm(), out.header.name, out.vol(out.tape.volx).name, out.recx+1); end; else do; /* discard out */ out.recx = out.recx + 1; return (TRUE); end; end write_seg; /* * * * * * * * * * * * * * * * * * * * * * * * * */ %include backup_dir_list; dcl pp ptr; %include backup_preamble_header; %include backup_record_types; %include event_wait_channel; %include event_wait_info; %include iocb; %include iox_modes; %include rcp_resource_types; %include rcp_tape_info; %include system_constants; end copy_dump_tape; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved