carry_dump.pl1 03/15/89 0838.9r w 03/15/89 0800.0 316800 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ carry_dump: proc; /* This command reads a queue of carry requests and produces: a backup tape containing the named segments and directory subtrees, a tape log segment called TAPE_NUMBER.tape_log, a list of requests called TAPE_NUMBER.input used to remake a tape, and a directory named mail_to_carry containing PERSON.PROJECT ASCII segments ("...loaded at...") which are carried on the tape and mailed at the target site to notify requestors that their requests have been loaded. Usage: carry_dump tape_number {queue_path} {-control_arg} where control_arg can be -force or -fc to write a tape even if there are no requests in the queue. If queue_path is not specified, the default pathname is: >daemon_dir_dir>carry_dir>carry.ms The remake_carry_tape command reads the file .input that was written when tape was first made, and makes another tape. The tape made can have a number different from . Usage: remake_carry_tape tape_number {new_tape_number} {-queue_dir path} Steve Herbst 7/9/76 -notify feature added 04/18/79 S. Herbst */ /* -trim added and bugs fixed 08/03/79 S. Herbst */ /* -user added 01/09/80 S. Herbst */ /* Modified to set dir_quota on append, Keith Loepere December 1984. */ %include backup_control; dcl 1 request_info (request_index) aligned based, 2 sender char (32), 2 new_user char (32), 2 type_string char (32), 2 notify bit (1) aligned; dcl SP_HT char (2) int static options (constant) init (" "); dcl (mseg_dir, queue_dir) char (168) init (">daemon_dir_dir>carry_dir"); dcl mseg_name char (32) init ("carry.ms"); dcl (dn, input_path, mail_dir_path, path, new_dir_path, tape_log_path) char (168); dcl line char (line_len) based (line_ptr); dcl arg char (arg_len) based (arg_ptr); dcl return_string char (return_len) varying based (return_ptr); dcl mail_seg char (mail_seg_len) based (mail_seg_ptr); dcl (buffer, header, warning_msg) char (500); dcl err_string char (100); dcl (en, new_user_id, sender_id, type_str) char (32); dcl atime char (24); dcl destination char (23); dcl tape_number char (32); dcl new_tape_number char (32) int static; dcl newline char (1) int static init (" "); dcl id (id_limit) bit (72) aligned based (id_ptr); dcl use_tape_number bit (1) aligned int static; dcl active_function bit (1) aligned; dcl remake_tape bit (1) aligned; dcl (got_number, got_new_number, got_queue, got_tape) bit (1) aligned; dcl (force_sw, new_dir_sw, no_requests, notify_sw, trim_sw, warn_subtree_sw) bit (1) aligned; dcl tape_attached bit (1) aligned init ("0"b); dcl area area based (area_ptr); dcl (bk_iocb, input_iocb, mail_iocb, tape_log_iocb) ptr init (null); dcl (eptr, nptr, id_ptr) ptr init (null); dcl (area_ptr, arg_ptr, line_ptr, mail_seg_ptr, names_ptr, new_id_ptr, return_ptr) ptr; dcl ptrs (2) ptr; dcl (control_ptr, info_ptr) ptr init (null); dcl (arg_count, arg_len, buffer_len, ecount, error_count, header_len, id_index, id_limit) fixed bin; dcl (i, j, line_len, mail_count, mail_seg_len, names_count, request_index, return_len) fixed bin; dcl mseg_index fixed bin init (0); dcl type fixed bin (2); dcl rings7 (3) fixed bin (3) init ((3)7); dcl mail_seg_bc fixed bin (24); dcl code fixed bin (35); dcl 1 entries (ecount) aligned based (eptr), 2 type bit (2) unaligned, 2 nnames fixed bin (15) unaligned, 2 nindex fixed bin (17) unaligned; dcl star_names (99) char (32) aligned based (nptr); %include branch_status; dcl names (names_count) char (32) based (names_ptr); %include create_branch_info; dcl 1 cb_info like create_branch_info; %include mseg_return_args; dcl 1 mseg_args like mseg_return_args; %include send_mail_info; dcl 1 dir_acl (1) aligned, 2 access_name char (32), 2 modes bit (36), 2 status_code fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$entlong fixed bin (35) ext; dcl error_table_$no_message fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$not_attached fixed bin (35) ext; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable); dcl backup_dump_ entry (ptr, fixed bin (35)); dcl backup_util$get_real_name entry (ptr, ptr, fixed bin, fixed bin (35)); dcl clock_ entry returns (fixed bin (71)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl convert_status_code_ entry (fixed bin (35), char (*), char (*)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_system_free_area_ entry returns (ptr); dcl get_temp_segments_ entry (char (*), (*)ptr, fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$del_dir_tree entry (char (*), char (*), fixed bin (35)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$truncate_file entry (char (*), char (*), fixed bin (18), fixed bin (35)); dcl ioa_ entry options (variable); dcl ioa_$ioa_switch entry options (variable); dcl ioa_$rs entry options (variable); dcl ioa_$rsnnl entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$error_output ptr ext; dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); dcl iox_$position entry (ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl message_segment_$close entry (fixed bin, fixed bin (35)); dcl message_segment_$delete_index entry (fixed bin, bit (72)aligned, fixed bin (35)); dcl message_segment_$incremental_read_index entry (fixed bin, ptr, bit (2)aligned, bit (72), ptr, fixed bin (35)); dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl message_segment_$read_index entry (fixed bin, ptr, bit (1)aligned, ptr, fixed bin (35)); dcl release_temp_segments_ entry (char (*), (*)ptr, fixed bin (35)); dcl send_mail_ entry (char (*), char (*), ptr, fixed bin (35)); dcl send_message_$notify_mail entry options (variable); dcl (addr, divide, fixed, index, length, null, ptr, reverse, rtrim, substr, unspec, verify) builtin; dcl cleanup condition; /* */ remake_tape = "0"b; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then active_function = "0"b; else active_function = "1"b; if arg_count = 0 then do; USAGE: if active_function then call active_fnc_err_$suppress_name (0, "carry_dump", "Usage: [carry_dump tape_number {queue_path} {-force}]"); else call com_err_$suppress_name (0, "carry_dump", "Usage: carry_dump tape_number {queue_path} {-force}"); return; end; force_sw, got_tape, got_queue, no_requests = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-force" | arg = "-fc" then force_sw = "1"b; else do; code = error_table_$badopt; if active_function then call active_fnc_err_ (code, "carry_dump", "^a", arg); else call com_err_ (code, "carry_dump", "^a", arg); return; end; else if ^got_tape then do; got_tape = "1"b; tape_number, new_tape_number = arg; end; else do; if got_queue then go to USAGE; /* two queue paths given */ got_queue = "1"b; call expand_pathname_ (arg, mseg_dir, mseg_name, code); if code ^= 0 then do; call warn (code, "carry_dump", arg); return; end; queue_dir = mseg_dir; j = length (mseg_name)+1-verify (reverse (mseg_name), " "); if j<4 | substr (mseg_name, j-2, 3) ^= ".ms" then if j+3>length (mseg_name) then do; call warn (error_table_$entlong, "carry_dump", rtrim (mseg_name) || ".ms"); return; end; else substr (mseg_name, j+1, 3) = ".ms"; end; end; if active_function then return_string = "false"; /* initialize */ call message_segment_$open (mseg_dir, mseg_name, mseg_index, code); if mseg_index = 0 then do; call warn (code, "carry_dump", rtrim (mseg_dir) || ">" || mseg_name); return; end; on condition (cleanup) call clean_up; /* See if we can read first request */ area_ptr = get_system_free_area_ (); call message_segment_$read_index (mseg_index, area_ptr, "0"b, addr (mseg_args), code); if code ^= 0 then if force_sw then no_requests = "1"b; else do; MSEG_ERROR: if code = error_table_$no_message then if active_function then call ioa_$ioa_switch (iox_$error_output, "Queue ^a>^a is empty.", mseg_dir, mseg_name); else call com_err_ (0, "carry_dump", "Queue ^a>^a is empty.", mseg_dir, mseg_name); else call warn (code, "carry_dump", rtrim (mseg_dir) || ">" || mseg_name); RETURN: call clean_up; return; end; call ioa_$rsnnl ("^a>^a.input", input_path, (0), queue_dir, tape_number); call hcs_$truncate_file (input_path, "", 0, code); /* prepare to write .input */ call hcs_$set_bc (input_path, "", 0, code); call iox_$attach_name ("carry_input", input_iocb, "vfile_ "||input_path, null, code); if code ^= 0 then do; INPUT_ERROR: call warn (code, "carry_dump", "^/Unable to attach ""carry_input"" to " || input_path); go to RETURN; end; call iox_$open (input_iocb, 3, "0"b, code); if code ^= 0 then do; call warn (code, "carry_dump", "^/Unable to write " || input_path); go to RETURN; end; /* Allocate room for message id's */ id_limit = 128; allocate id in (area) set (id_ptr); id_index = 0; i = index (mseg_name, "."); /* get destination from queue name prefix */ if i ^= 0 & substr (mseg_name, i+1, 8) = "carry.ms" then do; GET_DS: destination = substr (mseg_name, 1, i-1); end; else do; /* name given has no destination prefix */ call hcs_$status_ (mseg_dir, mseg_name, 1, addr (branch_status), area_ptr, code); if code ^= 0 then do; NO_DS: call warn (code, "carry_dump", "^/Unable to determine carry destination. Please give destination - prefixed name of queue " || rtrim (mseg_dir) || ">" || mseg_name); go to RETURN; end; names_ptr = ptr (area_ptr, branch_status.names_rel_pointer); names_count = fixed (branch_status.number_names); do j = 1 to names_count; mseg_name = names (j); i = index (mseg_name, "."); if i ^= 0 & substr (mseg_name, i+1, 8) = "carry.ms" then do; free names in (area); go to GET_DS; end; end; free names in (area); code = 0; go to NO_DS; end; /* Write header line in .input */ call date_time_ (clock_ (), atime); call ioa_$rs ("Carry tape ^a to ^a written ^a", header, header_len, tape_number, destination, atime); call iox_$put_chars (input_iocb, addr (header), header_len, code); if code ^= 0 then do; call warn (code, "carry_dump", "^/Unable to write " || input_path); go to RETURN; end; if no_requests then go to MAKE_BLANK_TAPE; /* Read queue into .input */ code = 0; do while (code = 0); id_index = id_index+1; /* remember message id for later deletion */ if id_index>id_limit then do; /* need more room for id array */ id_limit = id_limit+64; allocate id in (area) set (new_id_ptr); do j = 1 to id_index-1; new_id_ptr -> id (j) = id_ptr -> id (j); end; free id_ptr -> id in (area); id_ptr = new_id_ptr; end; id (id_index) = mseg_args.ms_id; sender_id = mseg_args.sender_id; line_ptr = mseg_args.ms_ptr; line_len = divide (mseg_args.ms_len+8, 9, 17, 0); if substr (line, line_len, 1) = newline then line_len = line_len-1; if substr (line, line_len - 5, 6) = " -hold" then do; /* hold request */ line_len = line_len-6; id_index = id_index-1; /* do not delete it from queue */ end; if substr (line, line_len - 7, 8) = " -notify" then do; notify_sw = "1"b; line_len = line_len - 8; end; else notify_sw = "0"b; j = index (line, " -new_dir "); if j ^= 0 then do; new_dir_path = substr (line, j + 10); line_len = j - 1; end; else new_dir_path = ""; if substr (line, line_len - 5, 6) = " -trim" then do; trim_sw = "1"b; line_len = line_len - 6; end; else trim_sw = "0"b; j = index (line, " -user "); if j ^= 0 then do; new_user_id = substr (line, j + 7); line_len = j - 1; end; else new_user_id = ""; if substr (line, 1, 8) ^= "Segment " & substr (line, 1, 8) ^= "Subtree " then do; call hcs_$status_minf ((line), "", 1, type, 0, code); if code ^= 0 then go to NEXT; if type = 2 then type_str = "Subtree"; else type_str = "Segment"; call ioa_$rs ("^a ^a ^a^[ -user ^a^;^s^]^[ -trim^]^[ -notify^]", buffer, buffer_len, type_str, substr (line, 1, line_len), sender_id, new_user_id ^= "", new_user_id, trim_sw, notify_sw); end; else call ioa_$rs ("^a ^a^[ -user ^a^;^s^]^[ -trim^]^[ -notify^]", buffer, buffer_len, substr (line, 1, line_len), sender_id, new_user_id ^= "", new_user_id, trim_sw, notify_sw); if new_dir_path ^= "" then do; substr (buffer, buffer_len, 10) = " -new_dir" || newline; buffer_len = buffer_len + 9; end; call iox_$put_chars (input_iocb, addr (buffer), buffer_len, code); if new_dir_path ^= "" then call ioa_$ioa_switch (input_iocb, "^10xMove to directory ^a", new_dir_path); NEXT: call message_segment_$incremental_read_index /* read next request from queue */ (mseg_index, area_ptr, "01"b, mseg_args.ms_id, addr (mseg_args), code); if code ^= 0 & code ^= error_table_$no_message then go to MSEG_ERROR; end; /* Position back and read header line from .input */ call iox_$position (input_iocb, -1, 0, code); call iox_$get_line (input_iocb, addr (buffer), length (buffer), line_len, code); if code ^= 0 then do; call warn (code, "carry_dump", "^/Unable to read " || input_path); go to RETURN; end; go to COMMON; /* */ remake_carry_tape: entry; remake_tape = "1"b; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then active_function = "0"b; else active_function = "1"b; if arg_count = 0 then do; USAGE2: if active_function then call active_fnc_err_$suppress_name (0, "remake_carry_tape", "Usage: [remake_carry_tape tape_number {new_tape_number} {-queue_dir path}]"); else call com_err_$suppress_name (0, "remake_carry_tape", "Usage: remake_carry_tape tape_number {new_tape_number} {-queue_dir path}]"); return; end; got_number, got_new_number = "0"b; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-queue_dir" | arg = "-qd" then do; i = i+1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call absolute_pathname_ (arg, queue_dir, code); if code ^= 0 then do; call com_err_ (code, "remake_carry_tape", "^a", arg); return; end; end; else do; code = error_table_$badopt; if active_function then call active_fnc_err_ (code, "remake_carry_tape", "^a", arg); else call com_err_ (code, "remake_carry_tape", "^a", arg); return; end; else if ^got_number then do; tape_number = arg; got_number = "1"b; end; else if ^got_new_number then do; new_tape_number = arg; got_new_number = "1"b; end; else go to USAGE2; end; if ^got_number then go to USAGE2; if ^got_new_number then new_tape_number = tape_number; call ioa_$rsnnl ("^a>^a.input", input_path, (0), queue_dir, tape_number); call iox_$attach_name ("carry_input", input_iocb, "vfile_ "||input_path, null, code); if code ^= 0 then go to INPUT_ERROR; call iox_$open (input_iocb, 1, "0"b, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to read " || input_path); go to RETURN; end; call iox_$get_line (input_iocb, addr (buffer), length (buffer), line_len, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to read " || input_path); go to RETURN; end; /* Get destination from input file header */ line_ptr = addr (buffer); i = index (line, " written "); j = index (reverse (substr (line, 1, i-1)), " ")-1; destination = substr (line, i-j, j); /* Build header line */ call date_time_ (clock_ (), atime); call ioa_$rs ("Carry tape ^a to ^a written ^a", header, header_len, new_tape_number, destination, atime); /* */ COMMON: call initialize_backup; call attach_tape_log; /* write header line in .tape_log */ use_tape_number = "1"b; /* make $tape_entry return tape id */ /* Create directories to hold mail segs */ cb_info.version = create_branch_version_2; unspec (cb_info.switches) = "0"b; cb_info.dir_sw, cb_info.parent_ac_sw = "1"b; cb_info.mode = "111"b; cb_info.mbz2, cb_info.access_class = "0"b; cb_info.rings = rings7; cb_info.userid = get_group_id_ (); cb_info.bitcnt, cb_info.quota, cb_info.dir_quota = 0; call ioa_$rsnnl ("^a>mail_to_carry", mail_dir_path, 168, queue_dir); call create_mail_dir ("mail_to_carry"); call create_mail_dir ("mail_to_send"); /* */ /* Queue input file to be dumped */ request_index, control_ptr -> backup_control.request_count = 1; control_ptr -> backup_control.path (1) = input_path; control_ptr -> backup_control.new_path (1) = ""; info_ptr -> request_info.type_string (1) = "Segment"; info_ptr -> request_info.sender (1) = get_group_id_ (); info_ptr -> request_info.new_user (1) = ""; /* Queue carry requests (add them to backup_control structure) */ call iox_$get_line (input_iocb, addr (buffer), length (buffer), buffer_len, code); do while (code ^= error_table_$end_of_info); request_index, control_ptr -> backup_control.request_count = request_index+1; control_ptr -> backup_control.no_primary_sw (request_index) = "1"b; line_ptr = addr (buffer); line_len = buffer_len; if substr (line, line_len, 1) = newline then line_len = line_len-1; if substr (line, line_len - 8, 9) = " -new_dir" then do; /* carry -new_dir */ new_dir_sw = "1"b; line_len = line_len - 9; end; else new_dir_sw = "0"b; if substr (line, line_len - 7, 8) = " -notify" then do; info_ptr -> request_info.notify (request_index) = "1"b; line_len = line_len - 8; end; else info_ptr -> request_info.notify (request_index) = "0"b; if substr (line, line_len - 5, 6) = " -trim" then do; control_ptr -> backup_control.trim_sw (request_index) = "1"b; line_len = line_len - 6; end; else control_ptr -> backup_control.trim_sw (request_index) = "0"b; i = index (line, " -user "); if i ^= 0 then do; info_ptr -> request_info.new_user (request_index) = substr (line, i + 7); line_len = i - 1; end; else info_ptr -> request_info.new_user (request_index) = ""; line_len = length(rtrim(substr(line,1,line_len))); i = line_len+1-index(reverse(substr(line,1,line_len))," "); /* find last space */ info_ptr -> request_info.sender (request_index) = substr (line, i+1); info_ptr -> request_info.type_string (request_index) = substr (line, 1, 7); path = substr (line, 9, i - 9); control_ptr -> backup_control.path (request_index) = path; if new_dir_sw then do; /* -new_dir */ call expand_pathname_ (path, dn, en, code); call iox_$get_line (input_iocb, addr (buffer), length (buffer), buffer_len, code); i = index (buffer, "Move to directory ") + 18; /* start of new pathname */ control_ptr -> backup_control.new_path (request_index) = substr (buffer, i, buffer_len - i) || ">" || en; end; else control_ptr -> backup_control.new_path (request_index) = ""; call iox_$get_line (input_iocb, addr (buffer), length (buffer), buffer_len, code); end; /* Dump .input and carry requests */ tape_attached = "1"b; control_ptr -> backup_control.hold_sw = "1"b; call backup_dump_ (control_ptr, code); if code ^= 0 then do; if code = error_table_$not_attached then call warn (0, "carry_dump", "Tape " || rtrim (new_tape_number) || " is not available."); else call warn (code, "carry_dump", "^/Tape not written."); go to RETURN; end; tape_attached = "0"b; if active_function then return_string = "true"; /* tape written */ /* */ /* Look for errors and build segs to mail. These segs are named Person.Project after the requestors and go in either of two directories: mail_to_send for sending at this site and mail_to_carry for sending at the target site */ error_count, mail_count = 0; do i = 1 to control_ptr -> backup_control.request_count; path = control_ptr -> backup_control.path (i); type_str = info_ptr -> request_info.type_string (i); sender_id = info_ptr -> request_info.sender (i); /* remove instance tag */ sender_id = substr (sender_id, 1, length (sender_id) - index (reverse (sender_id), ".")); if control_ptr -> backup_control.status_code (i) ^= 0 then do; if substr (control_ptr -> backup_control.error_name (i), 1, 13) = "(in subtree) " then do; warn_subtree_sw = "1"b; call convert_status_code_ (control_ptr -> backup_control.status_code (i), "", err_string); warning_msg = "Omitted some entries in " || control_ptr -> backup_control.path (i); warning_msg = rtrim (warning_msg) || "^/^-"; warning_msg = rtrim (warning_msg) || substr (control_ptr -> backup_control.error_name (i), 14); warning_msg = rtrim (warning_msg) || ":^x"; warning_msg = rtrim (warning_msg) || err_string; call warn (0, "Warning", rtrim (warning_msg, SP_HT)); end; else do; warn_subtree_sw = "0"b; error_count = error_count + 1; call warn (control_ptr -> backup_control.status_code (i), control_ptr -> backup_control.error_name (i), control_ptr -> backup_control.path (i)); end; /* Mail goes to requestor at this site */ mail_count = mail_count + 1; call ioa_$rsnnl ("vfile_ ^a>mail_to_send>^a -extend", buffer, buffer_len, queue_dir, sender_id); call iox_$attach_name ("carry_mail", mail_iocb, buffer, null, code); call iox_$open (mail_iocb, 2, "0"b, code); if warn_subtree_sw then call ioa_$ioa_switch (mail_iocb, "Warning: " || warning_msg); else do; call ioa_$ioa_switch (mail_iocb, "Unable to dump carry request ^a on tape ^a.", path, new_tape_number); call convert_status_code_ (control_ptr -> backup_control.status_code (i), "", err_string); call ioa_$ioa_switch (mail_iocb, "^a: ^a", control_ptr -> backup_control.error_name (i), err_string); end; end; else do; if info_ptr -> request_info.notify (i) then do; mail_count = mail_count + 1; call ioa_$rsnnl ("vfile_ ^a>mail_to_send>^a -extend", buffer, buffer_len, queue_dir, sender_id); call iox_$attach_name ("carry_mail", mail_iocb, buffer, null, code); call iox_$open (mail_iocb, 2, "0"b, code); call ioa_$ioa_switch (mail_iocb, "Dumped ^a on tape ^a.", path, new_tape_number); call iox_$close (mail_iocb, code); call iox_$detach_iocb (mail_iocb, code); end; /* Notification of loading gets carried and mailed to requestor at target site */ if i > 1 then do; /* not .input */ call ioa_$rsnnl ("vfile_ ^a>mail_to_carry>^a -extend", buffer, buffer_len, queue_dir, sender_id); call iox_$attach_name ("carry_mail", mail_iocb, buffer, null, code); call iox_$open (mail_iocb, 2, "0"b, code); if control_ptr -> backup_control.new_path (i) ^= "" then path = control_ptr -> backup_control.new_path (i); call ioa_$ioa_switch (mail_iocb, "^a ^a loaded at ^a from tape ^a.", type_str, path, destination, new_tape_number); end; /* Append to .tape_log that this request was dumped */ new_user_id = info_ptr -> request_info.new_user (i); if control_ptr -> backup_control.new_path (i) ^= "" then do; call expand_pathname_ (control_ptr -> backup_control.new_path (i), dn, en, code); call ioa_$ioa_switch (tape_log_iocb, "^a ^a ^a^[ -user ^a^;^s^]^[ -trim^] -new_dir^/^10xMove to directory ^a", type_str, control_ptr -> backup_control.path (i), sender_id, new_user_id^="", new_user_id, control_ptr -> backup_control.trim_sw (i), dn); end; else call ioa_$ioa_switch (tape_log_iocb, "^a ^a ^a^[ -user ^a^;^s^]^[ -trim^]", type_str, path, sender_id, new_user_id ^= "", new_user_id, control_ptr -> backup_control.trim_sw (i)); end; if mail_iocb ^= null then do; call iox_$close (mail_iocb, code); call iox_$detach_iocb (mail_iocb, code); end; end; /* Dump .tape_log and mail_to_carry directory */ control_ptr -> backup_control.request_count = 2; control_ptr -> backup_control.path (1) = tape_log_path; control_ptr -> backup_control.new_path (1) = ""; control_ptr -> backup_control.path (2) = mail_dir_path; control_ptr -> backup_control.new_path (2) = ""; control_ptr -> backup_control.hold_sw = "0"b; tape_attached, use_tape_number = "1"b; call backup_dump_ (control_ptr, code); if code ^= 0 then do; buffer = "carry_dump"; NO_TAPE_LOG: if active_function then return_string = "false"; call warn (code, buffer, "Segment " || rtrim (tape_log_path) || " not dumped.^/Tape is invalid."); go to RETURN; end; tape_attached = "0"b; code = control_ptr -> backup_control.status_code (1); if code ^= 0 then do; buffer = control_ptr -> backup_control.error_name (1); go to NO_TAPE_LOG; end; /* Delete all processed requests from queue */ if ^remake_tape then do i = 1 to id_index; call message_segment_$delete_index (mseg_index, id (i), code); end; call clean_up; /* Send mail to requestors */ if mail_count ^= 0 then do; area_ptr = get_system_free_area_ (); send_mail_info.version = 2; send_mail_info.sent_from = ""; unspec (send_mail_info.switches) = "0"b; send_mail_info.always_add = "1"b; call ioa_$rsnnl ("^a>mail_to_send", mail_dir_path, 168, queue_dir); eptr, nptr = null; on condition (cleanup) begin; if eptr ^= null then free eptr -> entries in (area); if nptr ^= null then free nptr -> star_names in (area); end; call hcs_$star_ (mail_dir_path, "**", 3 /* all */, area_ptr, ecount, eptr, nptr, code); do i = 1 to ecount; sender_id = star_names (entries (i).nindex); call hcs_$initiate_count (mail_dir_path, sender_id, "", mail_seg_bc, 0, mail_seg_ptr, code); if mail_seg_ptr ^= null then do; mail_seg_len = divide (mail_seg_bc, 9, 17, 0); call send_mail_ (sender_id, mail_seg, addr (send_mail_info), code); call send_message_$notify_mail (sender_id, "", code); /* send notification */ call hcs_$terminate_noname (mail_seg_ptr, code); end; end; if eptr ^= null then free eptr -> entries in (area); if nptr ^= null then free nptr -> star_names in (area); end; call ioa_ ("carry_dump: Normal termination."); if error_count ^= 0 then call ioa_ ("^d request^[s^] omitted.", error_count, error_count > 1); return; /* */ MAKE_BLANK_TAPE: /* Write a tape containing only .input and no requests */ call attach_tape_log; /* write header line in .tape_log */ call ioa_$ioa_switch (tape_log_iocb, "Segment " || rtrim (tape_log_path) || " " || rtrim (get_group_id_$tag_star (), ".*")); call ioa_$ioa_switch (tape_log_iocb, "No requests submitted."); call iox_$close (tape_log_iocb, code); call iox_$detach_iocb (tape_log_iocb, code); tape_log_iocb = null; call ioa_$ioa_switch (input_iocb, "No requests submitted."); call iox_$close (input_iocb, code); call iox_$detach_iocb (input_iocb, code); input_iocb = null; call initialize_backup; use_tape_number = "1"b; control_ptr -> backup_control.request_count = 1; control_ptr -> backup_control.path (1) = tape_log_path; control_ptr -> backup_control.new_path (1) = ""; control_ptr -> backup_control.status_code (1) = 0; call backup_dump_ (control_ptr, code); if code ^= 0 then do; call warn (code, "carry_dump", "Tape " || rtrim (new_tape_number) || " not written."); if active_function then return_string = "false"; end; else if control_ptr -> backup_control.status_code (1) ^= 0 then do; call warn (control_ptr -> backup_control.status_code (1), control_ptr -> backup_control.error_name (1), "Error dumping " || rtrim (control_ptr -> backup_control.path (1)) || "^/Tape " || rtrim (new_tape_number) || " not written."); if active_function then return_string = "false"; end; else do; call ioa_ ("No requests. Tape contains only ^a", tape_log_path); if active_function then return_string = "true"; end; call clean_up; return; /* */ carry_tape_entry: entry (tape_label); /* This entry point, called by backup_dump_, returns carry_dump's tape_number argument the first time it is called and "(another)" succeeding times. */ dcl tape_label char (32); if use_tape_number then tape_label = new_tape_number; else tape_label = "(another)"; use_tape_number = "0"b; return; /* */ initialize_backup: proc; /* This internal procedure allocates a control structure to drive backup_dump_ */ call get_temp_segments_ ("carry_dump", ptrs, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to allocate temp segs in process directory."); go to RETURN; end; control_ptr = ptrs (1); info_ptr = ptrs (2); control_ptr -> backup_control.version = BACKUP_CONTROL_VERSION_5; control_ptr -> backup_control.tape_entry = carry_tape_entry; unspec (control_ptr -> backup_control.options) = "0"b; control_ptr -> backup_control.debug_sw = "1"b; control_ptr -> backup_control.request_count = 0; end initialize_backup; attach_tape_log: proc; /* This internal procedure opens a tape log segment for writing and puts in a header line */ call ioa_$rsnnl ("^a>^a.tape_log", tape_log_path, (0), queue_dir, new_tape_number); call hcs_$truncate_file (tape_log_path, "", 0, code); call hcs_$set_bc (tape_log_path, "", 0, code); call iox_$attach_name ("carry_tape_log", tape_log_iocb, "vfile_ "||tape_log_path, null, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to attach ""carry_tape_log"" to " || tape_log_path); go to RETURN; end; call iox_$open (tape_log_iocb, 2, "0"b, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to write " || tape_log_path); go to RETURN; end; call iox_$put_chars (tape_log_iocb, addr (header), header_len, code); if code ^= 0 then do; call warn (code, "carry_dump", "Unable to write " || tape_log_path); go to RETURN; end; end attach_tape_log; /* */ create_mail_dir: proc (a_name); dcl a_name char (*); /* This internal procedure deletes the old mail directory and creates a new one */ call hcs_$status_minf (queue_dir, a_name, 1, 0, 0, code); if code ^= error_table_$noentry then do; dir_acl (1).access_name = cb_info.userid; dir_acl (1).modes = "111"b; call hcs_$add_dir_acl_entries (queue_dir, a_name, addr (dir_acl), 1, code); call hcs_$del_dir_tree (queue_dir, a_name, code); call hcs_$delentry_file (queue_dir, a_name, code); end; call hcs_$create_branch_ (queue_dir, a_name, addr (cb_info), code); if code ^= 0 then do; call ioa_$rsnnl ("^a^[>^]^a", mail_dir_path, 168, queue_dir, queue_dir ^= ">", a_name); call warn (code, "carry_dump", "^/Unable to create directory " || mail_dir_path); go to RETURN; end; end create_mail_dir; /* */ warn: proc (a_code, a_name, a_string); /* This internal procedure prints an error message on error_output without signalling in the case of an active function. In the case of a command, it calls com_err_. We don't want active function error messages to abort exec_com's. */ dcl a_code fixed bin (35); dcl (a_name, a_string) char (*); if active_function then do; if a_name = "" then a_name = "carry_dump"; if a_code = 0 then call ioa_$ioa_switch (iox_$error_output, "^a: " || a_string, a_name); else do; call convert_status_code_ (a_code, "", err_string); call ioa_$ioa_switch (iox_$error_output, "^a: ^a " || a_string, a_name, err_string); end; end; else if a_name = "" then call com_err_$suppress_name (a_code, "carry_dump", a_string); else call com_err_ (a_code, a_name, a_string); end warn; clean_up: proc; if tape_attached then do; call iox_$find_iocb ("bk_output_1", bk_iocb, code); call iox_$close (bk_iocb, code); call iox_$detach_iocb (bk_iocb, code); end; if input_iocb ^= null then do; call iox_$close (input_iocb, code); call iox_$detach_iocb (input_iocb, code); end; if tape_log_iocb ^= null then do; call iox_$close (tape_log_iocb, code); call iox_$detach_iocb (tape_log_iocb, code); end; if control_ptr ^= null then call release_temp_segments_ ("carry_dump", ptrs, code); if mseg_index ^= 0 then call message_segment_$close (mseg_index, code); if id_ptr ^= null then free id in (area); end clean_up; end carry_dump;  carry_dump_dp.pl1 11/15/82 1811.6rew 11/15/82 1459.0 92349 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ carry_dump_dp: procedure ( dir_path, map_dir_name, sys_map_name, err_file_name ); /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* This procedure dprints the user maps made */ /* during a carry_dump run. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Declarations */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ declare ( dir_path, /* pathname of outer directory */ map_dir_name, /* entry name of user map directory */ sys_map_name, /* entry name of system map */ err_file_name ) char(*); /* entry name of error file */ declare ( map_dir_path, /* path name of user map directory */ sys_map_path, /* path name of system map */ err_file_path, /* path name of error file */ name_path, /* path name of a user map */ dir_name ) char(168); /* name of old user map directory */ declare header char(200) aligned, /* dp header for user maps */ header_len fixed bin; /* length of user headers */ declare user_map char(user_map_len) based(user_map_ptr); declare ( dir_len, /* real length of a dir pathname */ name_len ) fixed bin; /* real length of an entry name */ declare (i, j, k, start, user_map_len) fixed bin; declare code fixed bin(35); /* standard status code */ declare (time1, time2, one_day) fixed bin(71); declare type fixed bin(2), /* for call to status_minf */ bit_count fixed bin(24); /* = */ declare rings(3) fixed bin(5) internal static initial ( 4, 4, 4 ); /* for call to set_ring_brackets */ declare area_ptr pointer, /* pointer to area for star_ */ eptr pointer, /* pointer to star_ entry array */ nptr pointer, /* pointer to star_ name array */ user_map_ptr pointer, ecount fixed bin, /* star_ entry count */ 1 entry(ecount) based(eptr), /* star_ entry array structure */ 2 type bit(2) unaligned, /* entry type */ 2 nnames bit(16) unaligned, /* number of names on entry */ 2 nindex bit(18) unaligned, /* index of first name in name array */ name(2) char(32) based(nptr); /* star_ name array */ declare 1 branch_status aligned, ( 2 type bit(2), 2 nnames fixed bin(15), 2 nrp bit(18), 2 dtcm bit(36), 2 dtu bit(36), 2 mode bit(5), 2 pad bit(13), 2 records fixed bin(17)) unaligned; declare error_table_$noentry fixed bin (35) ext; declare area_ entry ( fixed bin, ptr ), /* external procedures */ clock_ entry returns ( fixed bin(71) ), com_err_ entry options ( variable ) , convert_date_to_binary_ entry(char(*),fixed bin(71),fixed bin(35)), delete_$path entry ( char(*), char(*), bit(6), char(*), fixed bin(35) ), dprint$dp entry options ( variable ) , hcs_$delentry_file entry (char (*), char (*), fixed bin(35) ), hcs_$delentry_seg entry ( ptr, fixed bin(35) ), hcs_$initiate_count entry(char(*),char(*),char(*),fixed bin(24),fixed bin(1),ptr,fixed bin(35)), hcs_$make_seg entry ( char(*), char(*), char(*), fixed bin(5), ptr, fixed bin(35) ), hcs_$set_ring_brackets entry ( char(*), char(*), (3) fixed bin(5), fixed bin(35) ), hcs_$star_ entry ( char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35) ), hcs_$status_ entry ( char(*), char(*), fixed bin(1), ptr, ptr, fixed bin(35) ), hcs_$status_minf entry ( char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35) ), hcs_$terminate_seg entry(ptr,fixed bin(1),fixed bin(35)), ioa_$rsnnl entry options ( variable ); declare ( addr, /* builtin functions */ fixed, index, null, substr ) builtin; /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Create the various pathnames for the user map */ /* directory, the system map, and the error file */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ dir_len = index ( dir_path, " " ) - 1; /* get length of directory portion */ name_len = index ( map_dir_name, " " ) - 1; /* get length of map dir entry name */ if name_len = -1 /* is it 32 characters ? */ then name_len = 32; /* yes, make it so */ map_dir_path = substr ( dir_path, 1, dir_len ) /* make up the full pathname */ || ">" || substr ( map_dir_name, 1, name_len ); name_len = index ( sys_map_name, " " ) - 1; /* get length of sys map entry name */ if name_len = -1 /* is it 32 characters ? */ then name_len = 32; /* yes, make it so */ sys_map_path = substr ( dir_path, 1, dir_len ) /* make up the full pathname */ || ">" || substr ( sys_map_name, 1, name_len ); name_len = index ( err_file_name, " " ) - 1; /* get length of err file entry name */ if name_len = -1 /* is it 32 characters ? */ then name_len = 32; /* yes, make it so */ err_file_path = substr ( dir_path, 1, dir_len ) /* make up the full pathname */ || ">" || substr ( err_file_name, 1, name_len ); /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* dprint the system map and error file if they */ /* actually exist. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* see if the system map exists */ call hcs_$status_minf ( dir_path, sys_map_name, 1, type, bit_count, code ); if code ^= 0 /* is it there ? */ then go to get_err_file ; /* no, don't dprint it */ /* set the ring brackets properly */ call hcs_$set_ring_brackets ( dir_path, sys_map_name, rings, code ); get_err_file: /* check to see if the error file is there */ call hcs_$status_minf ( dir_path, err_file_name, 1, type , bit_count, code); if code = error_table_$noentry then go to get_user_maps; call hcs_$set_ring_brackets ( err_file_path, "", rings, code ); if bit_count = 0 then call hcs_$delentry_file ( err_file_path, "", code ); /* */ /* * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Get set up to dprint the user maps. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * */ get_user_maps: /* first get a seg for star area */ call hcs_$make_seg( "", "carry_dump_area_", "", 01111b, area_ptr, code ); if area_ptr = null() then do; call com_err_ ( code, "carry_dump_dp", "^/Unable to create area segment, unable to dprint user maps."); return; end; call area_ (60000, area_ptr); /* initialize the allocation area */ /* get the entry list */ call hcs_$star_ (map_dir_path, "**", 3, area_ptr, ecount, eptr, nptr, code ); if code ^= 0 /* error getting names ? */ then do; /* yes, then complain and leave */ call com_err_ ( code, "carry_dump_dp", "^/Unable to obtain names of user maps, unable to dprint user maps." ); go to delete_old_dirs; end; /* are there entries ? */ if ecount = 0 then go to delete_old_dirs; /* no, leave */ dir_len = index ( map_dir_path, " " ) - 1; /* get length of user map dir path */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Having set everything up, loop through the maps */ /* printing them for the users. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ do i = 1 to ecount; j = fixed ( eptr->entry(i).nindex ); /* get offset in name array */ /* generate header string */ call ioa_$rsnnl ( "^a", header, header_len, nptr->name(j) ); name_len = index ( nptr->name(j), " ") - 1; /* get length of user name */ if name_len = -1 /* is it 32 characters ? */ then name_len = 32; /* yes, make it so */ name_path = substr ( map_dir_path, 1, dir_len) /* make up map path name */ || ">" || substr (nptr->name(j), 1, name_len); /* set the proper ring brackets */ call hcs_$set_ring_brackets ( map_dir_path, nptr->name(j), rings, code ); /* Dprint this user map only if there were errors */ call hcs_$initiate_count(name_path,"","",bit_count,0,user_map_ptr,code); if user_map_ptr=null then do; dprint_map: call dprint$dp("-bf","-dl","-he",substr(header,1,header_len),name_path); end; else do; if bit_count^=0 then do; user_map_len = divide(bit_count,9,17,0); start = 1; do while(start>0); k = index(substr(user_map,start),":"); if k=0 then start = 0; else do; if k<11 | substr(user_map,start+k-11,11)^="Tape label:" then do; call hcs_$terminate_seg(user_map_ptr,0,code); go to dprint_map; end; start = start+k; end; end; end; call delete_$path(name_path,"","000101"b,"",code); end; end; /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* Delete all old user map directories. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ delete_old_dirs: call hcs_$star_ (dir_path, "**.map_dir", 2, area_ptr, ecount, eptr, nptr, code); if code^=0 | ecount<2 then go to delete_area; do i = 1 to ecount; dir_name = nptr->name(fixed(eptr->entry(i).nindex)); if eptr->entry(i).type="10"b then if dir_name^=map_dir_name then do; call hcs_$status_(dir_path,dir_name,1,addr(branch_status),null,code); if code=0 then do; time1 = fixed(branch_status.dtcm)*2**16; /* microseconds, */ time2 = clock_(); /* microseconds, */ call convert_date_to_binary_("1 day",one_day,code); if time2-time1>one_day then call delete_$path (dir_path, dir_name, "011000"b, "carry_dump", code); end; end; end; /* * * * * * * * * * * * * * * * * * * * * * * * * */ /* */ /* All done. Delete the area seg and leave. */ /* */ /* * * * * * * * * * * * * * * * * * * * * * * * * */ delete_area: call hcs_$delentry_seg (area_ptr, code ); /* that's got it */ return; end carry_dump_dp;  carry_load.pl1 04/09/85 1408.5rew 04/09/85 1404.1 437967 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ carry_load: proc; /* This module implements the carry_load, carry_map and carry_retrieve commands, which operate on tapes created by the carry_dump command. Usage: carry_load tape_number {-control_args} where: 1. tape_number is the ASCII identifier of a tape. 2. control_args can be: -comment STR, -com STR specifies a comment name for the previously specified tape. -copy_dir PATH, -cpd PATH specifies a different directory in which to place retrieved copies. -force, -fc loads tape even if it is more than 5 days old. -next_vol STR, -nxv STR specifies a continuation tape. -queue_dir PATH, -qd PATH specifies a different directory containing the carry queue. -test does not load a tape; used for testing. One of the entries on a carry tape is a directory containing segments to be mailed to requestors when the requests are successfully loaded. This directory is named mail_to_carry and resides in the specified queue directory. After the load has been performed, error messages are inserted in these mail segments and copies of entries that cannot be loaded are retrieved under the directory >daemon_dir_dir>carry_dir>copies. Note: This command reloads an entire carry tape. To load particular entries from a tape, use the carry_retrieve command. Active function usage: [carry_load tape_number {-control_args}] returns true if the tape could be read, false otherwise. Other commands: carry_map tape_number to list the contents of a carry tape, and: carry_retrieve tape_number {-select} path1 {-new_dir path2} etc. to retrieve a specified entry from a carry tape, possibly into someplace new. With -select, prints list of tape contents and accepts line nuumbers of requests. Steve Herbst 1/16/77 */ /* -trim and bug fixes 08/03/79 S. Herbst */ /* carry_retrieve -select 09/05/79 S. Herbst */ /* Add -user & -next_vol 01/08/80 S. Herbst */ /* Add -comment & -copy_dir 07/30/80 S. Herbst */ %include backup_control; dcl 1 request_info (request_count) aligned based, 2 sender char (32) unaligned, /* Person.Project */ 2 new_user char (32) unaligned, /* access name for copy if different */ 2 type_string char (32) unaligned, /* "Segment" or "Subtree" */ 2 path char (168) unaligned, /* pathname on tape */ 2 incacc_sw bit (1) aligned, /* ON if requestor lacks sma on parent */ 2 incacc_code fixed bin (35), /* code from hcs_$get_user_effmode */ 2 copy_sw bit (1) aligned, /* ON to retrieve copy */ 2 copy_path char (168) unaligned, /* >ddd>carry_dir>copies>... */ 2 user_dir char (168) unaligned; /* >ddd>ccarry_dir>copies>next_dir */ dcl queue_dir char (168) init (">ddd>carry_dir"); dcl copy_dir char (168) init (">daemon_dir_dir>carry_dir>copies"); dcl WHITE_SPACE char (2) int static options (constant) init (" "); /* HT SP */ dcl DIGITS char (10) int static options (constant) init ("1234567890"); dcl copy_path_array (50) char (168); dcl copy_sender_array (50) char (168); dcl query_explanation char (168) int static options (constant) init ("Type the numbers of the requests you want retrieved, with optional ""-new_dir PATH"", as in ""2 4 -nd >foo 6"""); dcl (dn, error_path, mail_dir_path, new_dn, process_dir, request_path, tape_log_path) char (168); dcl (command, en, temp_en) char (32); dcl arg char (arg_len) based (arg_ptr); dcl return_string char (return_len) varying based (return_ptr); dcl mail_seg char (mail_seg_len) based (mail_seg_ptr); dcl (buffer, error_line) char (500); dcl answer char (300) varying; dcl (err_string, sender_string) char (100); dcl name_string char (65); dcl (new_user_id, sender_id) char (32); dcl (destination, ds_arg) char (23); dcl (comment, tape_number) char (32) int static; dcl newline char (1) int static options (constant) init (" "); dcl 1 next_array (20) int static, 2 next_vol char (32), 2 next_comment char (32); dcl retrieve_array (500) bit (1) unaligned; dcl dtm72 bit (72); dcl (active_function, ds_sw, found_sw, force_sw, got_path, got_tape) bit (1) aligned; dcl (mail_sw, new_dir_sw, print_log_sw, select_sw, test_sw) bit (1) aligned; dcl use_first_tape bit (1) aligned int static; dcl tape_attached bit (1) aligned init ("0"b); dcl (bk_iocb, new_mail_iocb, old_mail_iocb, tape_log_iocb) ptr init (null); dcl (eptr, nptr) ptr init (null); dcl (area_ptr, arg_ptr, mail_seg_ptr, return_ptr, tape_log_ptr) ptr; dcl ptrs (2) ptr; dcl (control_ptr, info_ptr) ptr init (null); dcl mode fixed bin (5); dcl (arg_count, arg_len, buffer_len, copies_omitted, days, ecount, error_line_len) fixed bin; dcl (i, j, k, level, number_omitted, request_count, request_index, return_len, saved_request_count) fixed bin; dcl (next_vol_count, next_vol_index) fixed bin int static; dcl mail_seg_len fixed bin; dcl (mail_seg_bc, tape_log_bc) fixed bin (24); dcl code fixed bin (35); dcl (now, time_written, four_days) fixed bin (71); dcl ONE_DAY fixed bin (71) int static options (constant) init (86400000000); dcl ONE_HOUR fixed bin (71) int static options (constant) init (3600000000); dcl area area based (area_ptr); dcl 1 segment_acl (1) aligned, 2 access_name char (32) unaligned, 2 modes bit (36), 2 zero_pad bit (36), 2 status_code fixed bin (35); dcl 1 entries (ecount) aligned based (eptr), 2 type bit (2) unaligned, 2 nnames fixed bin (15) unaligned, 2 nindex fixed bin (17) unaligned; dcl star_names (99) char (32) aligned based (nptr); %include branch_status; %include query_info; %include send_mail_info; %include access_mode_values; dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$end_of_info fixed bin (35) ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$noentry fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$no_dir fixed bin (35) ext; dcl error_table_$not_act_fnc fixed bin (35) ext; dcl error_table_$not_attached fixed bin (35) ext; dcl error_table_$request_pending fixed bin (35) ext; dcl error_table_$rqover fixed bin (35) ext; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl (active_fnc_err_, active_fnc_err_$suppress_name) entry options (variable); dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed bin (24), fixed bin (35)); dcl backup_load_ entry (ptr, fixed bin (35)); dcl bk_input$input_finish entry; dcl bk_ss_$holdsw bit (1) aligned ext; dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl command_query_ entry options (variable); dcl convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35)); dcl convert_status_code_ entry (fixed bin (35), char (*), char (*)); dcl cu_$arg_count entry (fixed bin, fixed bin (35)); dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)); dcl cu_$level_get entry (fixed bin); dcl cv_dec_ entry (char (*)) returns (fixed bin); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_ entry returns (char (32)); dcl get_pdir_ entry returns (char (168)); dcl get_system_free_area_ entry returns (ptr); dcl get_temp_segments_ entry (char (*), (*)ptr, fixed bin (35)); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)); dcl hcs_$del_dir_tree entry (char (*), char (*), fixed bin (35)); dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (1), ptr, fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl (ioa_, ioa_$ioa_switch, ioa_$nnl, ioa_$rs, ioa_$rsnnl) entry options (variable); dcl iox_$attach_name entry (char (*), ptr, char (*), ptr, fixed bin (35)); dcl iox_$close entry (ptr, fixed bin (35)); dcl iox_$detach_iocb entry (ptr, fixed bin (35)); dcl iox_$error_output ptr ext; dcl iox_$find_iocb entry (char (*), ptr, fixed bin (35)); dcl iox_$get_line entry (ptr, ptr, fixed bin, fixed bin, fixed bin (35)); dcl iox_$open entry (ptr, fixed bin, bit (1), fixed bin (35)); dcl iox_$put_chars entry (ptr, ptr, fixed bin, fixed bin (35)); dcl iox_$user_output ptr ext; dcl release_temp_segments_ entry (char (*), (*)ptr, fixed bin (35)); dcl send_mail_ entry (char (*), char (*), ptr, fixed bin (35)); dcl send_message_$notify_mail entry options (variable); dcl unique_chars_ entry (bit (1) aligned) returns (char (32)); dcl (addr, clock, divide, fixed, index, length, ltrim) builtin; dcl (min, null, rtrim, search, substr, translate, unspec, verify) builtin; dcl (cleanup, program_interrupt) condition; /* */ command = "carry_load"; print_log_sw, select_sw = "0"b; call cu_$af_return_arg (arg_count, return_ptr, return_len, code); if code = error_table_$not_act_fnc then active_function = "0"b; else do; active_function = "1"b; return_string = "false"; end; if arg_count = 0 then do; USAGE: if active_function then call active_fnc_err_$suppress_name (0, "carry_load", "Usage: [carry_load tape_number {-control_args}]"); else call com_err_$suppress_name (0, "carry_load", "Usage: carry_load tape_number {-control_args}"); return; end; comment = ""; ds_sw, force_sw, got_tape, test_sw = "0"b; next_vol_count = 0; next_vol_index = 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 = "-force" | arg = "-fc" then force_sw = "1"b; else if arg = "-test" then test_sw = "1"b; else if arg = "-destination" | arg = "-ds" then do; i = i + 1; if i > arg_count then do; call warn (0, "carry_load", "No value specified for -destination."); return; end; ds_sw = "1"b; call cu_$arg_ptr (i, arg_ptr, arg_len, code); ds_arg = arg; end; else if arg = "-queue_dir" | arg = "-qd" then do; i = i + 1; if i > arg_count then do; call warn (0, "carry_load", "No value specified for -queue_dir"); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call absolute_pathname_ (arg, queue_dir, code); if code ^= 0 then do; call warn (code, "carry_load", arg); return; end; end; else if arg = "-comment" | arg = "-com" then do; i = i + 1; if i > arg_count then do; call warn (0, "carry_load", "No value specified for -comment."); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if next_vol_count = 0 then comment = arg; else next_array.next_comment (next_vol_count) = arg; end; else if arg = "-copy_dir" | arg = "-cpd" then do; i = i + 1; if i > arg_count then do; call warn (0, "carry_load", "No value specified for -copy_dir"); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); call absolute_pathname_ (arg, copy_dir, code); if code ^= 0 then do; call warn (code, "carry_load", arg); return; end; end; else if arg = "-next_vol" | arg = "-nxv" then do; i = i + 1; if i > arg_count then do; call warn (0, "carry_load", "No value specified for -next_vol."); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); next_vol_count = next_vol_count + 1; next_array.next_vol (next_vol_count) = arg; next_array.next_comment (next_vol_count) = ""; end; else do; code = error_table_$badopt; if active_function then call active_fnc_err_ (code, "carry_load", "^a", arg); else call com_err_ (code, "carry_load", "^a", arg); return; end; else if got_tape then go to USAGE; else do; got_tape = "1"b; tape_number = arg; end; end; if ^got_tape then go to USAGE; go to COMMON; /* */ carry_map: entry; command = "carry_map"; active_function = "0"b; print_log_sw = "1"b; call cu_$arg_count (arg_count, code); if arg_count = 0 then do; USAGE2: call com_err_$suppress_name (0, "carry_map", "Usage: carry_map tape_number {-next_vol ...}"); return; end; go to GET_ARGS; carry_retrieve: entry; command = "carry_retrieve"; active_function = "0"b; force_sw = "1"b; /* read tape no matter how old */ call cu_$arg_count (arg_count, code); if arg_count < 2 then do; USAGE3: call com_err_$suppress_name (0, "carry_retrieve", "Usage: carry_retrieve tape_number {-control_args} {path1} {-new_dir path2} etc."); return; end; GET_ARGS: ds_sw, got_tape, got_path, select_sw, test_sw = "0"b; comment = ""; next_vol_count = 0; next_vol_index = 1; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) ^= "-" then if ^got_tape then do; got_tape = "1"b; tape_number = arg; end; else got_path = "1"b; else if arg = "-next_vol" | arg = "-nxv" then do; i = i + 1; if i > arg_count then do; call com_err_ (0, command, "No value specified for -next_vol"); return; end; call cu_$arg_ptr (i, arg_ptr, arg_len, code); next_vol_count = next_vol_count + 1; next_array.next_vol (next_vol_count) = arg; end; else if command = "carry_map" then do; call com_err_ (error_table_$badopt, "carry_map", "^a", arg); return; end; else if arg = "-test" then test_sw = "1"b; else if arg = "-select" then select_sw = "1"b; else if arg = "-no_select" then select_sw = "0"b; end; if command = "carry_map" then do; if ^got_tape then go to USAGE2; end; else do; if ^got_path & ^select_sw then go to USAGE3; print_log_sw = select_sw; end; /* */ COMMON: on condition (cleanup) call clean_up; /* Allocate and initialize a control structure to drive backup_load_ */ call get_temp_segments_ (command, ptrs, code); if code ^= 0 then do; call warn (code, command, "^/Unable to allocate temp segs in process directory.^/Cannot load tape."); return; end; control_ptr = ptrs (1); info_ptr = ptrs (2); use_first_tape = "1"b; control_ptr -> backup_control.version = BACKUP_CONTROL_VERSION_5; control_ptr -> backup_control.tape_entry = load_tape_entry; unspec (control_ptr -> backup_control.options) = "0"b; control_ptr -> backup_control.debug_sw = "1"b; control_ptr -> backup_control.first = "1"b; if command = "carry_load" | select_sw then control_ptr -> backup_control.hold_sw = "1"b; else control_ptr -> backup_control.hold_sw = "0"b; if command = "carry_retrieve" & ^select_sw then go to RETRIEVE; /* Load .tape_log segment */ control_ptr -> backup_control.no_primary_sw = "0"b; /* try by both given and primary path */ call ioa_$rsnnl ("^a>^a.tape_log", tape_log_path, 168, queue_dir, tape_number); control_ptr -> backup_control.request_count = 1; control_ptr -> backup_control.path (1) = tape_log_path; if print_log_sw then do; process_dir = get_pdir_ (); call ioa_$rsnnl ("^a>^a.tape_log", tape_log_path, 168, process_dir, tape_number); control_ptr -> backup_control.new_path (1) = tape_log_path; end; else control_ptr -> backup_control.new_path (1) = ""; tape_attached = "1"b; call backup_load_ (control_ptr, code); if code = error_table_$not_attached then do; NO_TAPE: call warn (0, command, "Tape " || rtrim (tape_number) || " is not available."); go to RETURN; end; if print_log_sw then do; /* print tape log segment */ if code ^= 0 then do; call com_err_ (code, command, "Unable to load ^a", tape_log_path); go to RETURN; end; else if ^control_ptr -> backup_control.loaded (1) then do; call com_err_ (control_ptr -> backup_control.status_code (1), command, "Unable to load ^a", tape_log_path); go to RETURN; end; call adjust_bit_count_ ((process_dir), rtrim (tape_number) || ".tape_log", "1"b, tape_log_bc, code); call hcs_$initiate_count (tape_log_path, "", "", tape_log_bc, 0, tape_log_ptr, code); if select_sw then go to READ; call ioa_ ("^/"); call iox_$put_chars (iox_$user_output, tape_log_ptr, divide (tape_log_bc, 9, 17, 0), code); call ioa_ (""); call hcs_$delentry_file (tape_log_path, "", code); go to RETURN; end; if code ^= 0 then do; call warn (code, command, "^/Segment " || rtrim (tape_log_path) || " not loaded.^/Cannot load tape."); go to RETURN; end; else if ^control_ptr -> backup_control.loaded (1) then do; if control_ptr -> backup_control.status_code (1) = 0 then call warn (0, command, "Segment " || rtrim (tape_log_path) || " not found on tape. Cannot load tape."); else call warn (control_ptr -> backup_control.status_code (1), command, "^/Segment " || rtrim (tape_log_path) || " not found.^/Cannot load tape."); go to RETURN; end; /* Read .tape_log */ READ: segment_acl (1).access_name = "*.*.*"; segment_acl (1).modes = "100"b; segment_acl (1).zero_pad = "0"b; call hcs_$add_acl_entries (tape_log_path, "", addr (segment_acl), 1, code); call adjust_bit_count_ ((queue_dir), (rtrim (tape_number) || ".tape_log"), "1"b, (0), code); call iox_$attach_name ("carry_tape_log", tape_log_iocb, "vfile_ " || tape_log_path, null, code); if code ^= 0 then do; call warn (code, command, "^/Unable to attach ""carry_tape_log"" to " || tape_log_path); go to RETURN; end; call iox_$open (tape_log_iocb, 1, "0"b, code); if code ^= 0 then do; READ_ERROR: call warn (code, command, "^/Unable to read " || rtrim (tape_log_path) || "^/Cannot load tape."); go to RETURN; end; call iox_$get_line (tape_log_iocb, addr (buffer), length (buffer), buffer_len, code); if code ^= 0 then go to READ_ERROR; j = index (buffer, " to "); i = index (buffer, " written "); if i = 0 then do; PARSE_ERROR: call warn (0, command, "Syntax error in tape log " || tape_log_path); call ioa_$ioa_switch (iox_$error_output, substr (buffer, 1, min (100, buffer_len))); call ioa_$ioa_switch (iox_$error_output, "Cannot load tape."); go to RETURN; end; destination = substr (buffer, j + 4, i - j - 4); if ds_sw then if destination ^= ds_arg then do; call warn (0, command, "Tape destination " || rtrim (destination) || " does not match destination arg " || rtrim (ds_arg) || "^/Cannot load tape."); go to RETURN; end; i = i + 9; call convert_date_to_binary_ (substr (buffer, i, buffer_len - i), time_written, code); if code ^= 0 then go to PARSE_ERROR; days = divide (clock () - time_written, ONE_DAY, 71, 0); if days > 5 & ^force_sw then do; call ioa_$rsnnl ("Tape is ^d days old and may contain old data.^/Not loaded.", buffer, buffer_len, days); call warn (0, command, substr (buffer, 1, buffer_len)); go to RETURN; end; if select_sw then call ioa_ ("^/^a", substr (buffer, 1, buffer_len)); /* print header */ /* */ /* Test that requestors have sma access to parent directories */ call cu_$level_get (level); call iox_$get_line (tape_log_iocb, addr (buffer), length (buffer), buffer_len, code); request_count, control_ptr -> backup_control.request_count = 0; number_omitted = 0; if select_sw then on program_interrupt go to QUERY_INIT; do while (code ^= error_table_$end_of_info); if buffer_len >= 22 & substr (buffer, 1, 22) = "No requests submitted." & control_ptr -> backup_control.request_count < 2 then do; call ioa_ ("Tape contains no requests."); if active_function then return_string = "true"; go to RETURN; end; request_count, control_ptr -> backup_control.request_count = request_count + 1; if select_sw then call ioa_$nnl ("^3d^2x^a", request_count, substr (buffer, 1, buffer_len)); i = index (buffer, " "); if i = 0 then go to PARSE_ERROR; info_ptr -> request_info (request_count).type_string = substr (buffer, 1, 7); control_ptr -> backup_control.no_primary_sw (request_count) = "1"b; if substr (buffer, buffer_len, 1) = newline then buffer_len = buffer_len - 1; if substr (buffer, buffer_len - 8, 9) = " -new_dir" then do; new_dir_sw = "1"b; buffer_len = buffer_len - 9; end; else new_dir_sw = "0"b; if substr (buffer, buffer_len - 5, 6) = " -trim" then do; control_ptr -> backup_control.trim_sw (request_count) = "1"b; buffer_len = buffer_len - 6; end; else control_ptr -> backup_control.trim_sw (request_count) = "0"b; sender_string = substr (buffer, i + 2, buffer_len - i - 1); j = index (sender_string, " -user "); if j = 0 then do; sender_id = sender_string; new_user_id = ""; end; else do; sender_id = substr (sender_string, 1, j - 1); new_user_id = substr (sender_string, j + 7); end; info_ptr -> request_info (request_count).sender = sender_id; info_ptr -> request_info (request_count).new_user = new_user_id; request_path, control_ptr -> backup_control.path (request_count) = substr (buffer, 9, i - 9); control_ptr -> backup_control.new_path (request_count) = ""; call expand_pathname_ (request_path, dn, en, code); if code ^= 0 then go to NEXT_LINE; if new_dir_sw then do; call iox_$get_line (tape_log_iocb, addr (buffer), length (buffer), buffer_len, code); if code = 0 then do; request_path, control_ptr -> backup_control.new_path (request_count) = substr (buffer, 29, buffer_len - 29) || ">" || en; if select_sw then call ioa_$nnl ("^5x^a", substr (buffer, 1, buffer_len)); end; end; if select_sw then go to NEXT_LINE; /* don't test access for carry_retrieve */ temp_en = ""; /* get access on parent */ GET_MODE: if substr (sender_id, length (rtrim (sender_id)) - 1, 1) = "." then call hcs_$get_user_effmode (dn, temp_en, sender_id, level, mode, code); else call hcs_$get_user_effmode (dn, temp_en, rtrim (sender_id) || ".*", level, mode, code); if (mode ^= SMA_ACCESS_BIN & code = 0) | (code ^= 0 & (code ^= error_table_$noentry | temp_en ^= "") & code ^= error_table_$no_dir) then if temp_en = "" & info_ptr -> request_info (request_count).type_string = "Subtree" then do; temp_en = en; /* settle for sma on existing directory itself */ go to GET_MODE; end; else do; info_ptr -> request_info (request_count).incacc_sw = "1"b; info_ptr -> request_info (request_count).incacc_code = code; info_ptr -> request_info (request_count).path = control_ptr -> backup_control.path (request_count); control_ptr -> backup_control.path (request_count) = ">foo>foo"; /* not findable */ end; NEXT_LINE: call iox_$get_line (tape_log_iocb, addr (buffer), length (buffer), buffer_len, code); end; if select_sw then do; /* carry_retrieve -select */ QUERY_INIT: unspec (query_info) = "0"b; query_info.version = query_info_version_5; query_info.suppress_name_sw = "1"b; query_info.explanation_ptr = addr (query_explanation); query_info.explanation_len = length (rtrim (query_explanation)); QUERY: call command_query_ (addr (query_info), answer, "carry_retrieve", "Request numbers: "); unspec (retrieve_array) = "0"b; request_index = 0; /* initialize */ answer = ltrim (answer, WHITE_SPACE); do while (answer ^= ""); dn = get_token (); if verify (rtrim (dn), DIGITS) = 0 then do; request_index = cv_dec_ (dn); if request_index < 1 | request_index > request_count then do; call com_err_ (0, "carry_retrieve", "No request number ^d", request_index); go to QUERY; end; retrieve_array (request_index) = "1"b; /* to be retrieved */ end; else if dn = "-new_dir" | dn = "-nd" then do; if request_index = 0 then do; call com_err_ (0, "carry_retrieve", "-new_dir must follow a request number."); go to QUERY; end; dn = get_token (); if dn = "" then do; call com_err_ (0, "carry_retrieve", "No value specified for -new_dir"); go to QUERY; end; call absolute_pathname_ (dn, dn, code); if code ^= 0 then do; call com_err_ (code, "carry_retrieve", "^a", dn); go to QUERY; end; call expand_pathname_ (control_ptr -> backup_control.path (request_index), "", en, code); control_ptr -> backup_control.new_path (request_index) = rtrim (dn) || ">" || en; end; else do; call com_err_ (0, "carry_retrieve", "Can only select request #'s, optionally followed by -nd PATH."); go to QUERY; end; end; if substr (unspec (retrieve_array), 1, request_count) = "0"b then do; call com_err_ (0, "carry_retrieve", "No retrievals requested."); go to RETURN; end; do i = 1 to request_count; if ^retrieve_array (i) then control_ptr -> backup_control.path (i) = ">foo>foo"; /* not findable dummy */ end; tape_attached = "1"b; go to RELOAD; end; /* */ /* Add mail_to_carry directory to the control structure */ call ioa_$rsnnl ("^a>mail_to_carry", buffer, buffer_len, queue_dir); control_ptr -> backup_control.path (request_count + 1) = buffer; control_ptr -> backup_control.new_path (request_count + 1) = ""; request_count, control_ptr -> backup_control.request_count = request_count + 1; /* Delete old mail_to_carry directory */ call hcs_$status_minf (queue_dir, "mail_to_carry", 1, 0, 0, code); if code ^= error_table_$noentry then do; segment_acl (1).access_name = get_group_id_ (); segment_acl (1).modes = "111"b; call hcs_$add_dir_acl_entries (queue_dir, "mail_to_carry", addr (segment_acl), 1, code); call hcs_$del_dir_tree (queue_dir, "mail_to_carry", code); call hcs_$delentry_file (queue_dir, "mail_to_carry", code); end; /* Pick up args to carry_retrieve */ RETRIEVE: if command = "carry_retrieve" then do; request_count, control_ptr -> backup_control.request_count = 0; do i = 2 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) = "-" then if arg = "-new_dir" | arg = "-nd" | arg = "-move" | arg = "-mv" then if request_count = 0 then go to USAGE3; else do; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then go to USAGE3; call absolute_pathname_ (arg, new_dn, code); if code ^= 0 then do; BADPATH: call com_err_ (code, "carry_retrieve", "^a", arg); go to RETURN; end; control_ptr -> backup_control.new_path (request_count) = rtrim (new_dn) || ">" || en; end; else do; call com_err_ (error_table_$badopt, "carry_retrieve", "^a", arg); go to RETURN; end; else do; request_count, control_ptr -> backup_control.request_count = request_count + 1; call expand_pathname_ (arg, dn, en, code); if code ^= 0 then go to BADPATH; control_ptr -> backup_control.path (request_count) = rtrim (dn) || ">" || en; control_ptr -> backup_control.new_path (request_count) = ""; control_ptr -> backup_control.no_primary_sw (request_count) = "1"b; end; end; tape_attached = "1"b; end; control_ptr -> backup_control.no_reload_sw = test_sw; RELOAD: /* Try loading each thing by primary path as well, just in case */ do i = 1 to request_count; control_ptr -> backup_control.requests (i + request_count) = control_ptr -> requests (i); control_ptr -> backup_control.no_primary_sw (i + request_count) = "0"b; end; control_ptr -> backup_control.request_count = request_count * 2; /* Perform the reload */ call backup_load_ (control_ptr, code); if code = error_table_$not_attached then go to NO_TAPE; if code ^= 0 then do; call warn (code, command, "^/Tape " || rtrim (tape_number) || " not loaded."); go to RETURN; end; /* See if any were loaded by primary path instead of the expected path */ do i = 1 to request_count; if ^control_ptr -> backup_control.found (i) & control_ptr -> backup_control.found (i + request_count) then control_ptr -> backup_control.requests (i) = /* copy the primary path's info */ control_ptr -> backup_control.requests (i + request_count); end; control_ptr -> backup_control.request_count = request_count; if command = "carry_retrieve" then do; do i = 1 to control_ptr -> backup_control.request_count; if control_ptr -> backup_control.path (i) ^= ">foo>foo" then do; /* selected */ if ^control_ptr -> backup_control.loaded (i) then call ioa_$ioa_switch (iox_$error_output, "^a not ^[loaded^;found on tape^].", control_ptr -> backup_control.path (i), control_ptr -> backup_control.found (i)); if control_ptr -> backup_control.status_code (i) ^= 0 then do; dn = control_ptr -> backup_control.new_path (i); if dn = "" then dn = control_ptr -> backup_control.path (i); call com_err_ (control_ptr -> backup_control.status_code (i), control_ptr -> backup_control.error_name (i), dn); end; end; end; go to RETURN; end; if active_function then return_string = "true"; if control_ptr -> backup_control.loaded (request_count) then mail_sw = "1"b; /* mail dir loaded */ else mail_sw = "0"b; /* Look for error codes */ do i = 1 to control_ptr -> backup_control.request_count - 1; if control_ptr -> backup_control.loaded (i) then call really_look (i); if ^control_ptr -> backup_control.loaded (i) & control_ptr -> backup_control.status_code (i) ^= error_table_$noentry then do; number_omitted = number_omitted + 1; if info_ptr -> request_info (i).incacc_sw then control_ptr -> backup_control.path (i) = info_ptr -> request_info (i).path; else info_ptr -> request_info (i).path = control_ptr -> backup_control.path (i); if control_ptr -> backup_control.status_code (i) = 0 then do; control_ptr -> backup_control.status_code (i) = error_table_$noentry; control_ptr -> backup_control.error_name (i) = ""; end; /* Prepare to retrieve a copy */ if control_ptr -> backup_control.found (i) then do; /* only if found at all */ info_ptr -> request_info (i).copy_sw = "1"b; dn = control_ptr -> backup_control.new_path (i); if dn = "" then dn = control_ptr -> backup_control.path (i); j = index (substr (dn, 2), ">"); if j ^= 0 then do; k = index (substr (dn, j + 2), ">"); if k ^= 0 then if index (substr (dn, j + k + 2), ">") ^= 0 then dn = substr (dn, j + k + 1); end; dn = rtrim (copy_dir) || dn; info_ptr -> request_info (i).copy_path = dn; j = index (substr (dn, length (rtrim (copy_dir)) + 2), ">"); if j = 0 then info_ptr -> request_info.user_dir (i) = ""; else info_ptr -> request_info.user_dir (i) = substr (dn, 1, j + length (rtrim (copy_dir)) + 1); end; end; code = control_ptr -> backup_control.status_code (i); name_string = control_ptr -> backup_control.error_name (i); if code ^= 0 & name_string ^= "hcs_$set_safety_sw" & name_string ^= "hcs_$replace_dir_acl" & name_string ^= "set_ring_brackets" then do; /* Print error message */ if info_ptr -> request_info (i).incacc_sw then do; /* Lack sma to requestor */ code = info_ptr -> request_info (i).incacc_code; error_path = info_ptr -> request_info (i).path; if code = 0 then buffer = "Requestor lacks sma access to parent directory."; else buffer = "^/Cannot check requestor's access to parent directory."; call warn (code, "carry_load", rtrim (buffer) || " " || error_path); end; else if name_string = "ACL, ring brackets, safety switch" then do; if control_ptr -> backup_control.new_path (i) ^= "" then error_path = control_ptr -> backup_control.new_path (i); else error_path = control_ptr -> backup_control.path (i); call ioa_$ioa_switch (iox_$error_output, "Warning: No access to set ACL, ring brackets, safety switch. ^a", error_path); end; else do; if control_ptr -> backup_control.found (i) & control_ptr -> backup_control.new_path (i) ^= "" then error_path = control_ptr -> backup_control.new_path (i); else error_path = control_ptr -> backup_control.path (i); if code = error_table_$noentry then call warn (0, name_string, "Entry not found on tape: " || rtrim (error_path) || " Entry not loaded."); else call warn (code, name_string, error_path); end; if mail_sw then do; /* Put error message in mail seg */ if code = error_table_$incorrect_access then err_string = "Incorrect access to some containing directory."; else call convert_status_code_ (code, "", err_string); if info_ptr -> request_info (i).incacc_sw then if code = 0 then call ioa_$rs ("carry_load: " || buffer || " ^a", error_line, error_line_len, error_path); else call ioa_$rs ("carry_load: ^a ^a " || buffer, error_line, error_line_len, err_string, error_path); else if name_string = "ACL, ring brackets, safety switch" then call ioa_$rs ("Warning: No access to set ACL, ring brackets, safety switch. ^a", error_line, error_line_len, error_path); else call ioa_$rs ("^a: ^a ^a", error_line, error_line_len, name_string, err_string, error_path); sender_id = info_ptr -> request_info.new_user (i); if sender_id = "" then sender_id = info_ptr -> request_info.sender (i); call ioa_$rsnnl ("^a>mail_to_carry", dn, 168, queue_dir); temp_en = unique_chars_ ("0"b); /* prepare to copy mail seg */ call hcs_$chname_file (dn, sender_id, sender_id, temp_en, code); if code ^= 0 then go to MAIL_END; found_sw = "0"b; call iox_$attach_name ("old_carry_mail", old_mail_iocb, "vfile_ " || rtrim (dn) || ">" || temp_en, null, code); if code ^= 0 then go to MAIL_END; call iox_$open (old_mail_iocb, 1, "0"b, code); if code ^= 0 then go to DETACH_OLD; call iox_$attach_name ("new_carry_mail", new_mail_iocb, "vfile_ " || rtrim (dn) || ">" || sender_id, null, code); if code ^= 0 then go to CLOSE_OLD; call iox_$open (new_mail_iocb, 2, "0"b, code); if code ^= 0 then go to DETACH_NEW; call iox_$get_line (old_mail_iocb, addr (buffer), length (buffer), buffer_len, code); do while (code ^= error_table_$end_of_info); if ^found_sw then do; /* still looking */ /* See if this is the right line */ request_path = substr (buffer, 9, index (buffer, " loaded ") - 9); if request_path = error_path then do; found_sw = "1"b; if control_ptr -> backup_control.loaded (i) then do; call iox_$put_chars (new_mail_iocb, addr (buffer), buffer_len, code); call iox_$put_chars (new_mail_iocb, addr (error_line), error_line_len, code); end; else do; call ioa_$ioa_switch (new_mail_iocb, "Unable to load ^a from tape ^a", error_path, tape_number); error_line_len = length (rtrim (error_line)); call iox_$put_chars (new_mail_iocb, addr (error_line), error_line_len, code); if unspec (info_ptr -> request_info (i).copy_path) = "0"b then call ioa_$ioa_switch (new_mail_iocb, "Check for copy in ^a", copy_dir); else call ioa_$ioa_switch (new_mail_iocb, "Check for copy ^a", info_ptr -> request_info (i).copy_path); end; end; else call iox_$put_chars (new_mail_iocb, addr (buffer), buffer_len, code); end; else call iox_$put_chars (new_mail_iocb, addr (buffer), buffer_len, code); call iox_$get_line (old_mail_iocb, addr (buffer), length (buffer), buffer_len, code); end; call iox_$close (new_mail_iocb, code); DETACH_NEW: call iox_$detach_iocb (new_mail_iocb, code); CLOSE_OLD: call iox_$close (old_mail_iocb, code); DETACH_OLD: call iox_$detach_iocb (old_mail_iocb, code); call hcs_$delentry_file (dn, temp_en, code); MAIL_END: end; end; end; /* Print "not loaded" messages */ do i = 1 to control_ptr -> backup_control.request_count - 1; if ^control_ptr -> backup_control.loaded (i) then call ioa_$ioa_switch (iox_$error_output, "^a ^a not loaded.", info_ptr -> request_info (i).type_string, control_ptr -> backup_control.path (i)); end; if command = "carry_retrieve" then go to RETURN; /* Clean up old copies */ call delete_old_copies; /* Retrieve copies */ saved_request_count = control_ptr -> backup_control.request_count - 1; request_count, control_ptr -> backup_control.request_count = 0; do i = 1 to saved_request_count; if info_ptr -> request_info (i).copy_sw then do; request_count, control_ptr -> backup_control.request_count = request_count + 1; control_ptr -> backup_control.path (request_count) = info_ptr -> request_info (i).path; control_ptr -> backup_control.new_path (request_count) = info_ptr -> request_info (i).copy_path; control_ptr -> backup_control.status_code (request_count) = 0; info_ptr -> request_info (request_count).sender = info_ptr -> request_info (i).sender; info_ptr -> request_info (request_count).new_user = info_ptr -> request_info (i).new_user; info_ptr -> request_info (request_count).type_string = info_ptr -> request_info (i).type_string; end; end; if request_count = 0 then do; bk_ss_$holdsw = "0"b; /* demount tape */ call bk_input$input_finish; end; else do; control_ptr -> backup_control.hold_sw = "0"b; call backup_load_ (control_ptr, code); end; tape_attached = "0"b; /* Set access on copies */ segment_acl (1).modes = "111"b; copies_omitted = 0; do i = 1 to request_count; if control_ptr -> backup_control.loaded (i) then call really_look (i); if ^control_ptr -> backup_control.loaded (i) then do; if control_ptr -> backup_control.status_code (i) = error_table_$rqover then call hcs_$delentry_file (control_ptr -> backup_control.new_path (i), "", code); if control_ptr -> backup_control.status_code (i) = error_table_$incorrect_access then call com_err_ (0, "carry_load", "Incorrect access to some containing directory. ^a", control_ptr -> backup_control.new_path (i)); else if control_ptr -> backup_control.status_code (i) ^= 0 then call com_err_ (control_ptr -> backup_control.status_code (i), "carry_load", "^[Copy not loaded. ^]^a", control_ptr -> backup_control.status_code (i) - 0, control_ptr -> backup_control.new_path (i)); copies_omitted = copies_omitted + 1; copy_path_array (copies_omitted) = control_ptr -> backup_control.new_path (i); copy_sender_array (copies_omitted) = info_ptr -> request_info (i).sender; if active_function then return_string = "false"; end; sender_id = info_ptr -> request_info (i).new_user; if sender_id = "" then sender_id = info_ptr -> request_info (i).sender; segment_acl (1).access_name = substr (sender_id, 1, index (sender_id, ".") - 1) || ".*.*"; call expand_pathname_ (control_ptr -> backup_control.path (i), dn, en, code); call hcs_$add_dir_acl_entries (dn, "", addr (segment_acl), 1, code); /* parent */ if code ^= 0 & control_ptr -> backup_control.loaded (i) then call warn (code, "carry_load", dn); if info_ptr -> request_info (i).user_dir ^= "" then call hcs_$add_dir_acl_entries (info_ptr -> request_info (i).user_dir, "", addr (segment_acl), 1, code); if info_ptr -> request_info (i).type_string = "Subtree" then call hcs_$add_dir_acl_entries (dn, en, addr (segment_acl), 1, code); else call hcs_$add_acl_entries (dn, en, addr (segment_acl), 1, code); end; /* Send mail to requestors */ area_ptr = get_system_free_area_ (); send_mail_info.version = 2; send_mail_info.sent_from = ""; unspec (send_mail_info.switches) = "0"b; send_mail_info.always_add = "1"b; call ioa_$rsnnl ("^a>mail_to_carry", mail_dir_path, 168, queue_dir); ecount = 0; call hcs_$star_ (mail_dir_path, "**", 3 /* all */, area_ptr, ecount, eptr, nptr, code); do i = 1 to ecount; sender_id = star_names (entries (i).nindex); call hcs_$initiate_count (mail_dir_path, sender_id, "", mail_seg_bc, 0, mail_seg_ptr, code); if mail_seg_ptr ^= null then do; mail_seg_len = divide (mail_seg_bc, 9, 17, 0); call send_mail_ (sender_id, mail_seg, addr (send_mail_info), code); j = index (sender_id, "."); call send_message_$notify_mail (substr (sender_id, 1, j - 1), substr (sender_id, j + 1), code); /* send mail notification */ call hcs_$terminate_noname (mail_seg_ptr, code); end; end; call ioa_ ("carry_load: Normal termination."); if number_omitted ^= 0 then call ioa_ ("^d request^[s^] not loaded in place.", number_omitted, number_omitted > 1); if copies_omitted ^= 0 then do; call ioa_ ("OF THESE, ^d COPIES NOT LOADED:", copies_omitted); do i = 1 to copies_omitted; call ioa_ ("^3x^a^3x^a", copy_path_array (i), copy_sender_array (i)); end; end; RETURN: call clean_up; return; /* */ get_token: proc returns (char (168)); /* This internal procedure, used by carry_retrieve -select, returns the next space-separated token from the user's answer to "Request numbers:" query. */ dcl token char (168); if answer = "" then return (""); i = search (answer, WHITE_SPACE); if i = 0 then do; token = answer; answer = ""; end; else do; token = substr (answer, 1, i - 1); answer = ltrim (substr (answer, i), WHITE_SPACE); end; return (token); end get_token; /* */ really_look: proc (i); /* Checks that an entry has really been loaded with nonzero contents. */ dcl i fixed bin; dcl path char (168); path = control_ptr -> backup_control.new_path (i); if path = "" then path = control_ptr -> backup_control.path (i); call hcs_$status_ (path, "", 1, addr (branch_status), null, code); if code = error_table_$noentry | code = error_table_$no_dir then do; NOT_THERE: control_ptr -> backup_control.loaded (i) = "0"b; control_ptr -> backup_control.status_code (i) = error_table_$request_pending; /* "Request has not been completed" */ end; else if code = 0 then do; dtm72 = "0"b; substr (dtm72, 21, 36) = branch_status.date_time_modified; /* convert dtcm to clock time */ unspec (time_written) = unspec (dtm72); if clock () - time_written > ONE_HOUR then go to NOT_THERE; if branch_status.records = "0"b then go to NOT_THERE; end; end really_look; /* */ delete_old_copies: proc; /* This internal procedure deletes all directories under >ddd>carry_dir>copies all of whose segments are more than 4 days old. */ call convert_date_to_binary_ ("4 days", four_days, code); now = clock (); segment_acl (1).access_name = get_group_id_ (); segment_acl (1).modes = "111"b; area_ptr = get_system_free_area_ (); eptr, nptr = null; on condition (cleanup) begin; if eptr ^= null then free eptr -> entries in (area); if nptr ^= null then free nptr -> star_names in (area); end; call hcs_$star_ (copy_dir, "**", 3 /* all */, area_ptr, ecount, eptr, nptr, code); if code ^= 0 then return; do i = 1 to ecount; en = star_names (entries (i).nindex); if ALL_OLD (copy_dir, en) then do; call hcs_$del_dir_tree (copy_dir, en, code); call hcs_$delentry_file (copy_dir, en, code); end; end; if eptr ^= null then free eptr -> entries in (area); if nptr ^= null then free nptr -> star_names in (area); end delete_old_copies; /* */ ALL_OLD: proc (DN, EN) returns (bit (1) aligned); /* This internal procedure, which calls itself recursively, returns ("1"b) if all segments below it are more than 2 weeks old. */ dcl (DN, EN) char (*); dcl DIR_NAME char (168); dcl ENAME char (32); dcl (EPTR, NPTR) ptr; dcl (ECOUNT, I) fixed bin; call hcs_$status_ (DN, EN, 0, addr (branch_status), area_ptr, code); if code ^= 0 then return ("0"b); if branch_status.type = segment_type | branch_status.type = link_type then if now - fixed (branch_status.date_time_modified || (16)"0"b, 52) > four_days then return ("1"b); else return ("0"b); else do; call hcs_$add_dir_acl_entries (DN, EN, addr (segment_acl), 1, code); EPTR, NPTR = null; on condition (cleanup) call free_names; DIR_NAME = rtrim (DN) || ">" || EN; call hcs_$star_ (DIR_NAME, "**", 3 /* all */, area_ptr, ECOUNT, EPTR, NPTR, code); if code ^= 0 then if code = error_table_$nomatch then return ("1"b); else return ("0"b); do I = 1 to ECOUNT; ENAME = NPTR -> star_names (EPTR -> entries (I).nindex); if ^ALL_OLD (DIR_NAME, ENAME) then do; call free_names; return ("0"b); end; end; call free_names; return ("1"b); end; free_names: proc; if EPTR ^= null then free EPTR -> entries in (area); if NPTR ^= null then free NPTR -> star_names in (area); end free_names; end ALL_OLD; /* */ load_tape_entry: entry (tape_label); /* This entry point, called by backup_load_, returns carry_load's tape_number argument the first time it is called, -next_vol arguments succeeding times, and finally "" */ dcl tape_label char (32); if use_first_tape then if comment ^= "" then tape_label = rtrim (tape_number) || ",*" || translate (comment, ";", ","); else tape_label = tape_number; else if next_vol_index <= next_vol_count then do; tape_label = next_array.next_vol (next_vol_index); if next_array.next_comment (next_vol_index) ^= "" then tape_label = rtrim (tape_label) || ",*" || translate (next_array.next_comment (next_vol_index), ";", ","); next_vol_index = next_vol_index + 1; end; else tape_label = ""; use_first_tape = "0"b; return; /* */ warn: proc (a_code, a_name, a_string); /* This internal procedure prints an error message on error_output without signalling in the case of an active function. In the case of a command, it calls com_err_. We don't want active function error messages to abort exec_com's. */ dcl a_code fixed bin (35); dcl (a_name, a_string) char (*); if active_function then do; if a_name = "" then a_name = "carry_load"; if a_code = 0 then call ioa_$ioa_switch (iox_$error_output, "^a: " || a_string, a_name); else do; call convert_status_code_ (a_code, "", err_string); call ioa_$ioa_switch (iox_$error_output, "^a: ^a " || a_string, a_name, err_string); end; end; else if a_name = "" then call com_err_$suppress_name (a_code, "carry_load", a_string); else call com_err_ (a_code, a_name, a_string); end warn; clean_up: proc; if tape_attached then do; call bk_input$input_finish; call iox_$find_iocb ("bk_input_1", bk_iocb, code); call iox_$close (bk_iocb, code); call iox_$detach_iocb (bk_iocb, code); end; if old_mail_iocb ^= null then call iox_$close (old_mail_iocb, code); if old_mail_iocb ^= null then call iox_$detach_iocb (old_mail_iocb, code); if new_mail_iocb ^= null then call iox_$close (new_mail_iocb, code); if new_mail_iocb ^= null then call iox_$detach_iocb (new_mail_iocb, code); if tape_log_iocb ^= null then call iox_$close (tape_log_iocb, code); if tape_log_iocb ^= null then call iox_$detach_iocb (tape_log_iocb, code); call release_temp_segments_ ("carry_load", ptrs, code); end clean_up; end carry_load;  carry_total.pl1 11/15/82 1811.6rew 11/15/82 1459.2 51453 /* *********************************************************** * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ carry_total: ct: proc; /* This active function returns the number of carry requests in a given queue. Usage: [carry_total {-control_args}] where control args can be: -admin to include all requests. By default, only the user's own requests are included. -destination XXXX, -ds XXXX to specify a destination and thereby the queue XXXX.carry.ms. -queue_dir path, -qd path to specify the pathname of a carry queue. Steve Herbst 9/21/76 */ dcl mseg_dir char(168) init(">daemon_dir_dir>carry_dir"); dcl mseg_name char(32) init("carry.ms"); dcl arg char(arg_len) based(arg_ptr); dcl return_arg char(return_len) varying based(return_ptr); dcl message char(mseg_args.ms_len) based(mseg_args.ms_ptr); dcl buffer char(8) aligned; dcl (active_function, admin_mode) bit(1) aligned; dcl area area based(area_ptr); dcl (area_ptr, arg_ptr, return_ptr) ptr; dcl (arg_count, arg_len, i, j, message_count, mseg_index, return_len) fixed bin; dcl code fixed bin(35); dcl error_table_$badopt fixed bin(35) ext; dcl error_table_$entlong fixed bin(35) ext; dcl error_table_$no_message fixed bin(35) ext; dcl error_table_$no_s_permission fixed bin(35) ext; dcl error_table_$not_act_fnc fixed bin(35) ext; %include mseg_return_args; dcl 1 mseg_args like mseg_return_args; dcl complain entry variable options(variable); dcl active_fnc_err_ entry options(variable); dcl com_err_ entry options(variable); dcl cu_$af_return_arg entry(fixed bin,ptr,fixed bin,fixed bin(35)); dcl cu_$arg_ptr entry(fixed bin,ptr,fixed bin,fixed bin(35)); dcl expand_path_ entry(ptr,fixed bin,ptr,ptr,fixed bin(35)); dcl get_system_free_area_ entry returns(ptr); dcl hcs_$status_minf entry(char(*),char(*),fixed bin(1),fixed bin(2),fixed bin(24),fixed bin(35)); dcl ioa_ entry options(variable); dcl ioa_$rsnnl entry options(variable); dcl message_segment_$close entry(fixed bin,fixed bin(35)); dcl message_segment_$get_message_count_index entry(fixed bin,fixed bin,fixed bin(35)); dcl message_segment_$open entry(char(*),char(*),fixed bin,fixed bin(35)); dcl message_segment_$own_incremental_read_index entry(fixed bin,ptr,bit(2),bit(72),ptr,fixed bin(35)); dcl message_segment_$own_read_index entry(fixed bin,ptr,bit(1),ptr,fixed bin(35)); dcl (addr, length, null, reverse, substr, verify) builtin; /* */ call cu_$af_return_arg(arg_count,return_ptr,return_len,code); if code=error_table_$not_act_fnc then do; active_function = "0"b; complain = com_err_; end; else do; active_function = "1"b; complain = active_fnc_err_; end; admin_mode = "0"b; do i = 1 to arg_count; call cu_$arg_ptr(i,arg_ptr,arg_len,code); if substr(arg,1,1)^="-" then do; USAGE: if active_function then call active_fnc_err_(0,"", "Usage: [carry_total {-control_args}]"); else call com_err_(0,"","Usage: carry_total -control_args-"); return; end; else if arg="-admin" then admin_mode = "1"b; else if arg="-destination" | arg="-ds" then do; i = i+1; call cu_$arg_ptr(i,arg_ptr,arg_len,code); if code^=0 then do; call complain(0,"carry_total","Destination missing."); return; end; mseg_name = arg || ".carry.ms"; call hcs_$status_minf(mseg_dir,mseg_name,1,(0),(0),code); if code^=0 & code^=error_table_$no_s_permission then do; call complain(0,"carry_total","Invalid destination ^a",arg); return; end; end; else if arg="-queue_dir" | arg="-qd" then do; i = i+1; call cu_$arg_ptr(i,arg_ptr,arg_len,code); if code^=0 then do; call complain(0,"carry_total","Queue directory pathname missing."); return; end; call expand_path_(arg_ptr,arg_len,addr(mseg_dir),null,code); if code^=0 then do; call complain(code,"carry_total","^a",arg); return; end; end; else do; call complain(error_table_$badopt,"carry_total","^a",arg); return; end; end; /* */ call message_segment_$open(mseg_dir,mseg_name,mseg_index,code); if mseg_index=0 then do; call complain(code,"carry_total","^a>^a",mseg_dir,mseg_name); return; end; if admin_mode then do; call message_segment_$get_message_count_index(mseg_index,message_count,code); if code^=0 then do; MSEG_ERROR: call complain(code,"carry_total","^a>^a",mseg_dir,mseg_name); go to CLOSE; end; end; else do; area_ptr = get_system_free_area_(); message_count = 0; call message_segment_$own_read_index(mseg_index,area_ptr,"0"b,addr(mseg_args),code); do while(code=0); message_count = message_count+1; free mseg_args.ms_ptr->message in(area); call message_segment_$own_incremental_read_index (mseg_index,area_ptr,"01"b,mseg_args.ms_id,addr(mseg_args),code); end; if code^=error_table_$no_message then go to MSEG_ERROR; end; if active_function then do; call ioa_$rsnnl("^d",buffer,j,message_count); return_arg = substr(buffer,1,j); end; else if admin_mode then call ioa_("There are ^d carry requests in ^a>^a", message_count,mseg_dir,mseg_name); else call ioa_("You have ^d carry requests in ^a>^a",message_count,mseg_dir,mseg_name); CLOSE: call message_segment_$close(mseg_index,code); end carry_total;  enter_carry_request.pl1 02/19/85 1023.6r 02/14/85 0740.1 264060 /* ************************************************************ * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright, (C) Honeywell Information Systems Inc., 1980. * * * ************************************************************ */ enter_carry_request: ecr: proc; /* This module implements the commands: enter_carry_request, ecr list_carry_requests, lcr cancel_carry_requests, ccr Usage: enter_carry_request paths {-control_args} where the -new_dir PATH control argument causes the entry named by the preceding path argument to be reloaded under PATH instead. -notify sends the requestor mail when the request is dumped. list_carry_requests {-control_args} cancel_carry_request paths {-control_args} The last two accept the -admin (-am) control argument, allowing them to list or cancel any user's requests (the default is their own) if the user has r access to the carry queue. All the commands accept: -destination DEST, -ds DEST where DEST is up to 23 characters long, naming the queue DEST.carry.ms instead of the default queue carry.ms, the name added to the queue for the default destination. -queue_dir PATH, -qd PATH looks in the specified directory for the queue, rather than in >daemon_dir_dir>carry_dir. Steve Herbst 07/26/78 */ /* -notify added 04/18/79 S. Herbst */ /* -trim added, bugs fixed 08/03/79 S. Herbst */ /* MCR 4297 -user added 01/09/80 S. Herbst */ /* Add -entry for ccr, * conv for lcr & ccr, and clean up access forcing and messages 08/14/80 S. Herbst */ /* Add star convention to ecr 12/15/80 S. Herbst */ /* Fixed for "new" error code from hcs_$star_, 1/6/85 Keith Loepere. */ dcl default_destination char (23) int static init ("default destination"); dcl (default_queue_dir, mseg_dir) char (168) init (">daemon_dir_dir>carry_dir"); dcl mseg_name char (32) init ("carry.ms"); dcl 1 entries (ecount) aligned based (entries_ptr), 2 entry_type bit (2) unaligned, 2 nnames fixed bin (15) unaligned, 2 nindex fixed bin unaligned; dcl names (99 /* unlimited */) char (32) based (names_ptr); dcl arg char (arg_len) based (arg_ptr); dcl line char (line_len) based (line_ptr); dcl request char (500); dcl move_line char (200); dcl (request_dir) char (168); dcl answer char (32) varying; dcl (group_id, new_user, request_name, ME) char (32); dcl admin (acl_count) char (32) based (admin_ptr); dcl atime char (24); dcl destination char (23) init ("default destination"); dcl type_string char (7); dcl (admin_mode, all_queues, cancelling, ds_sw, expecting_ds, expecting_path) bit (1) aligned init ("0"b); dcl (hold_sw, listing, trim_sw) bit (1) aligned init ("0"b); dcl (first, header_printed, no_access, notify_sw, queried_once, warn_hdr_printed) bit (1) aligned; dcl (SEG init ("0"b), DIR init ("1"b)) bit (1) aligned int static options (constant); dcl SEG_TYPE bit (2) int static options (constant) init ("01"b); dcl ADROS_ACCESS bit (5) aligned int static options (constant) init ("11111"b); dcl request_id bit (36); dcl area area based (area_ptr); dcl (acl_ptr, admin_ptr, line_ptr) ptr init (null); dcl (arg_ptr, area_ptr, entries_ptr, names_ptr) ptr; dcl time fixed bin (71); dcl (mode, (R_ACCESS init (8), S_ACCESS init (8), SMA_ACCESS init (11)) int static options (constant)) fixed bin (5); dcl ALL_ENTRIES fixed bin (2) int static options (constant) init (3); dcl (type, (seg_type init (1), dir_type init (2)) int static) fixed bin (2); dcl (op, ecr_op init (1), lcr_op init (2), ccr_op init (3)) fixed bin; dcl (acl_count, admin_count, arg_count, arg_len, ds_count, ecount, ej, name_len) fixed bin; dcl (i, j, k, level, line_len, request_count, request_len, saved_line_len, walk_level) fixed bin; dcl mseg_index fixed bin init (0); dcl (code, code1) fixed bin (35); dcl error_table_$badopt fixed bin (35) ext; dcl error_table_$badstar fixed bin (35) ext; dcl error_table_$incorrect_access fixed bin (35) ext; dcl error_table_$moderr fixed bin (35) ext; dcl error_table_$no_message fixed bin (35) ext; dcl error_table_$no_s_permission fixed bin (35) ext; dcl error_table_$nomatch fixed bin (35) ext; dcl error_table_$nostars fixed bin (35) ext; dcl 1 request_array (arg_count) based (request_array_ptr), 2 dn char (168), 2 en char (32), 2 star_sw bit (1), 2 matched bit (1); dcl new_dir (arg_count) char (168) based (new_dir_ptr); dcl (request_array_ptr, new_dir_ptr) ptr init (null); dcl 1 segment_acl aligned, /* for forcing access */ 2 access_name char (32) unaligned, 2 modes bit (36), 2 pad bit (72); dcl 1 acl (acl_count) aligned based (acl_ptr), 2 user_id char (32), 2 mode bit (36), 2 exmode bit (36), 2 status_code fixed bin (35); %include query_info; %include branch_status; %include mseg_return_args; dcl 1 mseg_args like mseg_return_args; dcl iox_$error_output ptr ext; dcl absolute_pathname_ entry (char (*), char (*), fixed bin (35)); dcl check_star_name_$entry entry (char (*), fixed bin (35)); dcl check_star_name_$path entry (char (*), fixed bin (35)); dcl (com_err_, com_err_$suppress_name) entry options (variable); dcl command_query_ entry options (variable); 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 (fixed bin); dcl date_time_ entry (fixed bin (71), char (*)); dcl expand_path_ entry (ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_system_free_area_ entry returns (ptr); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, 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_long entry (char (*), char (*), fixed bin (1), 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 (ioa_, ioa_$ioa_switch, ioa_$ioa_switch_nnl, ioa_$rs, ioa_$rsnnl) entry options (variable); dcl match_star_name_ entry (char (*), char (*), fixed bin (35)); dcl message_segment_$add_index entry (fixed bin, ptr, fixed bin, bit (72), fixed bin (35)); dcl message_segment_$close entry (fixed bin, fixed bin (35)); dcl message_segment_$delete_index entry (fixed bin, bit (72), fixed bin (35)); dcl message_segment_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72), ptr, fixed bin (35)); dcl message_segment_$ms_acl_list entry (char (*), char (*), ptr, fixed bin, ptr, fixed bin (35)); dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35)); dcl message_segment_$own_incremental_read_index entry (fixed bin, ptr, bit (2), bit (72), ptr, fixed bin (35)); dcl message_segment_$own_read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35)); dcl message_segment_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35)); dcl (addr, addrel, after, before, divide, fixed, index, length, null, ptr, rtrim, substr, unspec) builtin; dcl cleanup condition; %page; /* enter_carry_request: ecr: proc; */ ME = "enter_carry_request"; op = ecr_op; notify_sw = "0"b; go to COMMON; list_carry_requests: lcr: entry; ME = "list_carry_requests"; op = lcr_op; listing = "1"b; go to COMMON; cancel_carry_request: ccr: entry; ME = "cancel_carry_request"; op = ccr_op; listing, cancelling = "1"b; COMMON: call cu_$arg_count (arg_count); if arg_count = 0 & op ^= lcr_op then do; USAGE: call com_err_$suppress_name (0, ME, "Usage: ^a ^[paths ^]{-control_args}", ME, op ^= lcr_op); return; end; area_ptr = get_system_free_area_ (); entries_ptr, names_ptr = null; on condition (cleanup) call clean_up; allocate request_array in (area) set (request_array_ptr); allocate new_dir in (area) set (new_dir_ptr); ds_count, request_count = 0; ds_sw = "0"b; new_user = ""; do i = 1 to arg_count; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if substr (arg, 1, 1) ^= "-" then do; /* pathname */ if op = lcr_op then go to USAGE; request_count = request_count+1; call expand_pathname_ (arg, dn (request_count), en (request_count), code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); go to RETURN; end; call check_star_name_$entry (en (request_count), code); if (code = 1 | code = 2) then star_sw (request_count) = "1"b; /* valid starname */ else if code ^= 0 then do; BAD_STARNAME: call com_err_ (code, ME, "^a", en (request_count)); go to RETURN; end; else star_sw (request_count) = "0"b; matched (request_count) = "0"b; new_dir (request_count) = ""; end; else if arg = "-destination" | arg = "-ds" then do; i = i+1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, ME, "-destination value missing."); go to RETURN; end; ds_sw = "1"b; destination = arg; mseg_name = arg || ".carry.ms"; call hcs_$status_minf (mseg_dir, mseg_name, 1, (0), (0), code); if code ^= 0 & code ^= error_table_$no_s_permission then do; call com_err_ (0, ME, "Invalid destination ^a", arg); go to RETURN; end; end; else if arg = "-entry" | arg = "-et" then do; if op ^= ccr_op then go to BADOPT; i = i + 1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, ME, "No value specified for -entry"); go to RETURN; end; call check_star_name_$entry (arg, code); if (code = 1 | code = 2) then star_sw (request_count) = "1"b; else if code ^= 0 then go to BAD_STARNAME; else star_sw (request_count) = "0"b; request_count = request_count + 1; dn (request_count) = ""; en (request_count) = arg; matched (request_count) = "0"b; new_dir (request_count) = ""; end; else if arg = "-queue_dir" | arg = "-qd" then do; i = i+1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, ME, "No value specified for -queue_dir"); go to RETURN; end; call absolute_pathname_ (arg, mseg_dir, code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); go to RETURN; end; default_destination = "default destination"; /* have to recompute */ end; else if arg = "-admin" | arg = "-am" then if op = ecr_op then go to BADOPT; else admin_mode = "1"b; else if arg = "-all" | arg = "-a" then do; if op ^= lcr_op then go to BADOPT; all_queues = "1"b; end; else if op ^= ecr_op then go to BADOPT; /* the rest are for ecr */ else if arg = "-hold" | arg = "-hd" then hold_sw = "1"b; else if arg = "-trim" then trim_sw = "1"b; else if arg = "-no_trim" | arg = "-notrim" then trim_sw = "0"b; else if arg = "-notify" | arg = "-nt" then notify_sw = "1"b; else if arg = "-no_notify" | arg = "-nnt" then notify_sw = "0"b; else if arg = "-new_dir" | arg = "-nd" then do; if request_count = 0 then do; call com_err_ (0, ME, "No path preceding ^a.", arg); go to RETURN; end; i = i+1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, ME, "No value specified for -new_dir"); go to RETURN; end; if arg = "" then do; call com_err_ (0, ME, "Invalid -new_dir argument """"."); go to RETURN; end; call absolute_pathname_ (arg, new_dir (request_count), code); if code ^= 0 then do; call com_err_ (code, ME, "^a", arg); go to RETURN; end; call check_star_name_$path (new_dir (request_count), code); if code ^= 0 then do; /* bad syntax, equal or starname */ call com_err_ (error_table_$badstar, ME, "^a", new_dir (request_count)); go to RETURN; end; end; else if arg = "-user" then do; i = i+1; call cu_$arg_ptr (i, arg_ptr, arg_len, code); if code ^= 0 then do; call com_err_ (0, ME, "No value specified for -user"); go to RETURN; end; new_user = arg; j = index (new_user, "."); if j = 0 then do; call com_err_ (0, ME, "-user argument not of the form Person.Project"); go to RETURN; end; k = index (substr (new_user, j + 1), "."); if k ^= 0 then new_user = substr (new_user, 1, j + k - 1); end; else do; BADOPT: call com_err_ (error_table_$badopt, ME, "^a", arg); go to RETURN; end; end; if all_queues & ds_sw & op = lcr_op then do; call com_err_ (0, ME, "Incompatible control arguments -all and -ds"); go to RETURN; end; if ^ds_sw then destination = default_destination; if request_count = 0 & (^listing | cancelling) then do; call com_err_ (0, ME, "No pathnames specified."); go to RETURN; end; if op = ecr_op then go to ENTER_REQUESTS; header_printed = "0"b; if ^all_queues then do; if destination = "default destination" then call get_default_destination (mseg_dir, mseg_name); call list_queue (mseg_dir, mseg_name); end; else do; call hcs_$star_ (mseg_dir, "**.carry.ms", 2 /* segs */, area_ptr, ecount, entries_ptr, names_ptr, code); if code ^= 0 then do; call com_err_ (code, ME, "^a^[>^]**.carry.ms", mseg_dir, mseg_dir ^= ">"); go to RETURN; end; do ej = 1 to ecount; if entries (ej).entry_type = SEG_TYPE then do; mseg_name = names_ptr -> names (entries_ptr -> entries (ej).nindex); call get_destination (mseg_dir, mseg_name); call list_queue (mseg_dir, mseg_name); end; end; end; go to RETURN; %page; ENTER_REQUESTS: call message_segment_$open (mseg_dir, mseg_name, mseg_index, code); if mseg_index = 0 then do; call com_err_ (code, ME, "^a^[>^]^a", mseg_dir, mseg_dir ^= ">", mseg_name); go to RETURN; end; call cu_$level_get (level); group_id = get_group_id_$tag_star (); call get_administrators; do i = 1 to request_count; if star_sw (i) then call enter_stars (dn (i), en (i)); else call enter_one (dn (i), en (i)); END: end; RETURN: call clean_up; return; %page; enter_one: proc (P_dn, P_en); dcl (P_dn, P_en) char (*); dcl j fixed bin; do j = 1 to admin_count; mode = 0; call hcs_$get_user_effmode (P_dn, "", admin (j), level, mode, code); if code ^= 0 | mode < S_ACCESS then do; if code = error_table_$incorrect_access then call ioa_$ioa_switch (iox_$error_output, "Warning: Unable to check access on ^a", dn (j)); else call ioa_$ioa_switch (iox_$error_output, "Warning: ^a lacks s access to ^a", admin (j), dn (j)); end; end; no_access, warn_hdr_printed = "0"b; walk_level = 0; queried_once = "0"b; /* about forcing access for this request */ call carry_access (P_dn, P_en, type); if no_access then do; call com_err_$suppress_name (0, "enter_carry_request", "Request ^a^[>^]^a not queued.", P_dn, P_dn ^= ">", P_en); go to END; end; if type = dir_type then type_string = "Subtree"; else type_string = "Segment"; call ioa_$rs ("^a ^a^[>^]^a^[ -user ^a^;^s^]^[ -trim^]^[ -new_dir ^a^;^s^]^[ -notify^]^[ -hold^]", request, request_len, type_string, P_dn, P_dn ^= ">", P_en, new_user ^= "", new_user, trim_sw, new_dir (i) ^= "", new_dir (i), notify_sw, hold_sw); call message_segment_$add_index (mseg_index, addr (request), request_len*9, (mseg_args.ms_id), code); if code ^= 0 then do; call com_err_ (code, ME, "^a>^a", mseg_dir, mseg_name); go to RETURN; end; end enter_one; %page; enter_stars: proc (P_dn, P_starname); dcl (P_dn, P_starname) char (*); dcl 1 entries (entry_count) based (entries_ptr), 2 pad bit (18) unaligned, 2 nindex bit (18) unaligned; dcl names (999) char (32) aligned based (names_ptr); dcl en char (32); dcl area area based (area_ptr); dcl (area_ptr, entries_ptr, names_ptr) ptr; dcl (entry_count, j) fixed bin; area_ptr = get_system_free_area_ (); entries_ptr, names_ptr = null; on cleanup call star_cleanup; call hcs_$star_ (P_dn, P_starname, ALL_ENTRIES, area_ptr, entry_count, entries_ptr, names_ptr, code); if code ^= 0 then do; call com_err_ (code, ME, "^a^[>^]^a", P_dn, P_dn ^= ">", P_starname); return; end; do j = 1 to entry_count; en = names_ptr -> names (fixed (entries_ptr -> entries (j).nindex)); call enter_one (P_dn, en); end; call star_cleanup; return; star_cleanup: proc; if entries_ptr ^= null then free entries in (area); if names_ptr ^= null then free names in (area); end star_cleanup; end enter_stars; %page; list_queue: proc (P_dn, P_en); /* Lists requests in a single queue */ dcl (P_dn, P_en) char (*); call message_segment_$open (P_dn, P_en, mseg_index, code); if mseg_index = 0 then do; call com_err_ (code, ME, "^a>^a", P_dn, P_en); return; end; first = "1"b; LOOP: if first then do; first = "0"b; if admin_mode then call message_segment_$read_index (mseg_index, area_ptr, "0"b, addr (mseg_args), code); else call message_segment_$own_read_index (mseg_index, area_ptr, "0"b, addr (mseg_args), code); if code ^= 0 then do; if code = error_table_$no_message then if admin_mode then call ioa_ ("Queue ^a is empty.", queue_name (P_dn, P_en)); else call ioa_ ("You have no requests in queue ^a", queue_name (P_dn, P_en)); else call com_err_ (code, ME, "^a>^a", P_dn, P_en); QUEUE_RETURN: call message_segment_$close (mseg_index, code); return; end; if admin_mode & ^cancelling & ^header_printed then do; call ioa_ ("DATE ENTERED^6xSENDER^26xTYPE^4xPATHNAME"); header_printed = "1"b; end; end; else do; if admin_mode then call message_segment_$incremental_read_index (mseg_index, area_ptr, "01"b, mseg_args.ms_id, addr (mseg_args), code); else call message_segment_$own_incremental_read_index (mseg_index, area_ptr, "01"b, mseg_args.ms_id, addr (mseg_args), code); if code ^= 0 then do; if code = error_table_$no_message then do; if cancelling then do i = 1 to request_count; if ^matched (i) then call com_err_ (0, ME, "^a^[>^]^a not found in queue ^a", dn (i), dn (i) ^= "", en (i), queue_name (P_dn, P_en)); end; if admin_mode then call ioa_ (""); end; else call com_err_ (code, ME, "^a>^a", P_dn, P_en); go to QUEUE_RETURN; end; end; line_ptr = mseg_args.ms_ptr; line_len, saved_line_len = divide (mseg_args.ms_len, 9, 17, 0)-1; if ^cancelling /* listing */ & request_count = 0 then go to LIST; i = index (line, " -") - 1; if i > 0 then line_len = i; call expand_path_ (addrel (line_ptr, 2), line_len-8, addr (request_dir), addr (request_name), code); name_len = length (rtrim (request_name)); do i = 1 to request_count; if dn (i) = request_dir | dn (i) = "" /* -entry */ then do; call match_star_name_ (request_name, en (i), code); if code = 0 then do; PROCESS: if cancelling then do; matched (i) = "1"b; /* found a match for this argument */ call message_segment_$delete_index (mseg_index, mseg_args.ms_id, code); if code ^= 0 then call com_err_ (code, ME, "Unable to delete ^a^[>^]^a from queue ^a", request_dir, request_dir ^= ">", request_name, queue_name (P_dn, P_en)); else do; call ioa_ ("Carry of ^a>^a to ^a cancelled.", request_dir, request_name, destination); end; go to NEXT; end; else do; LIST: line_len = saved_line_len; unspec (time) = mseg_args.ms_id; call date_time_ (time, atime); i = index (line, " -new_dir"); if i ^= 0 then do; move_line = substr (line, i + 1); line_len = i - 1; end; else move_line = ""; if admin_mode then call ioa_ ("^16a ^32a^a^[ (destination ^a)^]", substr (atime, 1, 16), mseg_args.sender_id, line, all_queues, destination); else call ioa_ ("^16a ^a^[ (destination ^a)^]", substr (atime, 1, 16), line, all_queues, destination); if move_line ^= "" then call ioa_ ("^10x^a", move_line); go to NEXT; end; end; end; /* If pathnames differ but entrynames are the same, compare unique id's */ else if en (i) = request_name then do; call hcs_$status_long (request_dir, request_name, 1, addr (branch_status), null, code); if code = 0 then do; request_id = branch_status.unique_id; call hcs_$status_long (dn (i), en (i), 1, addr (branch_status), null, code); if code = 0 & branch_status.unique_id = request_id then go to PROCESS; end; end; end; NEXT: free line in (area); go to LOOP; end list_queue; %page; clean_up: proc; if mseg_index ^= 0 then call message_segment_$close (mseg_index, code); if line_ptr ^= null then free line in (area); if request_array_ptr ^= null then free request_array in (area); if new_dir_ptr ^= null then free new_dir in (area); if acl_ptr ^= null then free acl in (area); if admin_ptr ^= null then free admin in (area); if entries_ptr ^= null then free entries in (area); if names_ptr ^= null then free names in (area); if mseg_dir ^= default_queue_dir then default_destination = "default destination"; /* restore */ end clean_up; %page; carry_access: proc (access_dn, access_en, a_type); dcl access_dn char (*); dcl access_en char (*); dcl (a_type, type) fixed bin (2); dcl dir_path char (168); dcl (entries_ptr, names_ptr) ptr init (null); dcl (ecount, ej) fixed bin; dcl 1 entries (ecount) aligned based (entries_ptr), 2 entry_type bit (2) unaligned, 2 nnames fixed bin (15) unaligned, 2 nindex fixed bin unaligned; dcl names (99) char (32) based (names_ptr); walk_level = walk_level + 1; on condition (cleanup) begin; if entries_ptr ^= null then free entries in (area); if names_ptr ^= null then free names in (area); end; call hcs_$status_minf (access_dn, access_en, 1, a_type, (0), code); if code ^= 0 then do; no_access = "1"b; call com_err_ (code, ME, "^a>^a", access_dn, access_en); warn_hdr_printed = "0"b; return; end; if a_type = seg_type then do; call hcs_$get_user_effmode (access_dn, access_en, group_id, level, mode, code); if code ^= 0 | mode 1 then call warn; else do; no_access = "1"b; if code = error_table_$incorrect_access then do; NO_S: call com_err_ (code, ME, "^/Unable to check access to ^a>^a", access_dn, access_en); warn_hdr_printed = "0"b; return; end; call com_err_ (0, ME, "You need r access to ^a>^a", access_dn, access_en); warn_hdr_printed = "0"b; return; end; end; end; do j = 1 to admin_count; call hcs_$get_user_effmode (access_dn, access_en, admin (j), level, mode, code); if code ^= 0 | mode 1 then call warn; else do; no_access = "1"b; call com_err_ (0, ME, "^a needs r access to ^a>^a", admin (j), access_dn, access_en); warn_hdr_printed = "0"b; return; end; end; end; end; end; else do; /* directory */ do j = 1 to admin_count; call hcs_$get_user_effmode (access_dn, access_en, admin (j), level, mode, code); if code ^= 0 | mode 1 then call warn; else do; no_access = "1"b; if code = error_table_$incorrect_access then go to NO_S; call com_err_ (0, ME, "^a needs sma access to ^a>^a", admin (j), access_dn, access_en); warn_hdr_printed = "0"b; return; end; end; end; end; call ioa_$rsnnl ("^a>^a", dir_path, (168), access_dn, access_en); STAR: call hcs_$star_ (dir_path, "**", 2, area_ptr, ecount, entries_ptr, names_ptr, code); if code ^= 0 then if code = error_table_$nomatch then do; if walk_level = 1 then no_access = "1"b; /* request is not queued */ return; end; else do; if ^force_access (group_id, DIR) then do; if walk_level > 1 then call warn; else do; no_access = "1"b; if code = error_table_$moderr then code = 0; call com_err_ (code, ME, "^[You need sma access to ^]^a^[>^]^a", code = 0, access_dn, access_dn ^= ">", access_en); warn_hdr_printed = "0"b; return; end; end; else go to STAR; end; do ej = 1 to ecount; call carry_access (dir_path, names (nindex (ej)), type); if no_access then do; free entries in (area); free names in (area); return; end; end; free entries in (area); free names in (area); end; force_access: proc (a_id, a_sw) returns (bit (1)); dcl a_id char (32); dcl a_sw bit (1) aligned; if ^queried_once then do; queried_once = "1"b; query_info.version = query_info_version_4; query_info.yes_or_no_sw = "1"b; call command_query_ (addr (query_info), answer, "enter_carry_request", "Do you want to force access to Carry and/or yourself?"); if answer ^= "yes" then go to CA_RETURN; end; segment_acl.access_name = a_id; if a_sw = DIR then segment_acl.modes = "111"b; /* sma */ else segment_acl.modes = "100"b; /* r */ if a_sw = DIR then call hcs_$add_dir_acl_entries (access_dn, access_en, addr (segment_acl), 1, code1); else call hcs_$add_acl_entries (access_dn, access_en, addr (segment_acl), 1, code1); if code1 ^= 0 then return ("0"b); return ("1"b); end force_access; warn: proc; if code = 0 then do; if ^warn_hdr_printed then do; warn_hdr_printed = "1"b; call ioa_$ioa_switch (iox_$error_output, "Warning: Entries in subtree will be omitted due to lack of access:^/^5x^a>^a", access_dn, access_en); end; else call ioa_$ioa_switch (iox_$error_output, "^5x^a>^a", access_dn, access_en); go to CA_RETURN; end; warn_hdr_printed = "0"b; call ioa_$ioa_switch_nnl (iox_$error_output, "Warning: "); call com_err_$suppress_name (code, ME, "Entry in subtree will be omitted: ^a>^a", access_dn, access_en); go to CA_RETURN; end warn; CA_RETURN: return; end carry_access; %page; queue_name: proc (P_dn, P_en) returns (char (168)); dcl (P_dn, P_en) char (*); dcl path char (168); /* returns "for destination STR" if queue is in the default dir, else pathname */ if mseg_dir = default_queue_dir then do; if destination = "default destination" then call get_default_destination (mseg_dir, mseg_name); if destination = "" | destination = "default destination" then return ("for default destination"); else return ("for destination " || destination); end; call ioa_$rsnnl ("^a^[>^]^a", path, length (path), P_dn, P_dn ^= ">", P_en); return (path); end queue_name; %page; get_default_destination: proc (P_dn, P_en); /* Sets the default destination by calling get_destination */ dcl (P_dn, P_en) char (*); if default_destination ^= "default destination" then do; /* if already set, just return it */ destination = default_destination; return; end; call get_destination (P_dn, "carry.ms"); default_destination = destination; end get_default_destination; %page; get_destination: proc (P_dn, P_en); /* Determines the destination name from the prefixed entryname of the queue */ dcl (P_dn, P_en) char (*); dcl (i, j, names_count) fixed bin; dcl names_ptr ptr; dcl names (names_count) char (32) based (names_ptr); call hcs_$status_long (P_dn, P_en, 1, addr (branch_status), area_ptr, code); if code ^= 0 then do; NO_DS: destination = "unknown destination"; return; end; names_ptr = ptr (area_ptr, branch_status.names_rel_pointer); names_count = fixed (branch_status.number_names); do j = 1 to names_count; if after (names (j), ".") = "carry.ms" then do; /* DEST.carry.ms */ destination = before (names (j), "."); free names in (area); return; end; end; free names in (area); go to NO_DS; end get_destination; %page; get_administrators: proc; /* This internal procedure enumerates users having "adros" extended access to the carry queue. */ dcl i fixed bin; acl_count = -1; call message_segment_$ms_acl_list (mseg_dir, mseg_name, acl_ptr, acl_count, area_ptr, code); allocate admin in (area) set (admin_ptr); admin_count = 0; do i = 1 to acl_count; if substr (acl.exmode (i), 1, 5) = ADROS_ACCESS then do; admin_count = admin_count+1; admin (admin_count) = acl.user_id (i); end; end; end get_administrators; end enter_carry_request; 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