1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 file_util: procedure;                                       /* File System Interface Module utility procedures. */
 14 
 15 /* Modified 13 August 1972, M J Grady - Honeywell. */
 16 /* Modified July 1973 by E. Stone to work both for 64k and 256k MSFs */
 17 /* Modified 750915 by PG to be able to attach to branches with many names */
 18 
 19 dcl  code2 fixed binary (35);                               /* Error code (returned). */
 20 dcl  pibp pointer;                                          /* Pointer to file control block. */
 21 dcl  ap pointer;                                            /* Temporary pointer. */
 22 dcl  b36 (0: 1) based fixed binary (35);                    /* Overlay to access thirtysix-bit elements (words). */
 23 dcl  bit_count fixed binary (24);                           /* Bits in segment or segments in directory. */
 24 dcl  bits_per_seg fixed bin (24);
 25 dcl  dname based character (168) aligned;                   /* Overlay for directory path name. */
 26 dcl  ename based character (32) aligned;                    /* Overlay for entry name. */
 27 dcl  entry character (32) aligned;                          /* Temporary for lower level entry name. */
 28 dcl  ep pointer;                                            /* Pointer to entry structure. */
 29 dcl  error_table_$bad_ms_file external fixed binary (35);
 30 dcl  error_table_$moderr external fixed binary (35);        /* File system error codes. */
 31 dcl  error_table_$noentry external fixed binary (35);
 32 dcl  error_table_$toomanylinks external fixed binary (35);
 33 dcl  error_table_$seg_unknown external fixed bin (35);
 34 dcl  i fixed bin;                                           /* Index. */
 35 dcl  infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */
 36 dcl  kind fixed binary (2);                                 /* Entry type. */
 37 dcl  max_length fixed bin (19);                             /* max length of component in words */
 38 dcl  msf_sw bit (3) aligned;                                /* bit switch for msf_manager_$adjust. */
 39 dcl  n fixed bin;                                           /* Temporary length. */
 40 dcl  p pointer;                                             /* Pointer to file control block. */
 41 dcl  path character (168) aligned;                          /* Aligned storage for path name. */
 42 dcl  suffix fixed binary;                                   /* Suffix of desired segment. */
 43 dcl  sys_info$max_seg_size ext fixed bin (19);              /* system maximum segment size in words */
 44 dcl  expand_path_ entry (pointer, fixed binary, pointer, pointer, fixed binary (35));
 45 dcl  hcs_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (19), fixed bin (35));
 46 dcl  hcs_$status_long entry (character (*) aligned, character (*) aligned, fixed binary (1), pointer,
 47      pointer, fixed binary (35));
 48 dcl  hcs_$status_minf entry (character (*) aligned, character (*) aligned, fixed binary (1),
 49      fixed binary (2), fixed binary (24), fixed binary (35));
 50 dcl  ioa_$rsnnl entry options (variable);                   /* Variable argument list. */
 51 dcl  msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)),
 52      msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)),
 53      msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3) aligned, fixed bin (35)),
 54      msf_manager_$close entry (ptr);
 55 
 56 dcl (addr, baseno, baseptr, bit, divide, fixed, empty, mod, null, substr) builtin;
 57 
 58 dcl 1 branch,                                               /* Branch structure filled by status_long. */
 59     2 ((dir, seg) bit (1), nnames bit (16), nrp bit (18)),  /* Type, number of names, pointer to names. */
 60     2 dtm bit (36),                                         /* Date-time segment modified. */
 61     2 dtu bit (36),                                         /* Date-time used. */
 62     2 ((t, r, e, w, a) bit (1), pad1 bit (13), records bit (18)), /* Mode, number of records. */
 63     2 dtd bit (36),                                         /* Date-time dumped. */
 64     2 dtem bit (36),                                        /* Date-time entry modified. */
 65     2 acct bit (36),                                        /* Account ID. */
 66     2 (curlen bit (12), bit_count bit (24)),                /* Current length, bit count. */
 67     2 ((did, mdid) bit (4), copysw bit (1), pad2 bit (9), rb (3) bit (6)), /* Dev. ID's, copy sw., rings. */
 68     2 uid bit (36);                                         /* Unique ID. */
 69 
 70 /* Single element from file control block. */
 71 % include file_pib;
 72 dcl 1 seg1 based aligned,                                   /* Overlay for word of ring memory. */
 73     2 (no bit (18), used bit (1), key bit (17)) unaligned;
 74                                                             /* ^L */
 75 file_util$attach_file:                                      /* Entry to attach file */
 76           entry (pibp, code2);
 77           p = pibp;                                         /* Copy pointer to file control block. */
 78           ap = addr (p -> pib.device_name.name_string);     /* Get pointer to input string. */
 79           n = p -> pib.device_name.name_size;               /* Compute total number of characters. */
 80           ep = addr (branch);                               /* Get pointer to branch structure. */
 81           call expand_path_ (ap, n, addr (p -> pib.dir_name), addr (p -> pib.entry_name), code2);
 82           if code2 ^= 0 then                                /* Error in path name? */
 83                do;                                          /* Yes. */
 84                p -> pib.call = 1;                           /* Mark place of failure. */
 85                return;                                      /* Give error return. */
 86           end;
 87           call hcs_$status_long (p -> pib.dir_name, p -> pib.entry_name, 1, ep, null, code2);
 88           if code2 ^= 0 then                                /* Some error? */
 89                do;                                          /* Yes. */
 90                if code2 = error_table_$noentry then         /* Is the entry missing? */
 91                     if p -> pib.w then                      /* Can we create it? */
 92                          do;                                /* Yes. */
 93                          p -> pib.level = ""b;              /* File is at top level. */
 94                                                             /* Initialize actual length. */
 95                          p -> pib.writebit, p -> pib.lastbit = 0;
 96                          p -> pib.bits_per_segment = sys_info$max_seg_size * 36;
 97                          go to attach_common;               /* Go do common stuff. */
 98                     end;
 99                p -> pib.call = 2;                           /* Mark point of failure. */
100                return;                                      /* Call foul. */
101           end;
102           if branch.seg then                                /* Is the entry a segment? */
103                do;                                          /* Yes. */
104                                                             /* Check for requested mode. */
105                if ^ branch.r & p -> pib.r | ^ branch.w & p -> pib.w then
106                     do;                                     /* No. */
107                     code2 = error_table_$moderr;            /* Report discrepancy. */
108                     return;
109                end;
110                p -> pib.level = ""b;                        /* File is at upper level. */
111                                                             /* Set write, last pointers according to bit count. */
112                p -> pib.writebit, p -> pib.lastbit = fixed (branch.bit_count, 35);
113                call hcs_$get_max_length (p -> pib.dir_name, p -> pib.entry_name, max_length, code2);
114                if code2 ^= 0 then do;
115                     p -> pib.call = 3;
116                     return;
117                end;
118                p -> pib.bits_per_segment = max_length * 36;
119                go to attach_common;                         /* Go set other initial values. */
120           end;
121           if branch.dir then                                /* Is the entry a directory? */
122                do;                                          /* Yes. */
123                suffix = fixed (branch.bit_count, 24) - 1;   /* Get suffix of last segment. */
124                if suffix < 0 then                           /* Was "bit count" zero? */
125                     do;                                     /* Yes. */
126                     suffix = 0;                             /* Set number of complete segments to zero. */
127                     go to attach_length_zero;               /* Continue attach of zero-length file. */
128                end;
129                call create_lower_level_names (null, suffix, addr (path), addr (entry));
130                                                             /* Examine statistics. */
131                call hcs_$status_minf (path, entry, 0, kind, bit_count, code2);
132                if code2 ^= 0 then                           /* Successful? */
133                     do;                                     /* No. */
134                     if code2 = error_table_$noentry then    /* Is segment missing? */
135                          if p -> pib.w then                 /* May we create it? */
136                               do;                           /* Yes. */
137 attach_length_zero:           bit_count = 0;                /* Assume zero bits in this segment. */
138                               max_length = sys_info$max_seg_size; /* And system maximum for max length */
139                               go to attach_lower_level;     /* Go compute total bit count. */
140                          end;
141                     p -> pib.call = 4;                      /* Mark point of failure. */
142                     return;                                 /* Reflect error. */
143                end;
144                if kind ^= 1 then                            /* Is this a segment? */
145                     do;                                     /* No. */
146                     code2 = error_table_$bad_ms_file;       /* Set error code. */
147                     return;                                 /* Give error return. */
148                end;
149                call hcs_$get_max_length (path, entry, max_length, code2);
150                if code2 ^= 0 then do;
151                     p -> pib.call = 5;
152                     return;
153                end;
154 attach_lower_level: p -> pib.level = "1"b;                  /* File is at lower level. */
155                                                             /* Set up current size. */
156                p -> pib.bits_per_segment = max_length * 36;
157                p -> pib.writebit, p -> pib.lastbit = p -> pib.bits_per_segment * suffix + bit_count;
158                go to attach_common;                         /* Do common initialization. */
159           end;
160           code2 = error_table_$toomanylinks;
161           return;
162 
163 attach_common:                                              /* Some of this initialization should be moved to caller. */
164           p -> pib.changed = ""b;                           /* Mark bit count as as yet unchanged. */
165           p -> pib.elsize = 9;                              /* Default size is one character. */
166           p -> pib.readbit = 0;                             /* Begin reading from beginning. */
167           p -> pib.highbit = p -> pib.lastbit;
168           p -> pib.boundbit = infinity - mod (infinity, 9); /* Default bound is 2 .P. 35 - 1. */
169           p -> pib.lastcomp = -1;                           /* init lastcomp to null */
170           p -> pib.lastseg = null;                          /* init ptr null too */
171           ap = addr (p -> pib.seg);                         /* Get pointer to ring memory. */
172           do i = 0 to 9;                                    /* Initialize each element. */
173                ap -> b36 (i) = 011111111111111111b;         /* Not used, null key. */
174           end;
175           p -> pib.search_type = 1;                         /* Special case of delimiter search. */
176           p -> pib.nreads = 1;                              /* Default is one read delimiter.. */
177           substr (p -> pib.readlist, 1, 9) = "000001010"b;  /* .. a new-line character. */
178 
179           call msf_manager_$open (p -> pib.dir_name, p -> pib.entry_name, p -> pib.fcb_ptr,
180                code2);
181           if code2 = error_table_$noentry then code2 = 0;
182 
183           return;                                           /* Return to caller. */
184                                                             /* ^L */
185 file_util$detach_file:                                      /* Entry to detach file. */
186           entry (pibp, code2);                              /* Returns IO system formatted codes. */
187           p = pibp;                                         /* Copy pointer to control data. */
188           bits_per_seg = p -> pib.bits_per_segment;
189           suffix = divide (p -> pib.lastbit, bits_per_seg, 17, 0); /* calc number of last segment. */
190           bit_count = mod (p -> pib.lastbit, bits_per_seg); /* bit count for last seg */
191           msf_sw = p -> pib.changed || p -> pib.changed || "1"b; /* this switch controls $adjust */
192 
193           call msf_manager_$adjust (p -> pib.fcb_ptr, suffix, bit_count, msf_sw, code2);
194                                                             /* call to adjust last bit count and terminate all segs */
195           if code2 ^= 0 then
196                if code2 ^= error_table_$seg_unknown
197                & code2 ^= error_table_$noentry then return;
198 
199           call msf_manager_$close (p -> pib.fcb_ptr);
200           p -> pib.fcb_ptr = null;
201 
202           code2 = 0;                                        /* Detach successful. */
203           return;                                           /* Return to caller. */
204                                                             /* ^L */
205 find_seg_ptr:                                               /* Entry to get pointer to segment. */
206           entry (pibp, bv_can_create, which, seg, code5);   /* Returns raw codes. */
207 
208 /* parameters */
209 
210 dcl  bv_can_create bit (1) aligned parameter;               /* ON if missing component can be created */
211 dcl  which fixed binary;                                    /* Number of desired segment in file. */
212 dcl  seg pointer;                                           /* Pointer to segment (returned). */
213 dcl  code5 fixed binary (35);                               /* Error code (returned). */
214 
215           p = pibp;                                         /* Copy pointer to control block. */
216           i = mod (which, 10);                              /* Look in the ring memory. */
217           ap = addr (p -> pib.seg (i));                     /* Get pointer to appropriate word. */
218           if ^ap -> seg1.used then goto skip_ck;            /* Is this entry in use? */
219           if fixed (ap -> seg1.key, 17) = which then        /* Is this it? */
220                do;                                          /* Yes. */
221                seg = baseptr (ap -> seg1.no);               /* Make up pointer to segment. */
222                go to have_seg;                              /* Give normal return. */
223           end;
224 skip_ck:                                                    /* Call msf_manager_ to get ptr to component */
225 
226           call msf_manager_$get_ptr (p -> pib.fcb_ptr, which, (bv_can_create & p -> pib.w), seg, bit_count, code5);
227           if seg = null then return;                        /* Return with code5 set to reason */
228 
229           ap = addr (p -> pib.seg (i));
230           ap -> seg1.no = baseno (seg);
231           ap -> seg1.key = bit (which, 17);
232 
233 /* set entry in ring memory */
234 
235 have_seg: ap -> seg1.used = "1"b;                           /* Indicate recent use of this segment. */
236           code5 = 0;                                        /* No error: clear code. */
237           return;                                           /* Return to caller. */
238                                                             /* ^L */
239 create_lower_level_names:                                   /* Procedure to make up names of "multi"-segments. */
240           procedure (enp1, suffix, path, entry);
241 dcl  enp1 pointer,                                          /* Pointer to entry name to append to directory name. */
242      suffix fixed binary,                                   /* Suffix desired on entry name. */
243     (path,                                                  /* Pointer to storage for directory path name. */
244      entry) pointer,                                        /* Pointer to storage for entry name. */
245      n fixed bin,                                           /* Length of resultant string (ignored). */
246      enp pointer;                                           /* Pointer to entry name in control block. */
247 
248                if path ^= null then                         /* Is directory path name wanted? */
249                     do;                                     /* Yes. */
250                     enp = enp1;                             /* Copy pointer to desired entry name. */
251                     if enp = null then                      /* If none, use entry name in control block. */
252                          enp = addr (p -> pib.entry_name);  /* .. */
253                     if substr (p -> pib.dir_name, 1, 4) = ">   " then /* Is it the root directory? */
254                          call ioa_$rsnnl (">^a", path -> dname, n, enp -> ename);
255                     else
256                     call ioa_$rsnnl ("^a>^a", path -> dname, n, p -> pib.dir_name, enp -> ename);
257                end;
258                if entry ^= null then                        /* Is entry name desired? */
259                     call ioa_$rsnnl ("^d", entry -> ename, n, suffix);
260           end create_lower_level_names;                     /* Return to caller. */
261      end file_util;