1
2
3
4
5
6
7
8
9
10
11 truncate: tc: proc;
12
13
14
15
16
17
18
19
20
21
22
23
24
25 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin(21), fixed bin(35));
26 dcl cv_oct_check_ entry (char(*), fixed bin(35)) returns(fixed bin(35));
27 dcl com_err_ entry options(variable);
28 dcl expand_pathname_ entry (char(*), char(*), char(*), fixed bin(35));
29 dcl hcs_$get_safety_sw_seg entry (ptr, bit (1), fixed bin (35));
30 dcl hcs_$truncate_file entry (char(*), char(*), fixed bin(19), fixed bin(35));
31 dcl hcs_$truncate_seg entry (ptr, fixed bin(19), fixed bin(35));
32
33
34 dcl hcs_$set_bc entry (char(*), char(*), fixed bin(24), fixed bin(35));
35 dcl hcs_$set_bc_seg entry (ptr, fixed bin(24), fixed bin(35));
36
37
38
39
40 dcl (error_table_$noarg,
41 error_table_$dirseg,
42 error_table_$noentry,
43 error_table_$inconsistent_msf) fixed bin(35) ext static;
44
45
46
47 dcl myname char (32) int static options (constant) init ("truncate");
48
49
50
51 dcl alen fixed bin(21);
52 dcl code fixed bin(35);
53 dcl bitcnt fixed bin(24);
54 dcl nwords fixed bin(19);
55 dcl i fixed bin;
56 dcl segno fixed bin;
57
58
59
60 dcl
61 aptr ptr;
62 dcl segptr ptr;
63
64 dcl (baseptr,char,divide,ltrim,null) builtin;
65
66
67
68 dcl dir char(168);
69 dcl ent char(32);
70 dcl arg char(alen) based(aptr);
71 dcl argsave char(168) init(" ");
72
73
74 dcl callpt label local;
75 ^L
76
77
78 i = 1;
79 call cu_$arg_ptr(i,aptr,alen,code);
80 if code = error_table_$noarg|alen = 0 then go to nogood;
81
82 if arg = "-name" | arg = "-nm" then do;
83
84 i = i + 1;
85 call cu_$arg_ptr(i,aptr,alen,code);
86 if code = error_table_$noarg | alen = 0 then go to nogood;
87 end;
88
89 else do;
90 segno = cv_oct_check_(arg,code);
91 if code = 0 then do;
92 segptr = baseptr(segno);
93 callpt = seg;
94 go to getoff;
95 end;
96 end;
97
98
99
100 call expand_pathname_(arg,dir,ent,code);
101 if code ^= 0 then do;
102 argsave = arg;
103 go to nogood;
104 end;
105 callpt = file;
106
107 getoff:
108 argsave = arg;
109 i = i + 1;
110 call cu_$arg_ptr(i,aptr,alen,code);
111 if code=0 & alen>0 then do;
112 nwords = cv_oct_check_(arg,code);
113 if code^=0 then go to badarg;
114 bitcnt = nwords*36;
115 end;
116 else do;
117 nwords,bitcnt = 0;
118 end;
119
120
121 go to callpt;
122
123 ^L
124
125
126 file:
127 call hcs_$truncate_file(dir,ent,nwords,code);
128 if code = 0 then do;
129 call hcs_$set_bc(dir,ent,bitcnt,code);
130 if code ^= 0 then goto nogood;
131 end;
132 else if code = error_table_$dirseg then call truncate_msf;
133 else goto nogood;
134 return;
135
136 seg:
137 call hcs_$truncate_seg(segptr,nwords,code);
138 if code = 0 then do;
139 call hcs_$set_bc_seg(segptr,bitcnt,code);
140 if code = 0 then return;
141 end;
142
143
144
145 nogood:
146 call com_err_(code,myname,"^a",argsave);
147 return;
148
149
150
151 badarg:
152 call com_err_(0,myname,"Invalid offset: ^a",arg);
153 return;
154
155 %page;
156 truncate_msf:
157 proc;
158
159 dcl initiate_file_ entry (char(*), char(*), bit(*), ptr, fixed bin(24), fixed bin(35));
160 dcl terminate_file_ entry (ptr, fixed bin(24), bit(*), fixed bin(35));
161 dcl delete_$ptr entry (ptr, bit(36) aligned, char(*), fixed bin(35));
162 dcl hcs_$star_ entry (char(*), char(*), fixed bin(2), ptr, fixed bin, ptr, ptr, fixed bin(35));
163 dcl pathname_ entry (char(*), char(*)) returns(char(168));
164
165 dcl cleanup condition;
166
167 dcl ec fixed bin (35);
168 dcl word_count fixed bin (19);
169 dcl word_count_sum fixed bin (35);
170 dcl path char (168);
171 dcl component fixed bin;
172 dcl (max_component, min_component) fixed bin (24);
173 dcl component_count fixed bin;
174 dcl deleting bit (1) aligned;
175 dcl safety_sw bit (1);
176 dcl error_component fixed bin;
177
178 path = pathname_ (dir, ent);
179
180
181
182 call hcs_$star_ (path, "**", 3, null, component_count, (null), (null), ec);
183 if ec ^= 0 then return;
184
185 begin;
186
187 dcl segp ptr;
188 dcl msf_bc fixed bin (24);
189
190 dcl 1 segs (component_count),
191 2 name char (32),
192 2 segp ptr,
193 2 bc fixed bin (24);
194
195 segp, segs.segp (*) = null;
196
197 on cleanup call msf_cleanup;
198
199 ec, max_component = 0;
200 do component = 1 by 1 while (ec = 0 & component <= component_count);
201 segs.name (component) = ltrim (char (max_component));
202 call initiate_file_ (path, segs.name (component), "001"b, segs.segp (component), segs.bc (component), ec);
203 if ec = 0
204 then max_component = max_component + 1;
205 else error_component = max_component;
206 end;
207
208 if ec ^= 0
209 then if ec ^= error_table_$noentry then goto msf_close;
210
211 if max_component ^= component_count then do;
212 ec = error_table_$inconsistent_msf;
213 error_component = 0;
214 goto msf_close;
215 end;
216
217 word_count_sum, word_count = 0;
218 do component = 1 to max_component;
219 word_count = divide (segs.bc (component) + 35, 36, 24, 0);
220 if word_count_sum + word_count >= nwords
221 then do;
222 msf_bc, min_component = component;
223
224
225
226 deleting = "1"b;
227 do component = max_component to min_component+1 by -1;
228 error_component = component;
229 call hcs_$get_safety_sw_seg (segs.segp (component), safety_sw, ec);
230 if ec ^= 0 then goto msf_close;
231
232 if ^safety_sw & deleting
233 then do;
234 call delete_$ptr (segs.segp (component), "010101"b, "truncate", ec);
235 segs.segp (component) = null;
236 end;
237 else do;
238 if deleting
239 then do;
240 msf_bc = component;
241 deleting = "0"b;
242 end;
243 call terminate_file_ (segs.segp (component),
244 0, TERM_FILE_TRUNC_BC_TERM, ec);
245 end;
246
247 if ec ^= 0 then goto msf_close;
248 end;
249
250 error_component = min_component;
251 call terminate_file_ (segs.segp (min_component), (nwords-word_count_sum)*36,
252 TERM_FILE_TRUNC_BC_TERM, ec);
253 if ec ^= 0 then goto msf_close;
254
255 error_component = 0;
256 call hcs_$set_bc (dir, ent, msf_bc, ec);
257 goto msf_close;
258 end;
259 else word_count_sum = word_count_sum + word_count;
260 end;
261
262
263
264
265 call com_err_ (0, myname, "Truncation length specified is larger than current length of ^d for ^a.",
266 word_count_sum, path);
267 ec = 0;
268
269 msf_close:
270 if ec ^= 0 then call com_err_ (ec, myname, "^a^[>^d^]", path, (error_component ^= 0), error_component);
271
272 call msf_cleanup;
273
274 msf_cleanup:
275 proc;
276
277 do component = 1 to component_count;
278 if segs.segp (component) ^= null then call terminate_file_ (segs.segp (component), 0, "0010"b, (0));
279 end;
280
281 if segp ^= null then call terminate_file_ (segp, 0, "0010"b, (0));
282
283 return;
284
285 end msf_cleanup;
286
287 end;
288
289 return;
290
291 end truncate_msf;
292
293 %include terminate_file;
294
295 end truncate;