1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 /****^  HISTORY COMMENTS:
 15   1) change(86-11-17,GWMay), approve(86-11-17,MCR7445), audit(86-11-20,GDixon),
 16      install(86-11-21,MR12.0-1223):
 17      added entrypoint "test" for debugging the retriever from a user process
 18      without changes to the system volume retriever queues.
 19   2) change(88-08-10,GWMay), approve(88-10-05,MCR8005), audit(88-10-12,Farley),
 20      install(88-10-17,MR12.2-1173):
 21      Added administrative support for two additional temporary work segments.
 22                                                    END HISTORY COMMENTS */
 23 
 24 
 25 /* format: style1,ind2,^inddcls,ifthenstmt,dclind2,declareind2,ifthendo,ifthen*/
 26 
 27 retriever: retrieve_from_volume: retv: proc;
 28 
 29 /* This is the main control routine of the volume retriever subsystem. It initializes the
 30    static control structure, parses the arguments, and controls which requests are processed. It uses two
 31    other routines, retv_vol_control_, to determine which dump volumes a request may be recovered from
 32    and retrieve_from_volume_, to recover objects from a specified dump volume. The major data bases created by
 33    this subsystem are in the process directory or in external static and are initialize/created for each invocation.
 34 */
 35 
 36 /* Modified 6/79 by D. Vinograd to correct notification bug, add accounting control argument ,
 37    add directory name space searching option, and xxx
 38    Modified: 12/18/81 by GA Texada to correct a bug in cross-retrieval (phx12113)
 39    Modified: 09/03/82 by GA Texada to fix a bug in scan_sub_tree ^H^Hwhen it calls submit_request.
 40    Modified: 3/83 by E. N. Kittlitz for 256K segments.
 41    Modified: 8/83 by GA Texada to make the "list" request go thru all the q's.
 42    Modified: 5/15/85 by GA Texada to ensure that retv_data_.qidx(X) is zeroed after calling message_segment_$delete
 43 */
 44 
 45 dcl wdir                 char (168);
 46 dcl short                char (8) aligned;
 47 dcl ac                   fixed bin;
 48 dcl options_string       char (256);
 49 dcl osl                  fixed bin;
 50 dcl narg                 fixed bin;
 51 dcl answer               char (3) var;
 52 dcl long                 char (100) aligned;
 53 dcl message              char (256);
 54 dcl message_len          fixed bin;
 55 dcl line                 char (32);
 56 dcl tp                   (9) ptr;
 57 dcl nelemt               fixed bin (21);
 58 dcl rvcx                 fixed bin;
 59 dcl sorty                fixed bin;
 60 dcl sortx                fixed bin;
 61 dcl nvolx                fixed bin;
 62 dcl q                    fixed bin;
 63 dcl qx                   fixed bin;
 64 dcl to_from              bit (1);
 65 dcl retv_ms_id           bit (72) aligned;
 66 dcl more_messages        bit (1);
 67 dcl more_to_do           bit (1);
 68 dcl dtm                  bit (36);
 69 dcl queue_name           char (32);
 70 dcl step                 bit (1);
 71 dcl list                 bit (1);
 72 dcl code                 fixed bin (35);
 73 dcl type                 fixed bin;
 74 dcl ignore               fixed bin (35);
 75 dcl arg                  char (argl) based (argp);
 76 dcl argl                 fixed bin;
 77 dcl argp                 ptr;
 78 dcl old_256K_switch      bit (2) aligned;
 79 
 80 dcl based_area           area based (retv_data_.areap);
 81 
 82 dcl LINK                 fixed bin static init (3) options (constant);
 83 dcl DIR                  fixed bin int static init (2) options (constant);
 84 dcl recursive_invocation bit (1) aligned int static init ("0"b);
 85 dcl myname               char (32) int static init ("retrieve_from_volume") options (constant);
 86 dcl max_q_num            fixed bin static init (3) options (constant);
 87 
 88 dcl 1 local_mseg_return_args like mseg_return_args aligned;
 89 dcl 1 local_retv_input   like retv_input aligned;
 90 
 91 dcl error_table_$noentry ext fixed bin (35);
 92 dcl error_table_$resource_unavailable ext fixed bin (35);
 93 dcl error_table_$badopt  fixed bin (35) ext;
 94 dcl error_table_$vtoce_connection_fail ext fixed bin (35);
 95 dcl error_table_$bad_segment ext fixed bin (35);
 96 dcl error_table_$no_message ext fixed bin (35);
 97 dcl sys_info$seg_size_256K fixed bin (19) ext static;
 98 dcl sys_info$max_seg_size fixed bin (18) ext static;
 99 
100 dcl retv_vol_control_$sort entry (ptr, fixed bin (35));
101 dcl retv_notify_         entry (char (*), ptr, char (*));
102 dcl request_id_          entry (fixed bin (71)) returns (char (19));
103 dcl get_wdir_            entry returns (char (168));
104 dcl retv_report_$error_output entry options (variable);
105 dcl retv_report_$online_output entry options (variable);
106 dcl message_segment_$close entry (fixed bin, fixed bin (35));
107 dcl message_segment_$open entry (char (*), char (*), fixed bin, fixed bin (35));
108 dcl message_segment_$delete entry (char (*), char (*), fixed bin (35));
109 dcl message_segment_$delete_index entry (fixed bin, bit (72) aligned, fixed bin (35));
110 dcl command_query_       entry options (variable);
111 dcl system_privilege_$ring1_priv_on entry (fixed bin (35));
112 dcl system_privilege_$ring1_priv_off entry (fixed bin (35));
113 dcl system_privilege_$ipc_priv_on entry (fixed bin (35));
114 dcl system_privilege_$ipc_priv_off entry (fixed bin (35));
115 dcl retv_account_$create entry (fixed bin (35));
116 dcl retv_account_$update entry (char (*) aligned);
117 dcl hc_backup_$retv_name_list entry (char (*) aligned, ptr, ptr, fixed bin, fixed bin (35));
118 dcl hc_backup_$retv_check entry (char (*) aligned, char (*) aligned, fixed bin, bit (36), fixed bin (35));
119 dcl convert_status_code_ entry (fixed bin (35), char (8) aligned, char (100) aligned);
120 dcl hcs_$delentry_seg    entry (ptr, fixed bin (35));
121 dcl hcs_$set_256K_switch entry (bit (2) aligned, bit (2) aligned, fixed bin (35));
122 dcl hcs_$set_max_length_seg entry (ptr, fixed bin (19), fixed bin (35));
123 dcl hcs_$truncate_seg    entry (ptr, fixed bin (19), fixed bin (35));
124 dcl date_time_           entry (fixed bin (71), char (*));
125 dcl get_system_free_area_ entry returns (ptr);
126 dcl get_temp_segments_   entry (char (*), (*) ptr, fixed bin (35));
127 dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35));
128 dcl cu_$arg_count        entry (fixed bin);
129 dcl cu_$arg_ptr          entry (fixed bin, ptr, fixed bin, fixed bin (35));
130 dcl com_err_             entry options (variable);
131 dcl ioa_$rsnnl           entry options (variable);
132 dcl ioa_                 entry options (variable);
133 dcl cv_oct_check_        entry (char (*), fixed bin (35)) returns (fixed bin);
134 dcl ioa_$nnl             entry options (variable);
135 dcl message_segment_$create entry (char (*), char (*), fixed bin (35));
136 dcl message_segment_$add_index entry (fixed bin, ptr, fixed bin, bit (72) aligned, fixed bin (35));
137 dcl message_segment_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
138 dcl retrieve_from_volume_ entry (ptr, fixed bin (35));
139 dcl retv_vol_control_    entry (ptr, fixed bin (35));
140 dcl message_segment_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72) aligned, ptr,
141                          fixed bin (35));
142 dcl message_segment_$update_message_index entry (fixed bin, fixed bin, bit (72) aligned, ptr, fixed bin (35));
143 
144 dcl cleanup              condition;
145 dcl linkage_error        condition;
146 
147 dcl (fixed, hbound, before) builtin;
148 dcl addr                 builtin;
149 dcl size                 builtin;
150 dcl unspec               builtin;
151 dcl length               builtin;
152 dcl null                 builtin;
153 dcl substr               builtin;
154 ^L
155 main: goto common;
156 
157 test: entry (test_dir);
158 
159 /*  This entry point is the counter part to the test entry point in the     */
160 /*  enter_retrieval_request (err) command program.  It is designed for use  */
161 /*  in testing the volume dumper/retriever.  To use it type                 */
162 /*  "retrieve_from_volume$test wdir"  where wdir is the directory where you */
163 /*  have created private message_segments named volume_retiever.ms and      */
164 /*  volume_retiever(1 2 3).ms for use as the retriever queues.              */
165 /*  Type "err$test wdir" before entering the retrieval request giving the   */
166 /*  same directory which contains the queue.                                */
167 
168 dcl test_dir             char (*);
169     queue_dir = test_dir;
170     return;
171 
172 common:
173                                                             /* protect against recursive invocation */
174     if recursive_invocation then do;
175         call com_err_ (0, myname, "Recursive invocation not allowed ");
176         return;
177       end;
178                                                             /* initialize static variables */
179     old_256K_switch = ""b;
180     tp (*) = null;
181     retv_data_.ptrs = null;
182     retv_data_.chars = "";
183     retv_data_.bits = ""b;
184     retv_data_.sys_dir = ">daemon_dir_dir>volume_backup";
185     retv_data_.fixed = 0;
186     retv_data_.all = "1"b;
187     retv_data_.io_module = "tape_mult_";
188                                                             /* and some local variables */
189     ms_arg_ptr = addr (local_mseg_return_args);
190     q = 1;
191     list = "0"b;
192     wdir = get_wdir_ ();
193     step = "0"b;
194                                                             /* initialize mail structure */
195                                                             /* process arguments */
196     inputp, requestp = null;
197     ac = 1;
198     call cu_$arg_count (narg);
199     do while (ac <= narg);
200       call cu_$arg_ptr (ac, argp, argl, code);
201       if code ^= 0 then do;
202 no_arg:   call retv_report_$error_output (code, myname, "Unable to access arg after ^a", arg);
203           goto finale;
204         end;
205       ac = ac + 1;
206       if arg = "-step" then step = "1"b;
207       else if arg = "-manual" then retv_data_.manual = "1"b;
208       else if arg = "-long" then retv_data_.long = "1"b;
209       else if arg = "-working_dir" | arg = "-wd" then retv_data_.sys_dir = wdir;
210       else if arg = "-accounting" then retv_data_.accounting = "1"b;
211       else if arg = "-all" | arg = "-a" then ;
212       else if arg = "-error_on" then retv_data_.err_online = "1"b;
213       else if arg = "-list" then list = "1"b;
214       else if arg = "-input_volume_desc" then do;
215           call cu_$arg_ptr (ac, argp, argl, code);
216           if code ^= 0 then goto no_arg;
217           ac = ac + 1;
218           retv_data_.input_volume_desc = arg;
219           retv_data_.io_module = before (arg, " ");
220         end;
221       else if arg = "-q" | arg = "-queue" then do;
222           retv_data_.all = "0"b;
223           call cu_$arg_ptr (ac, argp, argl, code);
224           if code ^= 0 then goto no_arg;
225           ac = ac + 1;
226           q = cv_oct_check_ (arg, code);
227           if code ^= 0 | (q < 1 | q > 3) then do;
228               call retv_report_$error_output (0, myname,
229                    "Invalid queue number ^a", arg);
230               goto finale;
231             end;
232         end;
233       else do;
234           call retv_report_$error_output (error_table_$badopt, myname, "^a", arg);
235           goto finale;
236         end;
237     end;
238     retv_data_.queue = q;
239     on cleanup call clean_it_up;
240     recursive_invocation = "1"b;
241 start:
242     call message_segment_$open (queue_dir, queue_seg_ (), retv_data_.qidx (user), code);
243     if code ^= 0 then do;
244         call retv_report_$error_output (code, myname, "Unable to open user queue ^a>^a", queue_dir, queue_seg_ ());
245         goto finish;
246       end;
247 
248     call message_segment_$open (wdir, "volume_retriever.ms", retv_data_.qidx (retriever), code);
249     if code ^= 0 & code ^= error_table_$noentry then do;
250         call retv_report_$error_output (code, myname, "Unable to open private queue ^a>volume_retriever.ms", wdir);
251         goto finale;
252       end;
253     retv_data_.arg_init = "1"b;
254     retv_data_.areap = get_system_free_area_ ();
255                                                             /* create temp segs and set static ptrs */
256     call get_temp_segments_ (myname, tp, code);
257     if code ^= 0 then do;
258         call retv_report_$error_output (code, myname, "Unable to create temp segs");
259         goto finale;
260       end;
261     retv_data_.nlp = tp (1);
262     retv_data_.aclp = tp (2);
263     retv_data_.recordp = tp (3);
264     retv_data_.objectp = tp (4);
265     retv_data_.vlp = tp (5);
266     retv_data_.contentsp = tp (6);
267     retv_data_.skip = tp (7);
268     retv_data_.input_buffer_ptr = tp (8);
269     retv_data_.page_buffer_ptr = tp (9);
270 
271     call hcs_$set_256K_switch ("11"b, (""b), code);
272     if code ^= 0 then do;
273         call retv_report_$error_output (code, myname, "Could not enable 256KW segments.");
274         go to finale;
275       end;
276     call hcs_$set_max_length_seg (retv_data_.objectp, sys_info$seg_size_256K, code);
277     if code ^= 0 then do;
278         call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (7).");
279         go to finale;
280       end;
281 
282     call hcs_$set_max_length_seg (retv_data_.input_buffer_ptr, sys_info$seg_size_256K, code);
283     if code ^= 0 then do;
284         call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (8).");
285         go to finale;
286       end;
287 
288     call hcs_$set_max_length_seg (retv_data_.page_buffer_ptr, sys_info$seg_size_256K, code);
289     if code ^= 0 then do;
290         call retv_report_$error_output (code, myname, "Could not make 256K word temp seg (9).");
291         go to finale;
292       end;
293 
294     on linkage_error begin;
295         call retv_report_$error_output (0, myname, "AIM ring 1 and ipc privileges not enabled.");
296         goto set_cleanup;
297       end;
298 
299     call system_privilege_$ring1_priv_on (ignore);
300     call system_privilege_$ipc_priv_on (ignore);
301 
302 /* establish cleanup handler and set flag */
303 set_cleanup:
304     revert linkage_error;
305     if retv_data_.qidx (retriever) ^= 0 then do;
306         call read_queue_message (retriever);
307         do while (more_messages);
308           inputp = mseg_return_args.ms_ptr;
309           call ioa_ ("ID: ^a Retrieval request of ^a^[>^]^a for ^a",
310                substr (request_id_ (retv_input.msg_time), 7, 8),
311                retv_input.dirname, retv_input.dirname ^= ">",
312                retv_input.ename, retv_input.requestor);
313           call ioa_$rsnnl (
314                "^[-skip ^]^[-subtree ^]^[-notify ^]^[-previous ^]^[-to ^a ^;^s ^]^[-from ^a ^;^s^]^[-new path ^a^[->^]^a^;^s^]",
315                options_string, osl, retv_input.skip_it,
316                retv_input.subtree, retv_input.notify, retv_input.previous,
317                retv_input.to_time ^= 0 & ^retv_input.previous,
318                time_ (retv_input.to_time), retv_input.from_time ^= 0,
319                time_ (retv_input.from_time), retv_input.new_dirname ^= "", retv_input.new_dirname,
320                retv_input.new_dirname ^= ">", retv_input.new_ename);
321           if osl > 1 then
322             call ioa_ ("options: ^a", options_string);
323           if ^list & step then do;
324 reread1:      call ioa_$nnl ("command:  ");
325               call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
326               if code ^= 0 then do;
327                   call retv_report_$error_output (code, myname, "Command read error");
328                   goto reread1;
329                 end;
330               line = substr (line, 1, nelemt - 1);
331               if line = "quit" | line = "q" then goto finish;
332               else if line = "skip" | line = "s" then do;
333                   retv_input.skip_it = "1"b;
334                   call update_queue_message;
335                 end;
336               else if line = "cancel" | line = "c" then do;
337                   if ^retv_input.proxy then
338                     call delete_queue_message (user, retv_input.user_ms_id);
339                   call delete_queue_message (retriever, mseg_return_args.ms_id);
340                 end;
341               else if line = "proceed" | line = "p" then do;
342                   retv_input.skip_it = "0"b;
343                   call update_queue_message;
344                 end;
345               else if line = "help" | line = "h" then do;
346                   call ioa_ ("Allowable commands are quit(q)^/skip(s)^/cancel(c)^/proceed(p)^/help(h)");
347                   goto reread1;
348                 end;
349               else do;
350                   call ioa_ ("Unrecognized command: ^a", line);
351                   goto reread1;
352                 end;
353             end;
354           call read_incremental_queue_message (retriever);
355         end;
356         if list then goto finish;                           /* go to the next q                               */
357       end;
358                                                             /* create retriever's private queue if necessary */
359     else do;
360         if list then goto finale;
361         call message_segment_$create (wdir, "volume_retriever.ms", code);
362         if code ^= 0 then do;
363             call retv_report_$error_output (code, myname,
364                  "Unable to create private queue ^a>volume_retriever.ms", wdir);
365             goto finish;
366           end;
367         call message_segment_$open (wdir, "volume_retriever.ms", retv_data_.qidx (retriever), code);
368         if code ^= 0 then do;
369             call retv_report_$error_output (code, myname,
370                  "Unable to open private queue ^a>volume_retriever.ms", wdir);
371             goto finish;
372           end;
373       end;
374 
375 /* Read each request from user queue. If the request is not valid then delete it. If the caller
376    wants to review  each request before processing then   display each request . */
377 
378 user_queue:
379     call read_queue_message (user);
380     do while (more_messages);
381       requestp = mseg_return_args.ms_ptr;
382       if retv_request.version ^= retv_request_version_2 then do;
383           call retv_report_$error_output (0, myname,
384                "Invalid version of retrieval request encountered and deleted");
385           call delete_queue_message (user, mseg_return_args.ms_id);
386           goto next;
387         end;
388       if step then do;
389           call ioa_ ("ID: ^a Retrieval request of ^a^[>^]^a for ^a",
390                substr (request_id_ (retv_request.msg_time), 7, 8),
391                retv_request.dirname, retv_request.dirname ^= ">",
392                retv_request.ename, mseg_return_args.sender_id);
393           call ioa_$rsnnl (
394                "^[-subtree ^]^[-notify ^]^[-previous ^]^[-to ^a ^;^s ^]^[-from ^a ^;^s^]^[-new path ^a^[->^]^a^;^s^]",
395                options_string, osl,
396                retv_request.subtree, retv_request.notify, retv_request.previous,
397                retv_request.to_time ^= 0 & ^retv_request.previous,
398                time_ (retv_request.to_time), retv_request.from_time ^= 0,
399                time_ (retv_request.from_time), retv_request.new_dirname ^= "", retv_request.new_dirname,
400                retv_request.new_dirname ^= ">", retv_request.new_ename);
401           if osl > 1 then call ioa_ ("options: ^a", options_string);
402 reread:   call ioa_$nnl ("command:  ");
403           call iox_$get_line (iox_$user_input, addr (line), length (line), nelemt, code);
404           if code ^= 0 then do;
405               call retv_report_$error_output (code, myname, "Command read error");
406               goto reread;
407             end;
408           line = substr (line, 1, nelemt - 1);
409           if line = "quit" | line = "q" then goto finish;
410           else if line = "skip" | line = "s" then goto next;
411           else if line = "cancel" | line = "c" then do;
412               call delete_queue_message (user, mseg_return_args.ms_id);
413               goto next;
414             end;
415           else if line = "proceed" | line = "p" then ;
416           else if line = "help" | line = "h" then do;
417               call ioa_ ("Allowable commands are quit (q)^/skip (s)^/cancel (c)^/proceed (p)^/help (h)");
418               goto reread;
419             end;
420           else do;
421               call ioa_ ("Unrecognized command: ^a", line);
422               goto reread;
423             end;
424         end;
425       unspec (local_retv_input) = "0"b;
426       local_retv_input.request = retv_request;
427       local_retv_input.user_ms_id = mseg_return_args.ms_id;
428       local_retv_input.access_class = mseg_return_args.sender_authorization;
429       local_retv_input.level = mseg_return_args.level;
430       local_retv_input.q_num = retv_data_.queue;
431       local_retv_input.requestor = mseg_return_args.sender_id;
432       local_retv_input.submission_time = fixed (mseg_return_args.ms_id, 71);
433       call message_segment_$add_index (retv_data_.qidx (retriever), addr (local_retv_input),
434            size (local_retv_input) * 36, retv_ms_id, code);
435       if code ^= 0 then
436         call retv_report_$error_output (code, myname,
437              "Unable to add to private queue ^a>volume_retriever.ms", wdir);
438 next:
439       call read_incremental_queue_message (user);
440     end;
441 
442 
443 /* This is the main recovery loop. Each dump volume that has a volume control seg is read
444    After each dump volume is read the private queue is scanned
445    to check for any requests that may have been satisified. If one is found then a check is made to see  if all
446    is well. This check is necessary since the retrieval of an entry may make a whole subtree accessible. If
447    all is well then the request is marked as completed in the private queue. If a subtree retrieval was requested
448    then  the subtree is scanned.
449 */
450 
451 recovery_loop:
452 
453 /* Loop through the queue setting the in_progress flag. This flag will be used latter to determine if a
454    request has not been satisfied */
455 
456     call read_queue_message (retriever);
457     do while (more_messages);
458       inputp = mseg_return_args.ms_ptr;
459       if ^retv_input.skip_it then do;
460           retv_input.retv_ms_id = mseg_return_args.ms_id;
461           call retv_vol_control_ (inputp, code);
462           if code ^= 0 then
463             retv_input.errcode = code;
464           retv_input.in_progress = "1"b;
465           call update_queue_message;
466         end;
467       call read_incremental_queue_message (retriever);
468     end;
469                                                             /* if any dump volumes - setup accounting */
470     if retv_data_.nvol > 0 & retv_data_.accounting then do;
471         call retv_account_$create (code);
472         if code ^= 0 then do;
473             call retv_report_$error_output (code, myname, "Accounting error");
474             goto finish;
475           end;
476       end;
477     do rvcx = 1 to retv_data_.nvol;                         /* sort the control seg */
478       call retv_vol_control_$sort (retv_data_.rvcp (rvcx), code);
479     end;
480     do rvcx = 1 to retv_data_.nvol;                         /* scan the volumes */
481       rvcp = retv_data_.rvcp (rvcx);
482       call retrieve_from_volume_ (rvcp, code);
483       if code ^= 0 then do;
484           if code = -1 then
485             call ioa_ ("Volume ^a in use - it will be skipped", retv_vol_control.volname);
486           else if code = error_table_$resource_unavailable then do;
487               query_info.version = query_info_version_5;
488               call command_query_ (addr (query_info), answer, myname, "^/^a^/^a",
489                    "The physical drive or dump volume is not available or is in use by another process.",
490                    "Do you wish to continue the retrieval ");
491               if answer = "no" then goto finish;
492             end;
493           else call retv_report_$error_output (code, myname, "Error processing volume ^a",
494                     retv_vol_control.volname);
495         end;
496       call read_queue_message (retriever);
497       do while (more_messages);
498         inputp = mseg_return_args.ms_ptr;
499         if retv_input.object_recovered | retv_input.entry_recovered | retv_input.errcode ^= 0 then do;
500             if retv_input.errcode = 0 then do;
501                 if retv_input.new_dirname ^= "" then        /* cross-retrieval */
502                   call hc_backup_$retv_check (retv_input.new_dirname, retv_input.new_ename, type, dtm, code);
503                 else call hc_backup_$retv_check (retv_input.dirname, retv_input.ename, type, dtm, code);
504                 if code ^= 0 & code ^= error_table_$vtoce_connection_fail then
505                   call retv_report_$error_output (code, myname, "Request check failed for ^[^a^[>^]^a^3s^;^3s^a^[>^]^a^]",
506                        (retv_input.new_dirname = ""), retv_input.dirname, retv_input.dirname ^= ">", retv_input.ename,
507                        retv_input.new_dirname, retv_input.new_dirname ^= ">", retv_input.new_ename);
508                 if code = 0 then do;
509                     if retv_input.subtree & type = DIR then do;
510                         to_from = (retv_input.to_time ^= 0) | (retv_input.from_time ^= 0);
511                         call scan_sub_tree (retv_input.dirname, retv_input.ename,
512                              to_from, ignore);
513                       end;
514                     if retv_input.entry_retrieval then do;
515                         call ioa_$rsnnl ("Recovery of object ^a^[>^]^a not necessary as object already there",
516                              message, message_len, retv_input.dirname, retv_input.dirname ^= ">",
517                              retv_input.ename);
518                         call retv_notify_ (message, inputp, myname);
519                       end;
520                     if ^retv_input.proxy then
521                       call delete_queue_message (user, retv_input.user_ms_id);
522                     call delete_queue_message (retriever, retv_input.retv_ms_id);
523                     if retv_data_.accounting then call retv_account_$update (retv_input.requestor);
524                   end;
525               end;
526 
527 /* Having completed a request we now scan all other volume control segments for the same
528    request and delete it if we find it. We must take care to delete the right request since more then one request may
529    exist for the same object.
530 */
531 
532             do sortx = 1 to retv_data_.nvol;
533               rvcp = retv_data_.rvcp (sortx);
534               do sorty = 1 to retv_vol_control.n_entries;
535                 rvcep = addr (retv_vol_control.array (sorty));
536                 if rvce.in_use
537                      & (rvce.uid = retv_input.uid)
538                      & (rvce.retv_ms_id = retv_input.retv_ms_id) then do;
539                     retv_vol_control.in_use_cnt = retv_vol_control.in_use_cnt - 1;
540                     rvce.in_use = "0"b;
541                   end;
542               end;
543             end;
544           end;
545         call read_incremental_queue_message (retriever);
546       end;
547     end;
548 
549 /* When we get here all the requests that were queued in volume control segments have been processed for
550    better or for worse. When a request is looked for on a dump volume the in_progress switch is set. If nothing
551    is found then a message is reported to the operator, and if requested to the requestor. Then the request is deleted
552    from the private queue, and the user queue. Note that proxy requests, because they are issued by the retriever
553    do not exist in the user queue.
554 */
555 
556     call read_queue_message (retriever);
557     do while (more_messages);
558       inputp = mseg_return_args.ms_ptr;
559       if retv_input.in_progress & (^retv_input.object_recovered & ^retv_input.entry_recovered) then do;
560           if retv_input.errcode ^= -1 then do;
561               call hc_backup_$retv_check (retv_input.dirname, retv_input.ename, type, dtm, code);
562               if code = 0 then do;
563                   call ioa_$rsnnl ("Recovery of object ^a^[>^]^a not necessary as already there",
564                        message, message_len, retv_input.dirname, retv_input.dirname ^= ">",
565                        retv_input.ename);
566                 end;
567               else do;
568                   if retv_input.errcode = 0 then long = "object not found on dump media";
569                   else call convert_status_code_ (retv_input.errcode, short, long);
570                   call ioa_$rsnnl ("Failed to recover ^a^[>^]^a for ^a because ^a", message, message_len,
571                        retv_input.dirname, retv_input.dirname ^= ">", retv_input.ename,
572                        retv_input.requestor, long);
573                 end;
574               call retv_notify_ (message, inputp, myname);
575             end;
576           if ^retv_input.proxy then
577             call delete_queue_message (user, retv_input.user_ms_id);
578           call delete_queue_message (retriever, retv_input.retv_ms_id);
579         end;
580       call read_incremental_queue_message (retriever);
581     end;
582 
583 
584 /* delete the volume control segs */
585 
586     do nvolx = 1 to retv_data_.nvol;
587       rvcp = retv_data_.rvcp (nvolx);
588       if rvcp ^= null then do;
589           call hcs_$delentry_seg (rvcp, code);
590           if code ^= 0 then
591             call retv_report_$error_output (code, myname,
592                  "Unable to delete control seg ^a.control", retv_vol_control.volname);
593         end;
594     end;
595     retv_data_.rvcp (*) = null;
596     retv_data_.nvol = 0;
597 
598 /* Now go through the private queue once more to see if any requests remain. If one does reset
599    some control flags. Then go back to the main recovery loop */
600 
601 
602     more_to_do = "0"b;
603     call read_queue_message (retriever);
604     do while (more_messages);
605       inputp = mseg_return_args.ms_ptr;
606       if ^retv_input.skip_it then do;
607           retv_input.uid = "0"b;
608           retv_input.volid = "0"b;
609           retv_input.entry_retrieval = "0"b;
610           retv_input.in_progress = "0"b;
611           retv_input.entry_name = "";
612           retv_input.entry_recovered = "0"b;
613           retv_input.object_recovered = "0"b;
614           retv_input.errcode = 0;
615           call update_queue_message;
616           more_to_do = "1"b;
617         end;
618       call read_incremental_queue_message (retriever);
619     end;
620     if more_to_do then goto recovery_loop;
621     else do;
622         call message_segment_$delete (wdir, "volume_retriever.ms", code);
623         retv_data_.qidx (retriever) = 0;                    /* so it can be reused later                      */
624         if code ^= 0 then call retv_report_$error_output (code, myname,
625                "Unable to delete private queue ^a>volume_retriever.ms", wdir);
626       end;
627 finish:
628     if retv_data_.queue ^= max_q_num & retv_data_.all then do;
629         retv_data_.queue = retv_data_.queue + 1;
630         goto start;
631       end;
632 finale:
633     call clean_it_up;
634     return;
635 
636 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
637 ^L
638 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
639 
640 queue_seg_: proc returns (char (32));
641 
642 /* This proc constructs the user queue segment name and returns it */
643 
644     call ioa_$rsnnl ("volume_retriever_^d.ms", queue_name, (0), retv_data_.queue);
645     return (queue_name);
646   end queue_seg_;
647 
648 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
649 
650 read_queue_message: proc (idx);
651 dcl idx                  fixed bin;
652 
653 /* This proc reads the first message from the specified queue.  */
654 
655     more_messages = "1"b;
656 read: call message_segment_$read_index (retv_data_.qidx (idx), retv_data_.areap, "0"b, ms_arg_ptr,
657          code);
658     if code ^= 0 then do;
659         if code = error_table_$no_message then more_messages = "0"b;
660         else if code = error_table_$bad_segment then do;
661             call retv_report_$error_output (0, myname, "^[Private^;User^] queue has been salvaged",
662                  idx = retriever);
663             goto read;
664           end;
665         else do;
666             call retv_report_$error_output (code, myname, "^[Private^;User^] queue read failed",
667                  retriever = idx);
668             goto finish;
669           end;
670       end;
671 
672   end read_queue_message;
673 
674 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
675 
676 update_queue_message: proc;
677 
678 /* This proc updates a specified message in the private queue.
679 */
680 
681 reupdate: call message_segment_$update_message_index (retv_data_.qidx (retriever), size (retv_input) * 36,
682          mseg_return_args.ms_id, inputp, code);
683     if code ^= 0 then do;
684         if code = error_table_$bad_segment then do;
685             call retv_report_$error_output (0, myname, "Private retriever queue ^a>volume_retriever.ms has been salvaged", wdir);
686             goto reupdate;
687           end;
688         else call retv_report_$error_output (code, myname, "Private queue ^a>volume_retriever.ms update failed", wdir);
689       end;
690   end update_queue_message;
691 
692 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
693 ^L
694 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
695 
696 read_incremental_queue_message: proc (idx);
697 dcl idx                  fixed bin;
698 
699 /* This proc reads the next message from the specified queue.  */
700 
701     if idx = retriever then do;
702         if inputp ^= null then free retv_input in (based_area);
703         inputp = null;
704       end;
705     else do;
706         if requestp ^= null then free retv_request in (based_area);
707         requestp = null;
708 
709       end;
710 retry_inc: call message_segment_$incremental_read_index (retv_data_.qidx (idx), retv_data_.areap, "01"b,
711          mseg_return_args.ms_id, ms_arg_ptr, code);
712     if code ^= 0 then do;
713         if code = error_table_$bad_segment then do;
714             call retv_report_$error_output (0, myname, "^[Private^;User^] queue has been salvaged",
715                  idx = retriever);
716             goto retry_inc;
717           end;
718         else if code = error_table_$no_message then more_messages = "0"b;
719         else do;
720             call retv_report_$error_output (code, myname, "^[Private^;User^] queue read failed",
721                  retriever = idx);
722             goto finish;
723           end;
724       end;
725   end read_incremental_queue_message;
726 
727 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
728 ^L
729 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
730 
731 scan_sub_tree: proc (dn, en, force, ec);
732 
733 /* This proc scans a directory and checks if each object in the directory is accessable. If not
734    it submitts a proxy requests for the missing object. If any object
735    encountered is a directory  then we recurse to
736    the next level. This proc is used during subtree retrieval to check for what is missing at some level
737    inferior to the subtree node and to issue the necessary request to get the object back.  In certain cases
738    even if the object is there a request is submitted. An example of this is a general request to move an existant
739    subtree back in time. */
740 
741 dcl (dn, en)             char (*) aligned;
742 dcl dtm                  bit (36);
743 dcl force                bit (1);
744 dcl nlp                  ptr;
745 dcl pname                char (168) aligned;
746 dcl ec                   fixed bin (35);
747 dcl (nlc, ndx, type)     fixed bin;
748 dcl names                (1) char (32) aligned based (nlp);
749     call ioa_$rsnnl ("^a^[>^]^a", pname, (0), dn, dn ^= ">", en);
750     nlc = 0;
751     ec = 0;
752     call hc_backup_$retv_name_list (pname, retv_data_.areap, nlp, nlc, ec);
753     if ec ^= 0 then do;
754         call retv_report_$error_output (ec, myname, "Unable to list names of ^a",
755              pname);
756         return;
757       end;
758     do ndx = 1 to nlc;
759       ec = 0;
760       call hc_backup_$retv_check (pname, names (ndx), type, dtm, ec);
761       if ec ^= 0 & ec ^= error_table_$vtoce_connection_fail then
762         call retv_report_$error_output (ec, myname, "Subtree check failed for ^a>^a",
763              pname, names (ndx));
764       if ((ec = error_table_$vtoce_connection_fail) | force) & type ^= LINK then do;
765           call submit_request (pname, names (ndx), type);
766         end;
767       if ec = 0 & type = DIR then
768         call scan_sub_tree (pname, names (ndx), force, ec);
769     end;
770     free names in (based_area);
771   end scan_sub_tree;
772 
773 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
774 ^L
775 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
776 
777 submit_request: proc (dn, en, type);
778 
779 /* This proc makes up a proxy request. A proxy request occurs when the retriever, during a subtree request,
780    discovers something missing. The proxy request, while submitted by the retriever, preserves the requestor's
781    access_class, validation level, etc. It differs from the normal request in that it does not have
782    a specific request in the user's queue. */
783 
784 dcl (dn, en)             char (*) aligned;
785 dcl type                 fixed bin;
786     unspec (local_retv_input) = "0"b;
787     local_retv_input.request = retv_input.request;
788     local_retv_input.dirname = dn;
789     local_retv_input.ename = en;
790     local_retv_input.user_ms_id = retv_input.user_ms_id;
791     local_retv_input.access_class = retv_input.access_class;
792     local_retv_input.level = retv_input.level;
793     local_retv_input.q_num = retv_input.q_num;
794     local_retv_input.requestor = retv_input.requestor;
795     local_retv_input.proxy = "1"b;
796     local_retv_input.submission_time = fixed (mseg_return_args.ms_id, 71);
797     call message_segment_$add_index (retv_data_.qidx (retriever), addr (local_retv_input),
798          size (retv_input) * 36, retv_ms_id, code);
799     if code ^= 0 then call retv_report_$error_output (code, myname, "Proxy update error");
800     else if retv_data_.long then call retv_report_$online_output (0,
801            myname, "Proxy submission of ^[directory^;segment^] ^a^[>^]^a", type = DIR, dn, (dn ^= ">"), en);
802   end submit_request;
803 
804 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
805 ^L
806 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
807 
808 
809 delete_queue_message: proc (idx, msid);
810 dcl idx                  fixed bin;
811 dcl msid                 bit (72) aligned;
812 
813 /* This proc deletes the specified message just read from the specified queue */
814 
815     call message_segment_$delete_index (retv_data_.qidx (idx), msid, code);
816     if code ^= 0 then
817       call retv_report_$error_output (code, myname, "^[Private^;User^] queue delete failed",
818            retriever = idx);
819   end delete_queue_message;
820 
821 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
822 
823 time_: proc (bin_time) returns (char (24));
824 
825 /* This proc converts a binary time into a suitable prinable form and returns it. */
826 
827 dcl bin_time             fixed bin (71);
828 dcl time_string          char (24);
829     call date_time_ (bin_time, time_string);
830     return (time_string);
831   end time_;
832 
833 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *   */
834 
835 clean_it_up: proc;
836 
837 /* This proc cleans up and frees whats ever left around */
838 
839     if requestp ^= null then free retv_request in (based_area);
840     if inputp ^= null then free retv_input in (based_area);
841     if tp (1) ^= null then do;
842         call hcs_$truncate_seg (retv_data_.objectp, 0, ignore); /* clean up our 256K seg */
843         call hcs_$set_max_length_seg (retv_data_.objectp, (sys_info$max_seg_size), ignore); /* be a good neighbour */
844         call hcs_$truncate_seg (retv_data_.input_buffer_ptr, 0, ignore); /* clean up our 256K seg */
845         call hcs_$set_max_length_seg (retv_data_.input_buffer_ptr, (sys_info$max_seg_size), ignore); /* be a good neighbour */
846         call hcs_$truncate_seg (retv_data_.page_buffer_ptr, 0, ignore); /* clean up our 256K seg */
847         call hcs_$set_max_length_seg (retv_data_.page_buffer_ptr, (sys_info$max_seg_size), ignore); /* be a good neighbour */
848 
849         call release_temp_segments_ (myname, tp, ignore);
850       end;
851     if retv_data_.error_iocbp ^= null then do;
852         call iox_$close (retv_data_.error_iocbp, ignore);
853         call iox_$detach_iocb (retv_data_.error_iocbp, ignore);
854       end;
855     if retv_data_.input_iocbp ^= null then do;
856         call iox_$close (retv_data_.input_iocbp, ignore);
857         call iox_$detach_iocb (retv_data_.input_iocbp, ignore);
858       end;
859     do nvolx = 1 to retv_data_.nvol;
860       call hcs_$delentry_seg (retv_data_.rvcp (nvolx), ignore);
861     end;
862     do qx = 1 to hbound (retv_data_.qidx, 1);
863       call message_segment_$close (retv_data_.qidx (qx), ignore);
864     end;
865     call hcs_$set_256K_switch (old_256K_switch, (""b), ignore);
866     on linkage_error goto end_clean_it_up;
867     call system_privilege_$ring1_priv_off (ignore);
868     call system_privilege_$ipc_priv_off (ignore);
869 end_clean_it_up:
870     recursive_invocation = "0"b;
871 
872   end clean_it_up;
873 ^L
874 %include retv_data_;
875 %include retv_request;
876 %include retv_input;
877 %include mseg_return_args;
878 %include retv_vol_control;
879 %include queue_msg_hdr;
880 %include query_info;
881 %include iox_dcls;
882 
883   end retriever;