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 truncate:  tc:   proc;
 12 
 13 /*   This command is used to truncate a specified segment to a specified word offset.
 14           the segment to be truncated is referred to either by a pathname or an octal segment
 15           number. The second argument is the length to which the segment is to be truncated.
 16           If no offset is supplied, zero will be assumed.
 17 
 18           Written by Robert S. Coren Sept 1972
 19           Modified Nov 1983 by Charles Spitzer. make work on consistent MSFs.
 20 ^L
 21 */
 22 
 23 
 24 /*        entry declarations   */
 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 /*        external refs  */
 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 /*        static   */
 46 
 47 dcl       myname char (32) int static options (constant) init ("truncate");
 48 
 49 /*        fixed binary    */
 50 
 51 dcl       alen fixed bin(21); /* length of currently examined argument */
 52 dcl       code fixed bin(35); /* status code */
 53 dcl       bitcnt fixed bin(24);/* new bit count */
 54 dcl       nwords fixed bin(19);/* new length in words */
 55 dcl       i fixed bin;        /* argument counter */
 56 dcl       segno fixed bin;
 57 
 58 /*        pointers  */
 59 
 60 dcl
 61           aptr ptr;           /* pointer to latest argument */
 62 dcl       segptr ptr;         /* pointer to segment if number coded */
 63 
 64 dcl       (baseptr,char,divide,ltrim,null) builtin;
 65 
 66 /*        character strings  */
 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 /*        labels    */
 74 dcl       callpt label local;
 75 ^L
 76 /********************         code begins here    ***********************/
 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;           /* Name option */
 83 
 84                i = i + 1;                                   /* Next arg is name of segment */
 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;                                          /* find out if it's a number */
 90                segno = cv_oct_check_(arg,code);
 91                if code = 0 then do;               /* it is */
 92                     segptr = baseptr(segno);
 93                     callpt = seg;
 94                     go to getoff;
 95                     end;
 96                end;
 97 
 98                                         /* if it's a name, expand it */
 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;                    /* Get offset argument (if any) */
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;       /* default is 0 */
118                end;
119 
120 
121           go to callpt;
122 
123 ^L
124 /**********************       actual truncation now         *******************/
125 
126 file:                                             /* pathname given */
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:                                              /* segment number given */
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                               /**** ERROR BRANCHES  ****/
144 
145 nogood:
146           call com_err_(code,myname,"^a",argsave);
147           return;
148 
149 
150 
151 badarg:                       /* Non-numeric offset */
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);                                      /* error code */
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 /* get the number of components. */
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),                               /* components of the msf */
191       2 name char (32),                                     /* component name */
192       2 segp ptr,                                           /* ptr to base of component */
193       2 bc fixed bin (24);                                  /* bit count of component */
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;     /* not enough segments in MSF to match what star_ said */
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;                                /* end the MSF on this component */
222                          msf_bc, min_component = component; /* MSF bit count is highest numbered component */
223 
224 /* going backwards means we have a valid MSF if we get an abort for any reason */
225 
226                          deleting = "1"b;                   /* delete components */
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;/* how many components to set the bit count of the dir */
241                                          deleting = "0"b;   /* don't delete any more previous to this one */
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 /* We reached the end of the MSF before nwords. This is not allowed. Issue
263    an error message and return. */
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:                                                /* inside begin block */
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;                                         /* begin block */
288 
289           return;
290 
291      end truncate_msf;
292 
293 %include terminate_file;
294 
295 end truncate;