1
2
3
4
5
6
7
8
9
10
11 backup_cleanup: bc: proc;
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26 %include dprint_arg;
27
28 dcl 1 entries (branch_count) aligned based (entries_ptr),
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);
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
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;
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
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 , 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;
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
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;