1
2
3
4
5
6
7
8
9
10
11
12
13 vfa:
14 vfile_adjust:
15 proc (pathname_arg);
16 seg_ptr, fcb_ptr, iocb_ptr = null;
17 call cu_$arg_count (n_args);
18 if n_args <= 0
19 then code = error_table_$noarg;
20 else if n_args > 3
21 then code = error_table_$too_many_args;
22 else code = 0;
23 call check_code;
24 call get_file_base;
25 if (seg_ptr -> header.file_code ^= seq_code) & (seg_ptr -> header.file_code ^= blk_code)
26 & (seg_ptr -> header.file_code ^= indx_code)
27 then call adj_uns_file;
28 else call adj_struc_file;
29 call check_code;
30 cleanup:
31 if fcb_ptr ^= null
32 then call msf_manager_$close (fcb_ptr);
33 else if seg_ptr ^= null
34 then call hcs_$terminate_noname (seg_ptr, code);
35 if iocb_ptr ^= null
36 then do;
37 call iox_$close (iocb_ptr, code);
38 call iox_$detach_iocb (iocb_ptr, code);
39 end;
40 return;
41
42 check_code:
43 proc;
44 if code = 0
45 then return;
46 call com_err_ (code, "vfile_adjust");
47 go to cleanup;
48 end check_code;
49
50 get_file_base:
51 proc;
52 call expand_path_ (addr (pathname_arg), length (pathname_arg), addr (d_name), addr (e_name), code);
53
54 call check_code;
55 call hcs_$status_long (d_name, e_name, 1, addr (branch_info), null, code);
56 call check_code;
57 if branch_info.type = "10"b
58 then if branch_info.bit_count = "0"b
59 then code = error_table_$dirseg;
60 else do;
61 call msf_manager_$open ((d_name), (e_name), fcb_ptr, code);
62
63 call check_code;
64 call msf_manager_$get_ptr (fcb_ptr, 0, "0"b, seg_ptr, bc, code);
65
66 if seg_ptr ^= null
67 then code = 0;
68 end;
69 else do;
70 call hcs_$initiate (d_name, e_name, "", 0, 1, seg_ptr, code);
71 if seg_ptr ^= null
72 then code = 0;
73 end;
74 call check_code;
75 end get_file_base;
76
77 adj_struc_file:
78 proc;
79 if n_args > 1
80 then code = error_table_$too_many_args;
81 call check_code;
82 call check_file_lock;
83 call attach_unique_sw;
84 call iox_$open (iocb_ptr, 7 , "0"b, code);
85
86 end adj_struc_file;
87
88 adj_uns_file:
89 proc;
90 if n_args <= 1
91 then code = error_table_$noarg;
92 call cu_$arg_ptr (2, opt1_ptr, opt1_len, code);
93 call check_code;
94 if n_args > 2
95 then do;
96 call cu_$arg_ptr (3, opt2_ptr, opt2_len, code);
97 call check_code;
98 end;
99 if n_args = 2
100 then if opt1_arg = "-set_bc"
101 then call adjust_bit_count_ (d_name, e_name, "1"b , bc, code);
102
103 else if opt1_arg = "-use_nl"
104 then call trunc_at_line;
105 else if opt1_arg = "-set_nl"
106 then call append_line;
107 else call get_use_bc;
108 else call get_use_bc;
109 return;
110
111 trunc_at_line:
112 proc;
113 call prep_uns_file;
114 call iox_$put_chars (iocb_ptr, (null), 0, code);
115 end trunc_at_line;
116
117 prep_uns_file:
118 proc;
119 call adjust_bit_count_ (d_name, e_name, "1"b, bc, code);
120
121 call check_code;
122 call attach_unique_sw;
123 call iox_$open (iocb_ptr, 3 , "0"b, code);
124
125 call check_code;
126 call iox_$position (iocb_ptr, 0, 0, code);
127 end prep_uns_file;
128
129 append_line:
130 proc;
131 call prep_uns_file;
132 call iox_$get_chars (iocb_ptr, addr (dummy_buffer), 1, rec_len, code);
133
134 if code ^= error_table_$end_of_info
135 then do;
136 call iox_$position (iocb_ptr, 1, 0, code);
137
138 call iox_$put_chars (iocb_ptr, addr (newline), 1, code);
139 end;
140 else code = 0;
141 end append_line;
142
143 get_use_bc:
144 proc;
145 if opt1_arg ^= "-use_bc"
146 then code = error_table_$bad_arg;
147 else if branch_info.type ^= "10"b
148 then do;
149 if n_args > 2
150 then if opt2_arg ^= "0"
151 then code = error_table_$bad_arg;
152 else call hcs_$truncate_seg (seg_ptr, divide (fixed (bit_count) + 35, 36, 18, 0), code);
153 end;
154 else do;
155 if n_args = 2
156 then call get_last_nz_comp;
157 else call get_comp_n;
158 call check_code;
159 call msf_manager_$adjust (fcb_ptr, n_tail, bc, "011"b, code);
160
161 end;
162 return;
163
164 get_last_nz_comp:
165 proc;
166
167 do n_tail = 1 repeat n_tail + 1 while (code = 0);
168 call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
169
170 end;
171
172 n_recs = 0;
173
174 do n_tail = n_tail - 2 to 0 by -1 while (n_recs = 0);
175
176 call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
177
178 call hcs_$fs_get_path_name (seg_ptr, d_name, d_len, e_name, code);
179
180 call hcs_$status_ (d_name, e_name, 0, addr (branch_info), null , code);
181
182 end;
183
184 n_tail = n_tail + 1;
185
186 end get_last_nz_comp;
187
188 get_comp_n:
189 proc;
190 n_tail = cv_dec_check_ (opt2_arg, code);
191 call check_code;
192 call msf_manager_$get_ptr (fcb_ptr, n_tail, "0"b, seg_ptr, bc, code);
193
194 end get_comp_n;
195
196 end get_use_bc;
197
198 end adj_uns_file;
199
200 attach_unique_sw:
201 proc;
202 call iox_$attach_ioname (unique_chars_ ("0"b), iocb_ptr, "vfile_ " || pathname_arg || " -extend", code);
203 call check_code;
204 end attach_unique_sw;
205
206 check_file_lock:
207 proc;
208 lock_word = seg_ptr -> header.lock_word;
209 call set_lock_$lock (lock_word, 0, code);
210 if code ^= 0
211 then if code = error_table_$locked_by_this_process
212 then do;
213 call command_query_ (addr (query_info), answer, "vfile_adjust",
214 "Warning
215 by this process. Resuming a previous invocation
216 of vfile_ after adjustment may produce unpredictable
217 errors. Close the I/O switch or issue a new_proc to be safe.
218 Do you still wish to adjust the file?"
219 );
220 if answer = "no"
221 then go to cleanup;
222 seg_ptr -> header.lock_word = bit (-1);
223
224 end;
225 end check_file_lock;
226
227
228 dcl hcs_$status_long entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35));
229 dcl hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed (1), fixed (2),
230 ptr, fixed (35));
231 dcl hcs_$terminate_noname entry (ptr, fixed (35));
232 dcl lock_word bit (36) aligned;
233 dcl seq_code static internal fixed init (83711);
234 dcl blk_code static internal fixed init (22513);
235 dcl indx_code static internal fixed init (7129);
236 dcl hcs_$truncate_seg entry (ptr, fixed (18), fixed (35));
237 dcl error_table_$end_of_info
238 external fixed (35);
239 dcl iox_$put_chars entry (ptr, ptr, fixed (21), fixed (35));
240 dcl iox_$position entry (ptr, fixed, fixed, fixed (35));
241 dcl iox_$get_chars entry (ptr, ptr, fixed (21), fixed (21), fixed (35));
242 dcl rec_len fixed (21);
243 dcl newline char (1) aligned static internal init ("
244 ");
245 dcl dummy_buffer char (1) aligned;
246 dcl pathname_arg char (*);
247 dcl opt1_arg char (opt1_len) based (opt1_ptr);
248 dcl opt2_arg char (opt2_len) based (opt2_ptr);
249 dcl (opt1_len, opt2_len) fixed;
250 dcl (opt1_ptr, opt2_ptr) ptr;
251 dcl cu_$arg_ptr entry (fixed, ptr, fixed, fixed (35));
252 dcl (fcb_ptr, iocb_ptr) ptr;
253 dcl cu_$arg_count entry (fixed);
254 dcl n_args fixed;
255 dcl code fixed (35);
256 dcl (error_table_$noarg, error_table_$dirseg, error_table_$too_many_args, error_table_$bad_arg,
257 error_table_$locked_by_this_process)
258 external fixed (35);
259 dcl (null, fixed, bit, divide, addr)
260 builtin;
261 dcl msf_manager_$close entry (ptr);
262 dcl iox_$close entry (ptr, fixed (35));
263 dcl iox_$open entry (ptr, fixed, bit (1) aligned, fixed (35));
264 dcl iox_$detach_iocb entry (ptr, fixed (35));
265 dcl com_err_ entry options (variable);
266 dcl expand_path_ entry (ptr, fixed, ptr, ptr, fixed (35));
267 dcl msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed (35));
268 dcl msf_manager_$get_ptr entry (ptr, fixed, bit (1), ptr, fixed (24), fixed (35));
269 dcl d_name char (168) aligned;
270 dcl e_name char (32) aligned;
271 dcl seg_ptr ptr;
272 dcl bc fixed (24);
273 dcl 1 header based (seg_ptr),
274 2 file_code fixed (35),
275 2 lock_word bit (36) aligned;
276 dcl adjust_bit_count_ entry (char (168) aligned, char (32) aligned, bit (1) aligned, fixed (24),
277 fixed (35));
278 dcl n_tail fixed;
279 dcl msf_manager_$adjust entry (ptr, fixed, fixed (24), bit (3), fixed (35));
280 dcl hcs_$fs_get_path_name entry (ptr, char (*) aligned, fixed, char (*) aligned, fixed (35));
281 dcl hcs_$status_ entry (char (*) aligned, char (*) aligned, fixed (1), ptr, ptr, fixed (35));
282 dcl d_len fixed;
283 dcl 1 branch_info aligned,
284 ( 2 type bit (2),
285 2 nnames fixed (15),
286 2 nrp bit (18),
287 2 dtm bit (36),
288 2 dtu bit (36),
289 2 mode bit (5),
290 2 pad bit (13),
291 2 n_recs fixed (17)
292 ) unaligned,
293 2 words1 (3) fixed,
294 2 pad1 bit (12) unal,
295 2 bit_count bit (24) unal,
296 2 words2 (2) fixed;
297 dcl cv_dec_check_ entry (char (*), fixed (35)) returns (fixed (35));
298 dcl set_lock_$lock entry (bit (36) aligned, fixed, fixed (35));
299 dcl command_query_ entry options (variable);
300 dcl 1 query_info aligned,
301 2 version fixed init (2),
302 2 yes_or_no_sw bit (1) unal init ("1"b),
303 2 suppress_name_sw bit (1) unal init ("0"b),
304 2 code fixed (35),
305 2 query_code fixed (35);
306 dcl answer char (12) var;
307 dcl iox_$attach_ioname entry (char (*), ptr, char (*), fixed (35));
308 dcl unique_chars_ entry (bit (*)) returns (char (15));
309 end vfile_adjust;