1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10           /* This command uses an edit_header file to create a new mst header from an old
 11              mst header:
 12 
 13                     edit_mst_header edit_header old_header -new_header-
 14 
 15              Originally coded by R. J. Feiertag on May 16, 1970                 */
 16 
 17 edit_mst_header:    emh:      proc;
 18 
 19           dcl name_ptr ptr,   /* pointer to argument */
 20               namel fixed bin(17), /* length of argument */
 21               name char(namel) based(name_ptr), /* argument to command */
 22               acinfo fixed bin(35), /* ACL information for ti_ about new header segment */
 23               code fixed bin(17), /* error code */
 24               dir char(168), /* directory of segment , also used for error comments */
 25               entry char(32), /* entry of segment */
 26               leave label init(finish), /* place to go for return */
 27               i fixed bin(17), /* miscellaneous index */
 28               nposition fixed bin(17) init(1), /* current position in new header */
 29               nptr ptr init(null), /* pointer to segment for new header */
 30               nstring char(262144) based(nptr), /* new_ header */
 31               bc fixed bin(17), /* bit count of segment */
 32               estring char(einfo.end_of_data) based(einfo.segment_ptr), /* edit_header */
 33               ostring char(oinfo.end_of_data) based(oinfo.segment_ptr), /* old header */
 34               optr ptr, /* pointer to status block of old header segment */
 35               eptr ptr, /* pointer to status block of edit header segment */
 36               okey char(40) aligned, /* current line of old header */
 37               ekey char(40) aligned, /* current line of edit header */
 38               action fixed bin(17); /* index specifying action to be taken */
 39 
 40           dcl nl char(1) internal static init("
 41 "); /* new line */
 42 
 43           dcl 1 oinfo, /* status information about old header segment */
 44                     2 segment_ptr ptr init(null), /* pointer to segment */
 45                     2 begin_section fixed bin(17), /* index to beginning of current section */
 46                     2 position fixed bin(17) init(0), /* current position in segment */
 47                     2 finish fixed bin(17) init(0), /* 1 if end of data reached */
 48                     2 end_of_data fixed bin(17); /* last character of segment */
 49 
 50           dcl 1 einfo, /* status information about edit header segment */
 51                     2 segment_ptr ptr init(null),
 52                     2 begin_section fixed bin(17),
 53                     2 position fixed bin(17) init(0),
 54                     2 finish fixed bin(17) init(0),
 55                     2 end_of_data fixed bin(17);
 56 
 57           dcl get_section internal entry(ptr,fixed bin(17),char(40) aligned);
 58                     /* internal procedure to get next header section */
 59 
 60           dcl hcs_$terminate_noname ext entry(ptr,fixed bin(17)),
 61               hcs_$fs_search_get_wdir ext entry(ptr,fixed bin(17)),
 62               ti_$getseg ext entry,
 63               ti_$findata ext entry(ptr,fixed bin(17),fixed bin(35),fixed bin(17)),
 64               expand_path_ ext entry(ptr,fixed bin(17),ptr,ptr,fixed bin(17)),
 65               cu_$arg_ptr ext entry(fixed bin(17),ptr,fixed bin(17),fixed bin(17)),
 66               hcs_$initiate_count ext entry,
 67               com_err_ ext entry;
 68 
 69           dcl error_table_$entlong ext fixed bin(17);
 70 /*^L*/
 71 
 72           call cu_$arg_ptr(2,name_ptr,namel,code); /* get second argument */
 73           if code ^= 0 then do; /* print error message */
 74                     dir = "";
 75 error:              call com_err_(code,"edit_mst_header",dir); /* print out error */
 76 finish:             if nptr ^= null then do; /* cleanup new header segment */
 77                               substr(nstring,nposition,1) = nl; /* append new line character */
 78                               call ti_$findata(nptr,9*nposition,acinfo,code); /* cleanup segment */
 79                               end;
 80                     if einfo.segment_ptr ^= null then call hcs_$terminate_noname(einfo.segment_ptr,code);
 81                               /* terminate edit header segment */
 82                     if oinfo.segment_ptr ^= null then call hcs_$terminate_noname(oinfo.segment_ptr,code);
 83                               /* terminate old header segment */
 84                     return;
 85                     end;
 86           if name = "-hard" then do; /* editing hardcore header */
 87                     dir = ">library_dir_dir>hard>info";
 88                     entry = "hardcore.header";
 89                     end;
 90            else if name = "-soft" then do; /* editing softcore header */
 91                     dir = ">library_dir_dir>soft>info";
 92                     entry = "softcore.header";
 93                     end;
 94             else do; /* header path name is being supplied */
 95                     call expand_path_(name_ptr,namel,addr(dir),addr(entry),code);
 96                               /* parse path name */
 97                     if code ^= 0 then do; /* error */
 98                               dir = name;
 99                               go to error;
100                               end;
101                     do i = 32 by -1 to 1 while(substr(entry,i,1) = " ");
102                               end; /* get length of entry name */
103                     if i < 1 | i > 25 then do; /* entry name too long */
104                               code = error_table_$entlong; /* return error code */
105                               dir = substr(entry,1,i)||".header";
106                               go to error;
107                               end;
108                     substr(entry,i+1,7) = ".header"; /* add suffix */
109                     end;
110           call hcs_$initiate_count(dir,entry,"",bc,1,oinfo.segment_ptr,code);
111                     /* get pointer to old header segment */
112           if oinfo.segment_ptr = null then do; /* error */
113 path_err:           do i = 168 by -1 to 1 while(substr(dir,i,1) = " ");
114                               end; /* find end of directory name */
115                     substr(dir,i+1,1) = ">"; /* insert greater than */
116                     substr(dir,i+2,min(32,167-i)) = entry; /* concatenate entry name */
117                     go to error;
118                     end;
119           oinfo.end_of_data = divide(bc,9,17,0); /* compute last character */
120           call cu_$arg_ptr(1,name_ptr,namel,code); /* get first argument */
121           if code ^= 0 then do; /* error*/
122                     dir = "";
123                     go to error;
124                     end;
125           call expand_path_(name_ptr,namel,addr(dir),addr(entry),code); /* parse path name */
126           if code ^= 0 then do; /* error */
127                     dir = name;
128                     go to error;
129                     end;
130           do i = 32 by -1 to 1 while(substr(entry,i,1) = " ");
131                     end; /* get length of entry name */
132           if i < 1 | i > 20 then do; /* name too long */
133                     code = error_table_$entlong; /* return error code */
134                     dir = substr(entry,1,i)||".edit_header";
135                     go to error;
136                     end;
137           substr(entry,i+1,12) = ".edit_header"; /* add suffix */
138           call hcs_$initiate_count(dir,entry,"",bc,1,einfo.segment_ptr,code);
139                     /* get pointer to edit header segment */
140           if einfo.segment_ptr = null then go to path_err; /* error */
141           einfo.end_of_data = divide(bc,9,17,0); /* get index of last character in edit header */
142           call cu_$arg_ptr(3,name_ptr,namel,code); /* get third argument */
143           if code ^= 0 then do; /* no third arg, assume same name as edit header */
144                     substr(entry,i+1,32-i) = ".header"; /* new header has same name as edit header */
145                     call hcs_$fs_search_get_wdir(addr(dir),code); /* put header in working dir */
146                     end;
147            else do; /* new header name has been provided */
148                     call expand_path_(name_ptr,namel,addr(dir),addr(entry),code); /* parse path name */
149                     if code ^= 0 then do; /* error */
150                               dir = name;
151                               go to error;
152                               end;
153                     do i = 32 by -1 to 1 while(substr(entry,i,1) = " ");
154                               end; /* find length of entry name */
155                     if i < 1 | i > 25 then do; /* name too long */
156                               code = error_table_$entlong; /* return error code */
157                               dir = substr(entry,1,i)||".header";
158                               go to error;
159                               end;
160                     substr(entry,i+1,7) = ".header"; /* add suffix */
161                     end;
162           call ti_$getseg(dir,entry,nptr,acinfo,code);
163                     /* create and initiate new header segment */
164           if nptr = null then go to path_err; /* error */
165           optr = addr(oinfo); /* initialize pointer to old header segment status block */
166           eptr = addr(einfo); /* initialize pointer to edit header segment status block */
167           call get_section(optr,i,okey); /* get first header section from old header */
168 next:     call get_section(eptr,action,ekey); /* get next header section form edit header */
169           if einfo.finish = 1 then go to finish; /* end of data reached in edit header segment, we are done */
170           if action > 3 then do; /* this is a skip instruction */
171                     do while(ekey ^= okey); /* look for matching header section in old header */
172                               call get_section(optr,i,okey); /* get next old header section for comparison */
173                               end;
174                     if action = 5 then call get_section(optr,i,okey); /* if skip_thru then go to next old
175                                                                                 header section */
176                     end;
177            else if action > 0 then do; /* this is a copy instruction */
178                     do while(ekey ^= okey); /* search for matching header section in old header */
179                               i = oinfo.position-oinfo.begin_section+1; /* copy header section to new header */
180                               substr(nstring,nposition,i) = substr(ostring,oinfo.begin_section,i);
181                               nposition = nposition + i;
182                               call get_section(optr,i,okey); /* get next old header section for comparison */
183                               end;
184                     if action = 2 then do; /* this is a copy thru instruction so copy old header section */
185                               i = oinfo.position-oinfo.begin_section+1; /* copy old header section to new header */
186                               substr(nstring,nposition,i) = substr(ostring,oinfo.begin_section,i);
187                               nposition = nposition + i;
188                               end;
189                     if action < 3 then call get_section(optr,i,okey); /* copy thru or copy_to,replace so go to
190                                                                       next old header section */
191                     end;
192           if action < 2 then do; /* copy edit header section */
193                     i = einfo.position-einfo.begin_section+1;
194                     substr(nstring,nposition,1) = nl; /* insert new line */
195                     substr(nstring,nposition+1,i) = substr(estring,einfo.begin_section,i);
196                     nposition = nposition + i + 1;
197                     end;
198           go to next;
199 /*^L*/
200           /* This next procedure gets the next header section in the specified segment and returns
201               an action indicator and the primary line of the header section */
202 
203 get_section:        proc(segptr,action,key);
204 
205           dcl segptr ptr, /* pointer to current header segment status block */
206               action fixed bin(17), /* action to be taken */
207               key char(40) aligned, /* primary statement from current section */
208               string char(stringl) based(string_ptr), /* current header segment */
209               stringl fixed bin(17), /* length of string */
210               string_ptr ptr, /* pointer to string */
211               linespace char(40), /* space for line */
212               line char(ll) based(line_ptr), /* current primary line for section */
213               line_ptr ptr init(addr(linespace)), /* pointer to linespace */
214               ll fixed bin(17); /* current line length */
215 
216           dcl 1 info based(segptr), /* header segment status block */
217                     2 seg_ptr ptr, /* pointer to header segment */
218                     2 begin_sect fixed bin(17), /* index to beginning of current section */
219                     2 pos fixed bin(17), /* index to current position in header segment */
220                     2 fin fixed bin(17), /* end of data reached in this header segment */
221                     2 eod fixed bin(17); /* number of characters in header segment */
222 
223           dcl get_line internal entry; /* internal procedure to get next line to specified breaks */
224 
225           stringl = eod; /* get length of current header segment */
226           string_ptr = seg_ptr; /* get pointer to current header segment */
227           if fin = 1 then do; /* we are trying to read off the end of the segment,error */
228                     call com_err_(0,"edit_mst_header","Premature end of data reached on old header segment.
229 Current line is: ^a",ekey);
230                     go to leave;
231                     end;
232           begin_sect = pos + 1; /* am starting a new section */
233           call get_line(0,":;"); /* get first line of section */
234           if fin = 1 then if ll = 0 then return; /* no more data */
235           if line = "copy_to,replace:" then action = 1; /* map key words into instructions */
236            else if line = "copy_to,reload:" then action = 1;
237            else if line = "copy_to:" then action = 3;
238             else if line = "copy_thru:" then action = 2;
239              else if line = "skip_to:" then action = 4;
240               else if line = "skip_thru:" then action = 5;
241                else do; /* not a control word so already have beginning of section */
242                     action = 0; /* insert section */
243                     go to skip;
244                     end;
245           begin_sect = pos + 1; /* control word is not part of section */
246           call get_line(0,":;"); /* get first line of section */
247 skip:     if line = "collection:" then do; /* collection mark haxs no end statement */
248                     call get_line(11,",;"); /* get rest of line */
249                     end;
250             else if line ^= "fini:" then do; /* regular header section, must find end statement */
251                     call get_line(ll,",;"); /* get rest of primary line */
252                     call get_line(ll,""); /* find end statement */
253                     end;
254           key = line; /* return primary line */
255           if fin = 1 then do; /* data has ended in middle of header section */
256                     call com_err_(0,"edit_mst_header","Premature end of header section. ^a",substr(string,begin_sect,
257                               eod-begin_sect+1)); /* print out error message */
258                     go to leave; /* abort */
259                     end;
260           return;
261 /*^L*/
262 
263           /* This next procedure returns the next statement up to the specified break in the
264               string line.    */
265 
266 get_line: proc(offset,breaks);
267 
268           dcl offset fixed bin(17), /* offset in line  of where to start placing new line */
269               breaks char(*), /* characters on which to break for this call */
270               ch char(1), /* current character */
271               i fixed bin(17), /* miscellaneous index */
272               end_flag fixed bin(17) init(0), /* 1 if we are searching for an end statement */
273               tab char(1) internal static init("  "); /* tab */
274 
275           if length(breaks) = 0 then end_flag = 1; /* we are looking for an end statement */
276           ll = offset; /* set line length to starting position in line */
277           do pos = pos + 1 to eod; /* scan each character */
278 new_char:           ch = substr(string,pos,1); /* get character */
279                     if ch = "/" then if eod-pos > 2 then if substr(string,pos+1,1) = "*" then do;
280                               /* we are at the beginning of a comment */
281                               i = index(substr(string,pos+2,eod-pos-1),"*/"); /* get position of end of comment */
282                               if i = 0 then do; /* comment never ends */
283                                         call com_err_(0,"edit_mst_header","Unended comment. ^a",
284                                                   substr(string,pos,eod-pos+1)); /* print out bad comment */
285                                         go to leave; /* abort */
286                                         end;
287                               pos = i + pos + 3; /* move position to end of comment */
288                               go to new_char; /* go pick up new character */
289                               end;
290                     if ch ^= " " then if ch ^= tab then if ch ^= nl then do; /* skip blanks, tabs, and new lines */
291                               if end_flag ^= 0 then do; /* search for end statement */
292                                         if ch = "e" then end_flag = 2; /* have found e */
293                                          else if end_flag ^= 1 then do; /* have already found part of end statement */
294                                                   if ch = "n" & end_flag = 2 then end_flag = 3;
295                                                             /* have found en */
296                                                    else if ch = "d" & end_flag = 3 then end_flag = 4;
297                                                             /* have found end */
298                                                     else if ch = ";" & end_flag = 4 then return;
299                                                             /* have found end statement */
300                                                      else end_flag = 1;
301                                                   end;
302                                         end;
303                                else do; /* place character in line */
304                                         ll = ll + 1; /* increment line length */
305                                         if ll > 40 then do; /* line is too long */
306                                                   call com_err_(0,"edit_mst_header","Statement too long. ^a",line);
307                                                   go to leave;
308                                                   end;
309                                         do i = 1 to length(breaks); /* check for break character */
310                                                   if ch = substr(breaks,i,1) then do; /* it is a break */
311                                                             substr(linespace,ll,1) = substr(breaks,1,1);
312                                                                       /* store character into line */
313                                                             return;
314                                                             end;
315                                                   end;
316                                         substr(linespace,ll,1) = ch; /* if not break then transfer character to line */
317                                         end;
318                               end;
319                     end;
320           fin = 1; /* end of data reached */
321           end get_line;
322           end get_section;
323           end edit_mst_header;