1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1984 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 /****^  HISTORY COMMENTS:
 15   1) change(85-07-01,CLJones), approve(86-08-05,MCR7458),
 16      audit(86-06-30,EJSharpe), install(86-08-19,MR12.0-1120):
 17      Made damaged and dnzp switch setting respect ring brackets.
 18   2) change(88-03-14,Lippard), approve(88-05-02,MCR7881),
 19      audit(88-06-09,Fawcett), install(88-08-02,MR12.2-1074):
 20      Added audit_flag_path, for setting entry audit switch
 21      (to cause generation of audit messages for all accesses to the
 22      object.
 23                                                    END HISTORY COMMENTS */
 24 
 25 
 26 /* format: style4 */
 27 set:
 28      proc;
 29 
 30 /* Modified October 1984, Keith Loepere, for auditing info;
 31 also to not allow the setting of bc for upgraded dirs. */
 32 /* Modified June 1984, Keith Loepere, to use the new dc_find. */
 33 /* Modified February 1984, Lindsey Spratt, changed the dm_gino check to be against the write bracket instead of the read bracket. */
 34 /* Modified August 1983, E. N. Kittlitz, setfaults$if_active pvid, vtocx args */
 35 /* Modified March 1983, E. N. Kittlitz, never set dtem back, delete tpd */
 36 /* Modified February 1983, E. N. Kittlitz, 256K max length. */
 37 /* Modified 30 July, 1981, W. Olin Sibert, to change the rules for damaged switch setting */
 38 /* Modified 800409 by PG to add change_bc entries for WOS */
 39 /* Modified 800314 by PG to add entries to set dnzp switch */
 40 /* Modified 07/18/79 by Steve Webber to disallow setting bit count on directories given a pointer */
 41 /* Modified by D.Vinograd 6/76 to add entry to set volume dump control switches */
 42 /* Modified 05/31/76 by R. Bratt to call find_$finished when done */
 43 /* Modified 04/20/76 by R. Bratt to check mountedness of LV */
 44 /* Modified by R. Bratt for setting branch tpd */
 45 /* Modified for NSS 4/75 by THVV: remove actind, use vtoc/aste */
 46 /* Modified by Kobziar 9/74 to call appropriate entry in access_mode */
 47 /* Modified by E. Stone to add entries to change the entry point bound - Aug 1974 */
 48 /* Modified on 12-4-73 by Kobziar to not check for append perm. to set bc */
 49 
 50 /* parameters */
 51 
 52 dcl  a_audit_flag bit (1) aligned parameter;
 53 dcl  a_auth char (*) parameter;
 54 dcl  a_bitct fixed bin (24) parameter;
 55 dcl  1 a_btimes aligned like based_btimes;
 56 dcl  a_chasesw fixed bin (1) parameter;
 57 dcl  a_code fixed bin (35) parameter;
 58 dcl  a_copy fixed bin (1) parameter;
 59 dcl  a_damaged_sw bit (1) parameter;
 60 dcl  a_date bit (36) parameter;
 61 dcl  a_datep ptr parameter;
 62 dcl  a_delta_bc fixed bin (24) parameter;
 63 dcl  a_dirname char (*) parameter;
 64 dcl  a_dtime fixed bin (52) parameter;                      /* time dumped */
 65 dcl  a_ename char (*) parameter;
 66 dcl  a_entry_bound fixed bin (14) parameter;
 67 dcl  a_max_length fixed bin (19) parameter;
 68 dcl  a_new_bc fixed bin (24) parameter;
 69 dcl  a_ncd fixed bin parameter;
 70 dcl  a_nid fixed bin parameter;
 71 dcl  a_old_bc fixed bin (24) parameter;
 72 dcl  a_safety_sw bit (1) parameter;
 73 dcl  a_segptr ptr parameter;
 74 dcl  a_setp ptr parameter;
 75 dcl  a_synchronized_sw bit (1) aligned parameter;
 76 
 77 /* based */
 78 
 79 dcl  1 a_reload_set_info aligned based like reload_set_info;
 80 dcl  1 based_time based aligned,
 81        2 dtem bit (36),
 82        2 dtd bit (36),
 83        2 dtu bit (36),
 84        2 dtm bit (36);
 85 
 86 dcl  1 based_btimes based aligned,                          /* times from backup */
 87        2 dtem fixed bin (52),
 88        2 dtd fixed bin (52),
 89        2 dtu fixed bin (52),
 90        2 dtm fixed bin (52);
 91 
 92 /* automatic */
 93 
 94 dcl  1 access_name aligned,                                 /* 3 part access name - used for author and bc_author */
 95        2 person char (32),
 96        2 project char (32),
 97        2 tag char (1);
 98 dcl  audit_flag bit (1) aligned;
 99 dcl  auth char (32) aligned;
100 dcl  authp ptr;
101 dcl  bitct fixed bin (24);
102 dcl  bs bit (1) aligned;
103 dcl  1 btimes aligned like based_btimes;
104 dcl  chasesw fixed bin (1);
105 dcl  check_rb bit (1) aligned;
106 dcl  code fixed bin (35);
107 dcl  copy fixed bin (1);
108 dcl  damaged_sw bit (1) aligned;
109 dcl  date bit (36);
110 dcl  delta_bc fixed bin (24);
111 dcl  detailed_operation fixed bin (18) uns;
112 dcl  dirname char (168);
113 dcl  dirsw bit (1) aligned;
114 dcl  dtm bit (36) aligned;
115 dcl  dtu bit (36) aligned;
116 dcl  ename char (32);
117 dcl  entry_bound fixed bin (14);
118 dcl  entry_type fixed bin;
119 dcl  find_was_called bit (1) aligned;
120 dcl  max_length fixed bin (19);
121 dcl  mxl fixed bin (9);
122 dcl  ncd fixed bin;
123 dcl  new_bc fixed bin (24);
124 dcl  nid fixed bin;
125 dcl  old_bc fixed bin (24);
126 dcl  1 pc_msk like vtoce_pc_sws aligned;
127 dcl  1 pc_val like vtoce_pc_sws aligned;
128 dcl  priv_ml bit (1) aligned init ("0"b);
129 dcl  pvid bit (36) aligned;
130 dcl  safety_sw bit (1) aligned;
131 dcl  segptr ptr;
132 dcl  setp ptr;
133 dcl  setting_for_reloader fixed bin init (0);
134 dcl  synchronized_sw bit (1) aligned;
135 dcl  1 time aligned like based_time;
136 dcl  uid bit (36) aligned;
137 dcl  val fixed bin (17);
138 dcl  vtocx fixed bin;
139 
140 /* constants */
141 
142 dcl  Normal_entry fixed bin init (1) static options (constant);
143 dcl  Set_bc_entry fixed bin init (2) static options (constant);
144 dcl  Change_bc_entry fixed bin init (3) static options (constant);
145 dcl  Dsw_entry fixed bin init (4) static options (constant);
146 dcl  Set_bc_entry_priv fixed bin init (5) static options (constant);
147 dcl  Normal_priv_entry fixed bin init (6) static options (constant);
148 
149 /* external static */
150 
151 dcl  error_table_$ai_restricted external fixed bin (35);
152 dcl  error_table_$argerr external fixed bin (35);
153 dcl  error_table_$bad_ring_brackets external fixed bin (35);
154 dcl  error_table_$dirseg external fixed bin (35);
155 dcl  error_table_$link external fixed bin (35);
156 dcl  error_table_$not_a_branch external fixed bin (35);
157 dcl  error_table_$not_dm_ring external fixed bin (35);
158 dcl  pds$access_name fixed bin (35) external;
159 dcl  1 pds$transparent ext aligned,
160        2 m bit (1) unaligned,
161        2 u bit (1) unaligned;
162 dcl  sys_info$data_management_ringno fixed bin external;
163 dcl  sys_info$seg_size_256K fixed bin (19) external;
164 
165 /* entries */
166 
167 dcl  acc_name_$delete entry (ptr);
168 dcl  acc_name_$elements entry (ptr, ptr, fixed bin (35));
169 dcl  acc_name_$encode entry (ptr, ptr, fixed bin (35));
170 dcl  change_dtem entry (ptr);
171 dcl  level$get returns (fixed bin (17));
172 dcl  lock$dir_unlock entry (pointer);
173 dcl  mountedp entry (bit (36) aligned) returns (fixed bin (35));
174 dcl  setfaults$if_active entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (1) aligned);
175 dcl  sum$dirmod entry (pointer);
176 dcl  vtoc_attributes$reloading entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (9), fixed bin (35));
177 dcl  vtoc_attributes$set_dates entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
178 dcl  vtoc_attributes$set_dump_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin, fixed bin, fixed bin (35));
179 dcl  vtoc_attributes$set_max_lth entry (bit (36) aligned, bit (36) aligned, fixed bin, fixed bin (9), bit (1) aligned, fixed bin (35));
180 dcl  vtoc_attributes$set_pc_switches entry (bit (36) aligned, bit (36) aligned, fixed bin, bit (36) aligned, bit (36) aligned, fixed bin (35));
181 
182 /* builtins */
183 
184 dcl  (addr, binary, bit, clock, fixed, divide, length, ptr, string, substr, unspec) builtin;
185 %page;
186 /* SET$COPYSW changes the setting of the copy switch in the branch effectively pointed to by
187    "entry" in the directory with path name "dirname" to "copy" if caller has
188    write permit in the directory. */
189 
190 copysw:
191      entry (a_dirname, a_ename, a_copy, a_code);
192 
193           detailed_operation = FS_OBJ_COPY_SW_MOD;
194           copy = a_copy;                                    /* must copy input arguments into stack before locking */
195           chasesw = 1;
196           check_rb = "1"b;
197           entry_type = Normal_entry;
198           call find_entry;
199           entry.copysw = bit (copy, 1);
200           go to finish;
201 %page;
202 /* SET$AUTH changes the auth variable in the entry "ename" in the directory pointed to by
203    the pathname "dirname" . The entry is "chased" if the chase switch is on. The caller must
204    have write permit on the directory. */
205 
206 auth:
207      entry (a_dirname, a_ename, a_chasesw, a_auth, a_code);
208 
209           detailed_operation = FS_OBJ_AUTHOR_MOD;
210           chasesw = a_chasesw;
211           auth = a_auth;
212           check_rb = "0"b;
213           entry_type = Normal_entry;
214           call find_entry;
215           authp = addr (entry.author);                      /* Get pointer to author. */
216 
217 set_auth:
218           call acc_name_$elements (addr (auth), addr (access_name), code);
219           if code ^= 0
220           then go to unlock;                                /* Break up author into 3 part access name. */
221           call acc_name_$delete (authp);                    /* Delete previous author if any */
222           call acc_name_$encode (authp, addr (access_name), code);
223           go to unlock;
224 %page;
225 /* SET$BC changes the setting of the bit count item in the branch effectively pointed
226    to by "entry" in the directory with path name "dirname" to "bitct"
227    if caller has execute permit in the directory and write
228    or append permit in the branch. */
229 
230 /* SET$BC_SEG is the same as set$bc except that it takes a pointer to a segment rather than
231    "dirname" and "entry" as input arguments.  */
232 
233 bc_seg_priv:
234      entry (a_segptr, a_bitct, a_code);                     /* privileged bitcount setting - no access check */
235 
236           entry_type = Set_bc_entry_priv;
237           go to bc_set_ptr_join;
238 
239 bc_seg:
240      entry (a_segptr, a_bitct, a_code);
241 
242           entry_type = Set_bc_entry;
243 
244 bc_set_ptr_join:
245           detailed_operation = FS_OBJ_BC_MOD;
246           bitct = a_bitct;                                  /* copy input args */
247           check_rb = "0"b;
248           call get_entry_ptr;
249           if dirsw
250           then                                              /* disallow setting bc on directory given pointer */
251                goto dirseg;
252 
253           go to set_bc;                                     /* Join common code. */
254 
255 bc:
256      entry (a_dirname, a_ename, a_bitct, a_code);
257 
258           detailed_operation = FS_OBJ_BC_MOD;
259           bitct = a_bitct;                                  /* must copy input arguments into stack before locking */
260           chasesw = 1;
261           check_rb = "0"b;
262           entry_type = Set_bc_entry;
263           call find_entry;
264 
265 set_bc:
266           if entry.dirsw then
267                if binary (entry.ring_brackets (1), 3) > 1 then
268                     if entry.multiple_class then            /* implies upgraded */
269                          go to ai_error;
270 
271           entry.bc = bitct;                                 /* actually set the bit count in the entry */
272 
273           call acc_name_$delete (addr (entry.bc_author));   /* set the bc author */
274           call acc_name_$encode (addr (entry.bc_author), addr (pds$access_name), code);
275 
276           go to finish;
277 %page;
278 /* SET$CHANGE_BC_PATH adds a specified amount to the bitcount, and returns the
279    old and new bitcount to the caller. It can be used by multiple processes
280    to synchronize their writing to an unstructured segment without any other
281    locking protocol. */
282 
283 change_bc_path:
284      entry (a_dirname, a_ename, a_delta_bc, a_old_bc, a_new_bc, a_code);
285 
286           detailed_operation = FS_OBJ_BC_MOD;
287           delta_bc = a_delta_bc;
288           chasesw = 1;
289           check_rb = "0"b;
290           entry_type = Change_bc_entry;
291           call find_entry;
292           go to change_bc;
293 
294 /* SET$CHANGE_BC_PTR is the same as set$change_bc_path except that it takes
295    a pointer to a segment. */
296 
297 change_bc_ptr:
298      entry (a_segptr, a_delta_bc, a_old_bc, a_new_bc, a_code);
299 
300           detailed_operation = FS_OBJ_BC_MOD;
301           delta_bc = a_delta_bc;
302           check_rb = "0"b;
303           entry_type = Change_bc_entry;
304           call get_entry_ptr;
305           if dirsw
306           then go to dirseg;
307 
308 change_bc:
309           old_bc = entry.bc;
310           new_bc, bitct = old_bc + delta_bc;
311           go to set_bc;
312 %page;
313 /* SET$DTD changes the setting of the date time dumped item in the branch effectively pointed to
314    by "entry" in the directory with path name "dirname" to "date"
315    if caller has write permit in the directory . */
316 
317 /* SET$BACKUP_DUMP_TIME is the same as set$dtd except that it takes a fixed bin (52)
318    time instead of a bit (36) file system time.  */
319 
320 dtd:
321      entry (a_dirname, a_ename, a_date, a_code);
322 
323           date = a_date;                                    /* must copy input argument into stack before locking */
324           entry_type = Normal_entry;
325           go to set_dtd;                                    /* Join common code. */
326 
327 backup_dump_time:
328      entry (a_dirname, a_ename, a_dtime, a_code);
329 
330           date = substr (bit (a_dtime, 52), 1, length (date)); /* copy and convert input argument */
331           entry_type = Normal_priv_entry;
332 
333 set_dtd:
334           detailed_operation = FS_OBJ_DT_DUMPED_MOD;
335           chasesw = 0;
336           check_rb = "0"b;
337           call find_entry;
338           if bs
339           then entry.dtd = date;
340           else link.dtd = date;
341           go to unlock;
342 %page;
343 /* SET$DATES changes the setting of the date time used, date time modified and date time entry modified
344    items in the branch effectively pointed to by "entry" in the directory with path name "dirname" to
345    "date" if caller has write permit in the directory. */
346 
347 dates:
348      entry (a_dirname, a_ename, a_datep, a_code);
349 
350           detailed_operation = FS_OBJ_DATES_MOD;
351           time = a_datep -> based_time;                     /* must copy input into stack before locking */
352           chasesw = 0;
353           check_rb = "0"b;
354           entry_type = Normal_entry;
355           call find_entry;
356           if bs then do;
357                uid = entry.uid;                             /* Extract unique ID */
358                pvid = entry.pvid;
359                vtocx = entry.vtocx;
360                dtu = time.dtu;
361                dtm = time.dtm;
362                if dirsw
363                then code = 0;                               /* assume RLV is always mounted */
364                else code = mountedp (dir.sons_lvid);        /* only if mounted! */
365                if code = 0
366                then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code);
367                if code ^= 0
368                then go to unlock;
369                entry.dtem = time.dtem;
370                entry.dtd = time.dtd;
371           end;
372           else do;
373                link.dtem = time.dtem;
374                link.dtd = time.dtd;
375           end;
376           go to unlock;
377 %page;
378 /* SET$DUMP_SWITCHES is used to set/reset the dump control switches  in the vtoce of
379    a branch. The two switches, no_complete_dump and no incremental dump are set on
380    if the input is positive, off if negative and not set if zero. */
381 
382 volume_dump_switches:
383      entry (a_dirname, a_ename, a_nid, a_ncd, a_code);
384 
385           detailed_operation = FS_OBJ_VOL_DUMP_SW_MOD;
386           chasesw = 1;
387           check_rb = "1"b;
388           ncd = a_ncd;
389           nid = a_nid;
390           entry_type = Normal_entry;
391           call find_entry;
392           if bs then do;
393                uid = entry.uid;
394                pvid = entry.pvid;
395                vtocx = entry.vtocx;
396                if dirsw
397                then code = error_table_$dirseg;
398                else code = mountedp (dir.sons_lvid);
399                if code = 0
400                then call vtoc_attributes$set_dump_switches (uid, pvid, vtocx, nid, ncd, code);
401           end;
402           else code = error_table_$link;
403           goto unlock;
404 %page;
405 /* SET$BACKUP_TIMES is used by the reloading process to set the following
406    items in a directory branch: date-time entry modified,
407    date-time dumped, date-time used, date-time modified.  */
408 
409 backup_times:
410      entry (a_dirname, a_ename, a_btimes, a_code);
411 
412           detailed_operation = FS_OBJ_BACKUP_TIMES_MOD;
413           btimes = a_btimes;                                /* copy structure argument */
414           chasesw = 0;
415           check_rb = "0"b;
416           entry_type = Normal_entry;
417           call find_entry;
418           if bs then do;
419                uid = entry.uid;                             /* Extract unique ID */
420                pvid = entry.pvid;
421                vtocx = entry.vtocx;
422                dtu = substr (bit (btimes.dtu, 52), 1, length (dtu));
423                dtm = substr (bit (btimes.dtm, 52), 1, length (dtm));
424                if dirsw
425                then code = 0;                               /* assume RLV always mounted */
426                else code = mountedp (dir.sons_lvid);        /* only if mounted! */
427                if code = 0
428                then call vtoc_attributes$set_dates (uid, pvid, vtocx, dtu, dtm, code);
429                if code ^= 0
430                then go to unlock;
431                entry.dtem = substr (bit (btimes.dtem, 52), 1, length (entry.dtem));
432                entry.dtd = substr (bit (btimes.dtd, 52), 1, length (entry.dtd));
433           end;
434           else do;
435                link.dtem = substr (bit (btimes.dtem, 52), 1, length (link.dtem));
436                link.dtd = substr (bit (btimes.dtd, 36), 1, length (link.dtd));
437           end;
438           go to unlock;
439 %page;
440 /* SET$SAFETY_SWITCH_PTR changes the safety switch in the directory entry corresponding
441    to the pointer "segptr".  */
442 
443 /* SET$_SAFETY_SWITCH_PATH is identical to set$safety_switch pointer except that
444    the "ename" and "dirname" are specified instead of a segment pointer.  */
445 
446 safety_sw_ptr:
447      entry (a_segptr, a_safety_sw, a_code);
448 
449           detailed_operation = FS_OBJ_SAFETY_SW_MOD;
450           safety_sw = a_safety_sw;
451           check_rb = "1"b;
452           entry_type = Normal_entry;
453           call get_entry_ptr;
454           go to set_safety;                                 /* Join common code. */
455 
456 safety_sw_path:
457      entry (a_dirname, a_ename, a_safety_sw, a_code);
458 
459           detailed_operation = FS_OBJ_SAFETY_SW_MOD;
460           safety_sw = a_safety_sw;
461           chasesw = 1;
462           check_rb = "1"b;
463           entry_type = Normal_entry;
464           call find_entry;
465 
466 set_safety:
467           entry.safety_sw = safety_sw;
468           go to finish;
469 %page;
470 /* SET$AUDIT_FLAG_PATH changes the audit switch in the directory entry for
471    the specified path. */
472 
473 audit_flag_path:
474      entry (a_dirname, a_ename, a_audit_flag, a_code);
475 
476           detailed_operation = FS_OBJ_AUDIT_FLAG_MOD;
477           audit_flag = a_audit_flag;
478           chasesw = 1;
479           check_rb = "1"b;
480           entry_type = Normal_entry;
481           call find_entry;
482 
483 set_audit_flag:
484           entry.audit_flag = audit_flag;
485           go to finish;
486 %page;
487 /* SET$DAMAGED_SW_PTR changes the damaged switch in the directory entry corresponding
488    to the pointer "segptr".  */
489 
490 /* SET$DAMAGED_SW_PATH is identical to set$damaged_sw_ptr except that
491    the "ename" and "dirname" are specified instead of a segment pointer.  */
492 
493 damaged_sw_ptr:
494      entry (a_segptr, a_damaged_sw, a_code);
495 
496           detailed_operation = FS_OBJ_DAMAGED_SW_MOD;
497           damaged_sw = a_damaged_sw;
498           check_rb = "1"b;
499           entry_type = Dsw_entry;
500           call get_entry_ptr;
501           go to set_damaged;                                /* Join common code. */
502 
503 damaged_sw_path:
504      entry (a_dirname, a_ename, a_damaged_sw, a_code);
505 
506           detailed_operation = FS_OBJ_DAMAGED_SW_MOD;
507           damaged_sw = a_damaged_sw;
508           chasesw = 1;
509           check_rb = "1"b;
510           entry_type = Dsw_entry;
511           call find_entry;
512 
513 set_damaged:
514           unspec (pc_val) = ""b;
515           unspec (pc_msk) = ""b;
516           pc_val.damaged = damaged_sw;
517           pc_msk.damaged = "1"b;
518           uid = entry.uid;
519           pvid = entry.pvid;
520           vtocx = entry.vtocx;
521           if dirsw
522           then code = 0;
523           else code = mountedp (dir.sons_lvid);
524           if code = 0
525           then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
526           if code ^= 0
527           then go to unlock;
528           go to finish;
529 %page;
530 /* SET$DNZP_SW_PTR changes the dnzp switch in the directory entry corresponding
531    to the pointer "segptr".  */
532 
533 /* SET$DNZP_SW_PATH is identical to set$dnzp_sw_ptr except that
534    the "ename" and "dirname" are specified instead of a segment pointer.  */
535 
536 /* parameters */
537 
538 declare  a_dnzp_sw bit (1) aligned parameter;
539 
540 /* automatic */
541 
542 declare  dnzp_sw bit (1) aligned;
543 
544 /* program */
545 
546 dnzp_sw_ptr:
547      entry (a_segptr, a_dnzp_sw, a_code);
548 
549           detailed_operation = FS_OBJ_DNZP_MOD;
550           dnzp_sw = a_dnzp_sw;
551           check_rb = "1"b;
552           entry_type = Normal_entry;
553           call get_entry_ptr;
554           go to set_dnzp;                                   /* Join common code. */
555 
556 dnzp_sw_path:
557      entry (a_dirname, a_ename, a_dnzp_sw, a_code);
558 
559           detailed_operation = FS_OBJ_DNZP_MOD;
560           dnzp_sw = a_dnzp_sw;
561           chasesw = 1;
562           check_rb = "1"b;
563           entry_type = Normal_entry;
564           call find_entry;
565 
566 set_dnzp:
567           if dirsw
568           then go to dirseg;                                /* Oh no you don't */
569 
570           unspec (pc_val) = ""b;
571           unspec (pc_msk) = ""b;
572           pc_val.dnzp = dnzp_sw;
573           pc_msk.dnzp = "1"b;
574           uid = entry.uid;
575           pvid = entry.pvid;
576           vtocx = entry.vtocx;
577           if dirsw
578           then code = 0;
579           else code = mountedp (dir.sons_lvid);
580           if code = 0
581           then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
582           if code ^= 0
583           then go to unlock;
584           go to finish;
585 %page;
586 /* SET$SYNCHRONIZED_SW changes the synchronized switch in the VTOCE
587    corresponding to the path supplied. This is used by Data Management
588    to order writes done by Page Control. */
589 
590 synchronized_sw:
591      entry (a_dirname, a_ename, a_synchronized_sw, a_code);
592 
593           detailed_operation = FS_OBJ_SYNC_SW_MOD;
594           synchronized_sw = a_synchronized_sw;
595           chasesw = 0;
596           check_rb = "1"b;
597           entry_type = Normal_entry;
598           call find_entry;
599 
600           if dirsw
601           then goto dirseg;
602 
603           if fixed (entry.ring_brackets (1), 3) > sys_info$data_management_ringno
604           then do;
605                code = error_table_$not_dm_ring;
606                goto unlock;
607           end;
608 
609           unspec (pc_val) = ""b;
610           unspec (pc_msk) = ""b;
611           pc_val.synchronized = synchronized_sw;
612           pc_msk.synchronized = "1"b;
613           uid = entry.uid;
614           pvid = entry.pvid;
615           vtocx = entry.vtocx;
616           code = mountedp (dir.sons_lvid);
617           if code = 0
618           then call vtoc_attributes$set_pc_switches (uid, pvid, vtocx, string (pc_val), string (pc_msk), code);
619           if code ^= 0 then goto unlock;
620           goto finish;
621 %page;
622 /* SET$MAX_LENGTH_PTR resets the maximum length of the segment pointed to
623    by "segptr" to the "max_length" specified in words.  */
624 
625 /* SET$MAX_LENGTH_PATH is identical to set$max_length_ptr except that the
626    "ename" and "dirname" of the segment are sepcified instead of the "segptr".  */
627 
628 max_length_ptr:
629      entry (a_segptr, a_max_length, a_code);
630 
631           detailed_operation = FS_OBJ_MAX_LEN_MOD;
632           max_length = a_max_length;
633           check_rb = "1"b;
634           entry_type = Normal_entry;
635           call get_entry_ptr;
636           go to set_max_length;
637 
638 max_length_priv:
639      entry (a_dirname, a_ename, a_max_length, a_code);
640 
641           priv_ml = "1"b;
642           check_rb = "0"b;
643           goto cp_ml_args;
644 
645 max_length_path:
646      entry (a_dirname, a_ename, a_max_length, a_code);
647           check_rb = "1"b;
648 
649 cp_ml_args:
650           detailed_operation = FS_OBJ_MAX_LEN_MOD;
651           max_length = a_max_length;
652           chasesw = 1;
653           entry_type = Normal_entry;
654           call find_entry;
655 
656 set_max_length:
657           if dirsw
658           then go to dirseg;
659           if max_length < 0
660           then go to argerr;
661           if max_length > sys_info$seg_size_256K
662           then go to argerr;
663           uid = entry.uid;                                  /* Extract unique ID */
664           pvid = entry.pvid;
665           vtocx = entry.vtocx;
666           mxl = divide (max_length + 1023, 1024, 9, 0);     /* Correct units */
667           code = mountedp (dir.sons_lvid);
668           if code = 0
669           then call vtoc_attributes$set_max_lth (uid, pvid, vtocx, mxl, priv_ml, code);
670           if code ^= 0
671           then go to unlock;
672           go to finish;
673 %page;
674 /* SET$BC_AUTH_PATH is used by the reloader to set the bitcount author of the
675    directory entry corresponding to the segment indicated by "ename" and
676    "dirname". */
677 
678 bc_auth_path:
679      entry (a_dirname, a_ename, a_auth, a_code);
680 
681           detailed_operation = FS_OBJ_BC_AUTHOR_MOD;
682           auth = a_auth;
683           chasesw = 1;
684           check_rb = "0"b;
685           entry_type = Normal_entry;
686           call find_entry;                                  /* no AIM check since privileged entry */
687 
688           authp = addr (entry.bc_author);                   /* Get pointer to bit count author. */
689           go to set_auth;                                   /* Join common author-setting code. */
690 %page;
691 /* SET$ENTRY_BOUND_PTR sets the entry point bound switch and changes the
692    entry point bound of the segment pointed to by "segptr" to the "entry_bound"
693    specified in words if "entry_bound" is greater than 0.
694    If "entry_bound" equals 0, then the entry point bound switch is reset and
695    the entry point bound is changed to 0. */
696 
697 /* SET$ENTRY_BOUND_PATH is identical to set$entry_point_ptr except that
698    then "dirname" and "ename" of the segment are specified instead of the "segptr". */
699 
700 entry_bound_ptr:
701      entry (a_segptr, a_entry_bound, a_code);
702 
703           detailed_operation = FS_OBJ_ENTRY_BOUND_MOD;
704           entry_bound = a_entry_bound;
705           check_rb = "1"b;
706           entry_type = Normal_entry;
707           call get_entry_ptr;
708           go to set_call_limiter;
709 
710 entry_bound_path:
711      entry (a_dirname, a_ename, a_entry_bound, a_code);
712 
713           detailed_operation = FS_OBJ_ENTRY_BOUND_MOD;
714           entry_bound = a_entry_bound;
715           chasesw = 1;
716           check_rb = "1"b;
717           entry_type = Normal_entry;
718           call find_entry;
719 
720 set_call_limiter:
721           if dirsw
722           then go to dirseg;
723           if entry_bound < 0
724           then go to argerr;                                /* Limited to 14 bits in sdw */
725           if entry_bound > 16383
726           then go to argerr;
727           uid = entry.uid;
728           pvid = entry.pvid;
729           vtocx = entry.vtocx;
730           call setfaults$if_active (uid, pvid, vtocx, "0"b);
731           if entry_bound = 0 then do;
732                entry.entrypt_sw = "0"b;
733                entry.entrypt_bound = "0"b;
734           end;
735           else do;
736                entry.entrypt_sw = "1"b;
737                entry.entrypt_bound = bit (entry_bound, 14);
738           end;
739           go to finish;
740 %page;
741 /* SET$SET_FOR_RELOADER  changes a number of variables in the entry "ename" in
742    the directory pointed to by the pathname "dirname".
743    It also makes one call to set appropriate items in the VTOC.
744    The entry is not chased.    The caller must have write permit
745    on the directory.  It is intended that that this entry in set
746    provide the sum of the functionality of a number of other entries:
747    that is the usual checks are made and status codes are returned.
748    Because this entry can only be reached through a priviliged gate,
749    the max_length is not checked against the current length ---
750    this is not only consistent with the privileged set_max_length entry,
751    but also with the fact that the dumper will never write more
752    meaningfull data than "max_length" to tape */
753 
754 set_for_reloader:
755      entry (a_dirname, a_ename, a_setp, a_code);
756 
757           detailed_operation = FS_OBJ_FOR_RELOADER_MOD;
758           setp = a_setp;
759           reload_set_info = setp -> a_reload_set_info;      /* copy input before locking */
760           if reload_set_info.version ^= reload_set_version_2 then do;
761                                                             /* called with bad structure */
762                a_code = error_table_$argerr;
763                return;
764           end;
765           setting_for_reloader = 1;                         /* remember to return info */
766           chasesw = 0;
767           check_rb = "0"b;
768           entry_type = Normal_priv_entry;
769           call find_entry;
770           uid = entry.uid;                                  /* Extract unique ID */
771           pvid = entry.pvid;
772           vtocx = entry.vtocx;
773 
774           if ^bs then do;
775                code = error_table_$not_a_branch;
776                go to unlock;
777           end;
778 
779           if reload_set_info.should_set.safety_sw
780           then                                              /* set the safety_sw? */
781                entry.safety_sw = reload_set_info.safety_sw;
782 
783           if reload_set_info.should_set.audit_flag
784           then                                              /* set the audit_flag? */
785                entry.audit_flag = reload_set_info.audit_flag;
786 
787 
788 
789           if reload_set_info.should_set.author then do;     /* author? */
790                authp = addr (entry.author);
791                call acc_name_$elements (addr (reload_set_info.author), addr (access_name), reload_set_info.author_code);
792                if reload_set_info.author_code = 0 then do;  /* if no errs proceed */
793                     call acc_name_$delete (authp);
794                     call acc_name_$encode (authp, addr (access_name), reload_set_info.author_code);
795                end;
796           end;
797 
798           if reload_set_info.should_set.bc_author then do;  /* no AIM check since privileged entry */
799                authp = addr (entry.bc_author);
800                call acc_name_$elements (addr (reload_set_info.bc_author), addr (access_name),
801                     reload_set_info.bc_author_code);
802                if reload_set_info.bc_author_code = 0 then do;
803                     call acc_name_$delete (authp);
804                     call acc_name_$encode (authp, addr (access_name), reload_set_info.bc_author_code);
805                end;
806           end;
807 
808 /* Now for the tricky part */
809 /* go to vtoc to set dtm,dtu,mxl */
810 /* if go to vtoc for mxl,  need not do setfaults here */
811 /* even if setting entry_bound */
812 
813           if reload_set_info.should_set.dtu
814           then dtu = reload_set_info.dtu;                   /* dtu = 0 means va$ wont set */
815           else dtu = "0"b;
816 
817           if reload_set_info.should_set.dtm
818           then dtm = reload_set_info.dtm;                   /* dtm = 0 means va$ wont set */
819           else dtm = "0"b;
820 
821           mxl = -1;                                         /* mxl = -1 means va$ wont set, dont setfaults */
822           if reload_set_info.should_set.max_length then do;
823                if dirsw
824                then reload_set_info.max_length_code = error_table_$dirseg;
825                                                             /* make some checks */
826                else if reload_set_info.max_length < 0
827                then reload_set_info.max_length_code = error_table_$argerr;
828                else mxl = divide (reload_set_info.max_length + 1023, 1024, 9, 0);
829           end;
830 
831           if dtm | dtu | mxl >= 0 then do;                  /* something to set in vtoc */
832                if dirsw
833                then code = 0;                               /* RLV always mounted */
834                else code = mountedp (dir.sons_lvid);        /* check mountedness */
835                if code = 0
836                then call vtoc_attributes$reloading (uid, pvid, vtocx, dtu, dtm, mxl, code);
837                                                             /*  NOTE: for  now we are punting the no mounted case */
838           end;                                              /* vtoc_attr has done setfaults if mxl >= 0 */
839 
840           if reload_set_info.should_set.entry_bound then do;/* see about epb */
841                if dirsw
842                then reload_set_info.entry_bound_code = error_table_$dirseg;
843                else if reload_set_info.entry_bound < 0
844                then reload_set_info.entry_bound_code = error_table_$argerr;
845                else if reload_set_info.entry_bound > 16383
846                then reload_set_info.entry_bound_code = error_table_$argerr;
847                else do;                                     /* we are willing to set it */
848                     if mxl < 0 | code ^= 0
849                     then                                    /* do setfault now, if not already done */
850                          call setfaults$if_active (uid, pvid, vtocx, "0"b);
851                     if reload_set_info.entry_bound = 0 then do;
852                                                             /* clear relevant fields */
853                          entry.entrypt_sw = "0"b;
854                          entry.entrypt_bound = "0"b;
855                     end;
856                     else do;
857                          entry.entrypt_sw = "1"b;
858                          entry.entrypt_bound = bit (reload_set_info.entry_bound, 14);
859                     end;
860                end;
861           end;
862 
863           if reload_set_info.should_set.dtem
864           then                                              /* date time entry modified? */
865                entry.dtem = reload_set_info.dtem;
866 
867           if reload_set_info.should_set.dtd
868           then                                              /* date time dumped? */
869                entry.dtd = reload_set_info.dtd;
870 
871           go to finish;
872 %page;
873 /* Update dtem, unlock entry, notify segment control that directory containing
874    entry has been modified and return */
875 
876 finish:
877           if pds$transparent.m = "0"b
878           then if entry.dtem ^= bit (binary (clock (), 52), 36)
879                then call change_dtem (ep);
880 
881 unlock:
882           call sum$dirmod (dp);
883           if find_was_called
884           then call dc_find$finished (dp, "1"b);
885           else call lock$dir_unlock (dp);
886 
887           if setting_for_reloader ^= 0
888           then setp -> a_reload_set_info = reload_set_info;
889           else if entry_type = Change_bc_entry then do;
890                a_old_bc = old_bc;
891                a_new_bc = new_bc;
892           end;
893 
894 finale:
895           a_code = code;
896           return;
897 
898 /* Error Handling */
899 
900 ai_error:
901           code = error_table_$ai_restricted;
902           go to unlock;
903 
904 argerr:
905           code = error_table_$argerr;
906           go to unlock;
907 
908 dirseg:
909           code = error_table_$dirseg;
910           go to unlock;
911 
912 bracket_error:
913           code = error_table_$bad_ring_brackets;
914           goto unlock;
915 %page;
916 /* internal procedures */
917 
918 find_entry:
919      proc;                                                  /* get a pointer to the entry and lock the directory */
920 
921           code = 0;
922           dirname = a_dirname;
923           ename = a_ename;
924           if entry_type = Normal_entry then
925                call dc_find$obj_status_write (dirname, ename, chasesw, detailed_operation, ep, code);
926           else if entry_type = Set_bc_entry then
927                call dc_find$obj_bc_write (dirname, ename, bitct, ep, code);
928           else if entry_type = Change_bc_entry then
929                call dc_find$obj_bc_delta_write (dirname, ename, delta_bc, ep, code);
930           else if entry_type = Dsw_entry then               /* allow no m on parent */
931                call dc_find$obj_attributes_write (dirname, ename, chasesw, detailed_operation, ep, code);
932           else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then
933                call dc_find$obj_status_write_priv (dirname, ename, chasesw, detailed_operation, ep, code);
934           dp = ptr (ep, 0);
935           if code ^= 0
936           then go to finale;
937           find_was_called = "1"b;
938           go to check;
939 
940 get_entry_ptr:
941      entry;                                                 /* get a pointer to the entry and lock the directory */
942 
943           code = 0;
944           segptr = a_segptr;
945           find_was_called = "0"b;
946           if entry_type = Normal_entry then
947                call dc_find$obj_status_write_ptr (segptr, detailed_operation, ep, code);
948           else if entry_type = Set_bc_entry then
949                call dc_find$obj_bc_write_ptr (segptr, bitct, ep, code);
950           else if entry_type = Change_bc_entry then
951                call dc_find$obj_bc_delta_write_ptr (segptr, delta_bc, ep, code);
952           else if entry_type = Dsw_entry then               /* allow no m on parent */
953                call dc_find$obj_attributes_write_ptr (segptr, detailed_operation, ep, code);
954           else if entry_type = Set_bc_entry_priv | entry_type = Normal_priv_entry then
955                call dc_find$obj_status_write_priv_ptr (segptr, detailed_operation, ep, code);
956           dp = ptr (ep, 0);
957           if code ^= 0
958           then go to finale;
959 
960 check:
961           bs = entry.bs;
962           dirsw = entry.dirsw;
963           if check_rb then do;                              /* also need to check ring brackets */
964                val = level$get ();
965                if dirsw then do;
966                     if val > fixed (entry.ex_ring_brackets (1), 3)
967                     then go to bracket_error;
968                end;
969                else do;
970                     if val > fixed (entry.ring_brackets (1), 3)
971                     then go to bracket_error;
972                end;
973           end;
974 
975      end find_entry;
976 %page;
977 /* include files */
978 
979 %page; %include dc_find_dcls;
980 %page; %include dir_entry;
981 %page; %include dir_header;
982 %page; %include dir_link;
983 %page; %include fs_obj_access_codes;
984 %page; %include reload_set_info;
985 %page; %include vtoce_pc_sws;
986      end set;