1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 backup_cleanup: bc: proc;
 12 
 13 /* Command to dprint and delete backup maps and error files.
 14 
 15    Usage:
 16           backup_cleanup {starnames} {-no_dprint}
 17 
 18    If no starnames are specified, *.*.map and *.*.ef in the working directory
 19    are processed. If -no_dprint is specified, the segments are deleted.
 20    Otherwise they are dprinted and deleted.
 21 
 22 Written 04/26/79 S. Herbst */
 23 
 24 
 25 
 26 %include dprint_arg;
 27 
 28 dcl 1 entries (branch_count) aligned based (entries_ptr),   /* for hcs_$star_ */
 29      2 type bit (2) unaligned,
 30      2 nnames bit (16) unaligned,
 31      2 nindex bit (18) unaligned;
 32 
 33 dcl names (99) char (32) aligned based (names_ptr);         /* for hcs_$star_ */
 34 
 35 dcl area area based (area_ptr);
 36 
 37 dcl arg char (arg_len) based (arg_ptr);
 38 dcl ERROR_FILE_DIR char (168) int static options (constant) init (">udd>SysDaemon>error_file");
 39 dcl dn char (168);
 40 dcl (en, name) char (32);
 41 
 42 dcl (dprint_sw, ef_sw, path_sw) bit (1) aligned;
 43 
 44 dcl (area_ptr, arg_ptr, entries_ptr, names_ptr) ptr;
 45 
 46 dcl rings (3) fixed bin (5);
 47 dcl (arg_count, arg_len, branch_count, i, j, queue_number) fixed bin;
 48 
 49 dcl code fixed bin (35);
 50 dcl error_table_$badopt fixed bin (35) ext;
 51 dcl error_table_$noentry fixed bin (35) ext;
 52 dcl error_table_$nomatch fixed bin (35) ext;
 53 
 54 dcl bk_ss_$myname char (16) ext;
 55 
 56 dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned,
 57           fixed bin (24), fixed bin (35));
 58 dcl check_star_name_$entry entry (char (*), fixed bin (35));
 59 dcl com_err_ entry options (variable);
 60 dcl copy_seg_ entry (char (*), char (*), char (*), char (*), char (*), bit (1) aligned, fixed bin (35));
 61 dcl cu_$arg_count entry (fixed bin);
 62 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 63 dcl cu_$level_get entry returns (fixed bin);
 64 dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
 65 dcl dprint_ entry (char (*), char (*), ptr, fixed bin (35));
 66 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 67 dcl get_system_free_area_ entry returns (ptr);
 68 dcl get_wdir_ entry returns (char (168));
 69 dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
 70 dcl hcs_$set_ring_brackets entry (char (*), char (*), (3) fixed bin (5), fixed bin (35));
 71 dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
 72 dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35));
 73 
 74 dcl (addr, fixed, length, max, null, rtrim, substr) builtin;
 75 
 76 dcl cleanup condition;
 77 /*^L*/
 78           bk_ss_$myname = "backup_cleanup";
 79 
 80           call cu_$arg_count (arg_count);
 81 
 82           dprint_sw = "1"b;
 83           path_sw = "0"b;
 84           queue_number = 1;
 85 
 86           do i = 1 to arg_count;
 87                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
 88                if substr (arg, 1, 1) = "-" then
 89                     if arg = "-no_dprint" | arg = "-ndp" then dprint_sw = "0"b;
 90                     else if arg = "-dprint" | arg = "-dp" then dprint_sw = "1"b;
 91                     else if arg = "-queue" | arg = "-q" then do;
 92                          i = i + 1;
 93                          if i > arg_count then do;
 94                               call com_err_ (0, "backup_cleanup", "No value specified for ^a", arg);
 95                               return;
 96                          end;
 97                          call cu_$arg_ptr (i, arg_ptr, arg_len, code);
 98                          queue_number = cv_dec_check_ (arg, code);
 99                          if code ^= 0 then do;
100 BAD_QUEUE:                    call com_err_ (0, "backup_cleanup", "Invalid queue number ^a", arg);
101                               return;
102                          end;
103                          else if queue_number < 1 | queue_number > 4 then go to BAD_QUEUE;
104                     end;
105                     else do;
106                          call com_err_ (error_table_$badopt, "backup_cleanup", "^a", arg);
107                          return;
108                     end;
109                else path_sw = "1"b;
110           end;
111 
112           area_ptr = get_system_free_area_ ();
113 
114           if dprint_sw then do;
115                dpap = addr (dprint_arg_buf);
116                dprint_arg.version = 1;
117                dprint_arg.copies = 1;
118                dprint_arg.delete = 1;
119                dprint_arg.queue = queue_number;
120                dprint_arg.pt_pch = 1;
121                dprint_arg.notify = 0;
122                dprint_arg.output_module = 1;
123                dprint_arg.dest = "SysDaemon";
124           end;
125 
126           if ^path_sw then do;                              /* no starnames specified */
127 
128                call do_starname (get_wdir_ (), "*.*.map");
129 
130                call do_starname (get_wdir_ (), "*.*.*.ef");
131           end;
132 
133           else do i = 1 to arg_count;
134 
135                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
136                if substr (arg, 1, 1) ^= "-" then do;
137 
138                     call expand_pathname_ (arg, dn, en, code);
139                     if code ^= 0 then do;
140                          call com_err_ (code, "backup_cleanup", "^a", arg);
141                          return;
142                     end;
143 
144                     if substr (arg, arg_len - 3, 4) = ".map" | substr (arg, arg_len - 2, 3) = ".ef" then
145 
146                          call do_starname (dn, en);
147 
148                     else do;
149 
150                          call do_starname (dn, rtrim (en) || ".map");
151 
152                          call do_starname (dn, rtrim (en) || ".ef");
153                     end;
154                end;
155           end;
156 
157           return;
158 /*^L*/
159 do_starname: proc (a_dn, a_en);
160 
161 dcl (a_dn, a_en) char (*);
162 
163           call check_star_name_$entry (a_en, code);
164 
165           if code = 0 then do;
166                branch_count, j = 1;
167                name = a_en;
168                go to ONE_FILE;
169           end;
170 
171           else if code = 1 | code = 2 then do;
172 
173                entries_ptr, names_ptr = null;
174 
175                on condition (cleanup) call clean_up;
176 
177                call hcs_$star_ (a_dn, a_en, 2 /* branches */, area_ptr, branch_count,
178                     entries_ptr, names_ptr, code);
179                if code ^= 0 then do;
180                     if code ^= error_table_$nomatch then
181                          call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", a_en);
182                     return;
183                end;
184 
185                do j = 1 to branch_count;
186 
187                     name = names (fixed (entries (j).nindex, 18));
188 
189 ONE_FILE:           if substr (a_en, length (rtrim (a_en)) - 2, 3) = ".ef" then do;
190                          ef_sw = "1"b;
191                          dprint_arg.heading = " for OLD ERROR FILE";
192                     end;
193                     else do;
194                          ef_sw = "0"b;
195                          dprint_arg.heading = " for OLD MAP";
196                     end;
197 
198                     if dprint_sw | ef_sw then do;
199 
200                          call adjust_bit_count_ ((a_dn), (name), "1"b, 0, code);
201                          if code ^= 0 then do;
202                               call com_err_ (code, "backup_cleanup", "^a^[>^]^a", a_dn, a_dn ^= ">", name);
203                               return;
204                          end;
205 
206                          rings (1), rings (2), rings (3) = max (4, cu_$level_get ());
207                          call hcs_$set_ring_brackets (a_dn, name, rings, code);
208                     end;
209 
210                     if ef_sw then do;                       /* copy error file */
211                          call hcs_$status_minf (ERROR_FILE_DIR, name, 0, 0, 0, code);
212                          if code ^= error_table_$noentry then do;
213                               call hcs_$delentry_file (ERROR_FILE_DIR, name, code);
214 COPY_ERROR:                   if code ^= 0 then call com_err_ (code, "backup_cleanup",
215                                    "Copying ^a^[>^]^a to ^a>^a", a_dn, a_dn ^= ">", name, ERROR_FILE_DIR, name);
216                          end;
217                          else code = 0;
218 
219                          if code = 0 then do;
220                               call copy_seg_ (a_dn, name, ERROR_FILE_DIR, name, "backup_cleanup", "0"b, code);
221                               if code ^= 0 then go to COPY_ERROR;
222                          end;
223                     end;
224 
225                     if dprint_sw then call dprint_ (a_dn, name, dpap, code);
226 
227                     else call hcs_$delentry_file (a_dn, name, code);
228                end;
229 
230                call clean_up;
231           end;
232 
233           else call com_err_ (code, "backup_cleanup", "^a", a_en);
234 
235 end do_starname;
236 /*^L*/
237 clean_up: proc;
238 
239           if entries_ptr ^= null then free entries_ptr -> entries in (area);
240           if names_ptr ^= null then free names_ptr -> names in (area);
241 
242 end clean_up;
243 
244 end backup_cleanup;