file.pl1 11/11/89 1133.6r w 11/11/89 0800.0 297891 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * *********************************************************** */ /* File System Interface Module. */ /* ****************************************************** * * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * * * ****************************************************** */ file: /* For multisegment file, read delimiters. */ procedure; /* Modified 13 August 1972, M J Grady. */ /* Modified July 1973 by E. Stone to work for both 64k and 256k MSFs */ /* Modified September 1974 by E. Stone to pass expand_path_ a maximum of 168 char pathname */ /* Modified 750915 by PG and MJG to eliminate incorrect validation of arguments to read */ /* internal static */ dcl (reading initial ("0"b), writing initial ("1"b)) bit (1) aligned internal static; /* declarations */ dcl (ioname1, type, ioname3, mode4) character (*); dcl status5 bit (72) aligned; dcl get_system_free_area_ entry returns (ptr); dcl free_area area based (fareap), fareap ptr init (null) int static; dcl pibp6 pointer; dcl (buffer_bit_offset, /* Bit offsets and lengths. */ bits_requested, total_bits, seg_bit_offset, bits_to_move, bits_moved, current_bit) fixed binary (24); dcl (ptrbit2, /* Temporaries for pointer manipulation. */ ptrbit3, offset) fixed binary (35); dcl (buffer, /* Pointer to workspace. */ p, /* Pointer to file control block. */ sp, /* Pointer to status string. */ seg) pointer; /* Pointer to file segment. */ dcl base fixed binary; /* Base of incremental bit search. */ dcl byte bit (9) aligned; /* Temporary for element during short delimiter search. */ dcl mode character (4) aligned; /* Copy of mode string. */ dcl no_delimiter bit (1) aligned; /* Flag to show we found a delimiter. */ dcl pointer_name character (8) aligned; /* Copy of pointer names. */ dcl (i, j) fixed bin (24), /* Index. */ (comp, /* component number for test. */ switch) fixed binary; dcl code fixed binary (35); /* error code for routines. */ dcl temp bit (72) aligned; /* Temporary for delimiter search. */ dcl infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */ dcl bits_per_seg fixed bin (24); dcl (error_table_$badcall, error_table_$boundviol, error_table_$change_first, error_table_$invalid_backspace_read, error_table_$invalid_elsize, error_table_$invalid_read, error_table_$invalid_seek_last_bound, error_table_$invalid_setdelim, error_table_$invalid_write, error_table_$negative_nelem, error_table_$ionmat, /* Ioname already attached. */ error_table_$negative_offset, error_table_$new_offset_negative, error_table_$no_room_for_dsb, /* Can't allocate file control block. */ error_table_$too_many_read_delimiters, error_table_$undefined_order_request, error_table_$undefined_ptrname) external fixed binary (35); dcl string based bit (9437184) aligned; /* Overlay of segment and workspace (buffer). */ dcl chars based character (1048576) aligned; /* Segment overlay for fast delimiter searches. */ dcl char1 character (1) aligned; /* Copy of delimiter table element. */ dcl 1 status based aligned, /* I/O system status string. */ 2 code fixed binary (35), /* Overall error code. */ 2 successful bit (4) unaligned, /* Logical/physical initiation/termination. */ 2 transaction_terminated bit (1) unaligned, /* No further status change. */ 2 unassigned bit (4) unaligned, 2 end_of_data bit (1) unaligned, /* Obvious. */ 2 pad bit (5) unaligned, 2 ioname_detached bit (1) unaligned, /* .. */ 2 pad2 bit (2) unaligned, 2 transaction_index bit (18) unaligned; /* IO system transaction index. */ dcl file_util$attach_file entry (pointer, fixed binary (35)); dcl file_util$detach_file entry (pointer, fixed binary (35)); dcl file_util$find_seg_ptr entry (pointer, bit (1) aligned, fixed binary, pointer, fixed binary (35)); dcl (add, addr, addrel, bit, divide, fixed, index, length, min, mod, multiply, null, rel, substr, unspec) builtin; dcl 1 fcb static aligned like pib; /* First file control block, allocated at translation time */ /* Additional file control blocks, allocated as needed. */ % include file_pib; dcl (msegp, mbufp) ptr, (msegoff, mbufoff, mmove) fixed bin (24), mchrarray (0:1) char (1) based, mwords (mmove) fixed bin (35) aligned based, mchars char (1000) based aligned; /* */ file_attach: /* entry to attach file. */ entry (ioname1, type, ioname3, mode4, status5, pibp6); sp = addr (status5); /* Set up pointer to status string. */ if pibp6 ^= null then /* Is this name already attached? */ do; /* Yes. */ code = error_table_$ionmat; /* Set error code. */ go to set_detached_bit; /* Give up. */ end; if fareap = null then fareap = get_system_free_area_ (); /* get area to alloc in */ if fcb.busy then /* Is the first block in use? */ do; /* Yes. */ allocate pib in (free_area) set (p); /* Get another. */ if p = null then /* Successful? */ do; /* No. */ code = error_table_$no_room_for_dsb; /* Set error code. */ go to set_detached_bit; /* Give up. */ end; end; else p = addr (fcb); /* Use internal block. */ /* Insert path name of file into control block. */ p -> pib.device_name.name_size = min (length (ioname3), length (p -> pib.device_name.name_string)); p -> pib.device_name.name_string = ioname3; /* .. */ mode = mode4; /* Copy mode string. */ p -> pib.r, p -> pib.w = ""b; /* Clear both permission flags. */ if mode = "r " then /* Read only? */ p -> pib.r = "1"b; /* Yes, set read permission flag. */ if mode = "w " then /* Write only? */ p -> pib.w = "1"b; /* Yes, set write permission flag. */ if p -> pib.r | p -> pib.w then go to mode_out; /* If any set now jump out. */ if index (mode4, "read") = 0 & index (mode4, "write") = 0 then do; p -> pib.r, p -> pib.w = "1"b; go to mode_out; end; i = index (mode4, "read"); if i ^= 0 then do; if i > 1 then if substr (mode4, i-1, 1) ^= "^" then p -> pib.r = "1"b; /* set read on */ else; else p -> pib.r = "1"b; end; i = index (mode4, "write"); if i ^= 0 then do; if i > 1 then if substr (mode4, i-1, 1) ^= "^" then p -> pib.w = "1"b; /* set write on */ else; else p -> pib.w = "1"b; /* also set write */ end; mode_out: call file_util$attach_file (p, code); /* Initialize data block. */ if code ^= 0 then /* Successful? */ go to delete_fcb; /* No, deallocate the control block. */ p -> pib.outer_module_name = type; /* Insert our name. */ p -> pib.device_name_list = addr (p -> pib.device_name); /* Insert pointer for IOS. */ p -> pib.device_name.next_device = null; /* Clear pointer to next list bead. */ p -> pib.busy = "1"b; /* Mark block as in use. */ pibp6 = p; /* Give pointer to block to IOS. */ go to good; /* Attach successfully completed. */ /* */ file_detach: entry (pibp1, ioname2, disposal, status4); dcl pibp1 pointer; dcl (ioname2, disposal) character (*); dcl status4 bit (72) aligned; p = pibp1; sp = addr (status4); call file_util$detach_file (p, code); /* Clean up and free data block. */ if code = 0 then /* Successful? */ go to delete_fcb; /* Yes, deallocate control block. */ if disposal ^= "h" then /* No, are we requested to hold the control block? */ do; /* No. */ delete_fcb: p -> pib.busy = ""b; /* Clear the use flag. */ if p ^= addr (fcb) then /* Is it the original block? */ free p -> pib in (free_area); /* No, return it to free storage. */ sp -> status.ioname_detached = "1"b; /* Set detached bit. */ end; if code ^= 0 then /* Which exit should we take? */ go to bad; /* Erroneous operation, report code. */ go to good; /* */ file_order: entry (pibp1, request, argptr, status4); dcl request character (*) aligned; /* The name of the request. */ dcl argptr pointer; /* Pointer to arguments. */ sp = addr (status4); /* Get pointer to status string. */ p = pibp1; /* Copy pointer to control block. */ if request = "backspace_read" then /* Examine request name. */ do; /* This is it. */ if ^ p -> pib.r then /* Is file readable? */ do; /* No. */ code = error_table_$invalid_read; /* Set error code. */ go to bad; /* Give error return. */ end; if argptr ^= null then /* No arguments. */ do; /* But some supplied. */ code = error_table_$badcall; /* Set error code. */ go to bad; /* Give error return. */ end; if p -> pib.nreads = 0 then /* Are there any delimiters? */ do; /* No. */ scan (0): scan_none: code = error_table_$invalid_backspace_read; /* No, set error code. */ go to bad; /* Return to caller. */ end; p -> pib.readbit = add (p -> pib.readbit, - 2 * p -> pib.elsize, 35, 0); /* Back up two bytes. */ try_scan: if p -> pib.readbit <= 0 then /* At beginning of file? */ do; /* Yes. */ p -> pib.readbit = 0; /* Make sure nonnegative. */ go to good; /* Give normal return. */ end; bits_per_seg = p -> pib.bits_per_segment; seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get offset in current segment. */ comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */ if comp ^= p -> pib.lastcomp then do; /* check to see if same as last time. */ call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */ if code ^= 0 then /* Successful? */ go to bad; /* Give error return. */ p -> pib.lastcomp = comp; /* set new component number. */ p -> pib.lastseg = seg; /* save new seg number */ end; else seg = p -> pib.lastseg; /* else set seg to be same as last time. */ do current_bit = seg_bit_offset by - p -> pib.elsize to 0; /* Scan backwards. */ temp = substr (seg -> string, current_bit + 1, p -> pib.elsize); /* Extract one byte. */ go to scan (p -> pib.search_type); /* Dispatch to proper scan. */ scan (2): scan_bit_table: if substr (p -> pib.readlist, fixed (substr (temp, 1, 9), 9) + 1, 1) then /* Is this a break? */ go to scan_done; /* Yes, terminate the scan. */ go to scan_loop; /* No, get next. */ scan (1): scan_1_char: /* Can't handle special case; treat as packed. */ scan (3): scan_packed: j = 0; /* Reset array index. */ do i = 1 to p -> pib.nreads; /* Compare with each delimiter. */ if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Does this match? */ go to scan_done; /* Yes, stop. */ j = j + p -> pib.elsize; /* Bump array index. */ end; scan_loop: end; /* Adjust read pointer to end of previous segment. */ p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset - p -> pib.elsize, 35, 0); go to try_scan; /* Go check for file beginning, get next segment. */ /* Adjust read pointer to place we found. */ scan_done: p -> pib.readbit = add (p -> pib.readbit, - seg_bit_offset + current_bit + p -> pib.elsize, 35, 0); go to good; /* Give normal return. */ end; if request = "call" then /* Is request for file system call? */ do; /* Yes. */ argptr -> status.code = p -> pib.call; /* Give it to caller. */ go to good; /* Return to caller. */ end; code = error_table_$undefined_order_request; /* Unrecognized request. */ go to bad; /* Give error return. */ /* */ file_getsize: entry (pibp1, elsize, status3); dcl elsize fixed binary (24); dcl status3 bit (72) aligned; p = pibp1; sp = addr (status3); elsize = p -> pib.elsize; go to good; file_setsize: entry (pibp1, elsize, status3); p = pibp1; sp = addr (status3); if elsize < 1 then do; code = error_table_$invalid_elsize; go to bad; end; bits_per_seg = p -> pib.bits_per_segment; if elsize > bits_per_seg then /* Is it too big? */ do; /* Yes. */ code = error_table_$invalid_elsize; /* Set code. */ go to bad; /* Give error return. */ end; p -> pib.elsize = elsize; /* Round pointers to integral element. */ call round (p -> pib.readbit); call round (p -> pib.writebit); call round (p -> pib.lastbit); call round (p -> pib.highbit); call round (p -> pib.boundbit); p -> pib.search_type, p -> pib.nreads = 0; /* Flush any read delimiters. */ go to good; /* */ file_read: entry (pibp1, workspace, offset3, nelem, nelemt, status6); dcl workspace pointer; dcl (offset3, nelem, nelemt) fixed binary (24); dcl status6 bit (72) aligned; p = pibp1; sp = addr (status6); nelemt, total_bits = 0; /* Nothing transmitted yet. */ if ^ p -> pib.r then do; /* Improper mode. */ code = error_table_$invalid_read; /* Give error return. */ go to bad; end; buffer = workspace; /* Copy workspace pointer. */ buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0); /* Copy workspace offset. */ if buffer_bit_offset < 0 then /* It must be non-negative. */ do; /* Bad offset. */ code = error_table_$negative_offset; /* Give error return. */ go to bad; end; bits_requested = multiply (nelem, p -> pib.elsize, 24, 0); /* Copy number of elements desired. */ if bits_requested < 0 then /* It, too must be non-negative. */ do; /* Bad buffer size. */ code = error_table_$negative_nelem; /* Give error return. */ go to bad; end; bits_per_seg = p -> pib.bits_per_segment; call round (p -> pib.lastbit); /* Round last pointer to element boundary. */ no_delimiter = "1"b; /* Set flag for retry. */ try_read: seg_bit_offset = mod (p -> pib.readbit, bits_per_seg); /* Get bit offset in current segment. */ bits_to_move = min (add (p -> pib.lastbit, - p -> pib.readbit, 35, 0), bits_requested); /* Get bits to move. */ bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move); /* Get bits we can move out of cur seg. */ comp = divide (p -> pib.readbit, bits_per_seg, 17, 0); /* get component number */ if comp ^= p -> pib.lastcomp then do; /* check to see if same as last time. */ call file_util$find_seg_ptr (p, (reading), comp, seg, code); /* Get segment. */ if code ^= 0 then go to good; /* Not an error...this is an EOF condition */ p -> pib.lastcomp = comp; /* set new component number. */ p -> pib.lastseg = seg; /* save new seg number */ end; else seg = p -> pib.lastseg; /* else set seg to be same as last time. */ go to read (p -> pib.search_type); /* Dispatch to proper delimiter search. */ read (2): /* READ BIT TABLE */ current_bit = 0; /* Reset bit count. */ do while (current_bit < bits_moved); /* Fill buffer if possible. */ /* Move one byte for comparison. */ byte = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize); current_bit = current_bit + p -> pib.elsize; /* Count the element. */ if substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) then /* Is this it? */ go to read_delimiter_found; /* Yes. */ end; go to read_move; /* Go move the entire string. */ read (3): /* READ PACKED */ current_bit = 0; /* Reset bit count. */ do while (current_bit < bits_moved); /* Fill buffer if possible. */ /* Move one byte for comparison. */ temp = substr (seg -> string, seg_bit_offset + current_bit + 1, p -> pib.elsize); current_bit = current_bit + p -> pib.elsize; /* Count the element. */ j = 0; /* Reset array index. */ do i = 1 to p -> pib.nreads; /* Search the delimiter list. */ if temp = substr (p -> pib.readlist, j + 1, p -> pib.elsize) then /* Is this it? */ go to read_delimiter_found; /* Yes. */ j = j + p -> pib.elsize; /* Update array index. */ end; end; go to read_move; /* Go move the entire string. */ read (1): /* READ 1 CHAR */ i = divide (seg_bit_offset, 9, 17, 0); /* Compute index of first character in file segment. */ j = divide (bits_moved, 9, 17, 0); /* Compute length of rest of segment in characters. */ unspec (char1) = substr (p -> pib.readlist, 1, 9); /* Copy the delimiter. */ current_bit = 9 * index (substr (seg -> chars, i + 1, j), char1); /* Look for the break. */ if current_bit ^= 0 then /* Any found? */ do; /* Yes. */ read_delimiter_found: no_delimiter = ""b; /* Clear flag. */ bits_moved = current_bit; /* Correct size of move. */ end; read (0): /* Case of no read delimiters. */ read_move: if p -> pib.elsize = 36 then do; msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0); msegp = addrel (seg, msegoff); mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0); mbufp = addrel (buffer, mbufoff); mmove = divide (bits_moved, p -> pib.elsize, 24, 0); mbufp -> mwords = msegp -> mwords; end; else if p -> pib.elsize = 9 then do; msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0); mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0); mmove = divide (bits_moved, p -> pib.elsize, 24, 0); substr (buffer -> mchars, mbufoff+1, mmove) = substr (seg -> mchars, msegoff+1, mmove); end; else do; substr (buffer -> string, buffer_bit_offset + 1, bits_moved) = substr (seg -> string, seg_bit_offset + 1, bits_moved); end; total_bits = total_bits + bits_moved; /* Count total bits transmitted. */ nelemt = divide (total_bits, p -> pib.elsize, 24, 0); p -> pib.readbit = add (p -> pib.readbit, bits_moved, 35, 0); if no_delimiter then /* Was the delimiter found? */ if bits_moved < bits_to_move then /* No, is more data in other segment? */ do; /* Yes. */ buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */ bits_requested = bits_requested - bits_moved; /* Decrease "demand". */ go to try_read; /* Go try again. */ end; go to good; /* */ file_write: entry (pibp1, workspace, offset3, nelem, nelemt, status6); p = pibp1; sp = addr (status6); nelemt, total_bits = 0; /* Clear for accumulation of bits transmitted. */ if ^ p -> pib.w then do; /* Improper mode. */ code = error_table_$invalid_write; /* Give error return. */ go to bad; end; buffer = workspace; /* Copy pointer to caller's buffer. */ buffer_bit_offset = multiply (offset3, p -> pib.elsize, 24, 0); if buffer_bit_offset < 0 then /* Check range. */ do; /* Bad. */ code = error_table_$negative_offset; /* Set up code. */ go to bad; /* Give error return. */ end; bits_requested = multiply (nelem, p -> pib.elsize, 24, 0); if bits_requested < 0 then /* Check range. */ do; /* Bad. */ code = error_table_$negative_nelem; /* Set up code. */ go to bad; /* Give error return. */ end; bits_per_seg = p -> pib.bits_per_segment; /* Might we get bounds fault accessing buffer? */ if fixed (rel (buffer), 18) * 36 + buffer_bit_offset + bits_requested > bits_per_seg then do; /* Yes. */ code = error_table_$boundviol; /* Off end of buffer. */ go to bad; /* Give error return. */ end; call round (p -> pib.writebit); /* Round write pointer to element boundary. */ try_write: seg_bit_offset = mod (p -> pib.writebit, bits_per_seg); /* Get offset in current segment. */ bits_to_move = min (add (p -> pib.boundbit, - p -> pib.writebit, 35, 0), bits_requested); bits_moved = min (bits_per_seg - seg_bit_offset, bits_to_move); /* Get bits we can move. */ comp = divide (p -> pib.writebit, bits_per_seg, 17, 0); /* get component number */ if comp ^= p -> pib.lastcomp then do; /* check to see if same as last time. */ call file_util$find_seg_ptr (p, (writing), comp, seg, code); /* Get segment. */ if code ^= 0 then /* Successful? */ go to bad; /* Give error return. */ p -> pib.lastcomp = comp; /* set new component number. */ p -> pib.lastseg = seg; /* save new seg number */ end; else seg = p -> pib.lastseg; /* else set seg to be same as last time. */ if p -> pib.elsize = 36 then do; msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0); msegp = addrel (seg, msegoff); mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0); mbufp = addrel (buffer, mbufoff); mmove = divide (bits_moved, p -> pib.elsize, 24, 0); msegp -> mwords = mbufp -> mwords; end; else if p -> pib.elsize = 9 then do; msegoff = divide (seg_bit_offset, p -> pib.elsize, 24, 0); mbufoff = divide (buffer_bit_offset, p -> pib.elsize, 24, 0); mmove = divide (bits_moved, p -> pib.elsize, 24, 0); substr (seg -> mchars, msegoff+1, mmove) = substr (buffer -> mchars, mbufoff+1, mmove); end; else do; substr (seg -> string, seg_bit_offset + 1, bits_moved) = substr (buffer -> string, buffer_bit_offset + 1, bits_moved); end; total_bits = total_bits + bits_moved; /* Count this batch. */ nelemt = divide (total_bits, p -> pib.elsize, 24, 0); p -> pib.writebit = add (p -> pib.writebit, bits_moved, 35, 0); if p -> pib.writebit > p -> pib.lastbit then /* Was file size increased? */ do; /* Yes. */ p -> pib.lastbit = p -> pib.writebit; /* Increase pointer to indicate it. */ p -> pib.highbit = p -> pib.lastbit; /* set high water mark */ p -> pib.changed = "1"b; /* Mark it for setting bit count. */ end; if bits_moved < bits_to_move then /* Is more data in other segment? */ do; /* Yes. */ buffer_bit_offset = buffer_bit_offset + bits_moved; /* Move up in buffer. */ bits_requested = bits_requested - bits_moved; /* Decrease "demand". */ go to try_write; /* Go try again. */ end; go to good; /* */ file_setdelim: entry (pibp1, nbreaks, breaklist, nreads, readlist, status6); dcl nbreaks, nreads; /* Numbers of elements. */ dcl (breaklist, readlist) bit (*) aligned; sp = addr (status6); /* Get pointer to status string. */ p = pibp1; /* Copy pointer to control data. */ if p -> pib.elsize > length (temp) then /* Will delimiter search work? */ do; /* No. */ code = error_table_$invalid_setdelim; /* Refuse call. */ go to bad; end; bits_per_seg = p -> pib.bits_per_segment; if mod (bits_per_seg, p -> pib.elsize) ^= 0 then /* Will elements span segment boundaries? */ do; /* Yes, delimiter search will not always work. */ code = error_table_$invalid_setdelim; /* Give error code. */ go to bad; /* Refuse call. */ end; if nreads < 0 then /* Check validity. */ do; /* Bad. */ code = error_table_$badcall; /* Refuse call. */ go to bad; end; if p -> pib.elsize > 9 then /* Will we have to store the bytes? */ do; /* Yes. */ total_bits = nreads * p -> pib.elsize; /* Compute number of bits required. */ if total_bits > length (p -> pib.readlist) then /* Make sure not too many. */ do; /* Bad. */ code = error_table_$too_many_read_delimiters; /* Refuse call. */ go to bad; end; end; p -> pib.nreads = nreads; /* Save the total number of delimiters. */ if p -> pib.nreads = 1 then /* Is there only one? */ if p -> pib.elsize = 9 then /* Is it a character? */ do; /* Yes, special case. */ p -> pib.search_type = 1; /* Set dispatch code. */ substr (p -> pib.readlist, 1, 9) = substr (readlist, 1, 9); /* Copy the character. */ go to good; /* Return to caller. */ end; if p -> pib.nreads = 0 then /* Are there no delimiters specified? */ do; /* Yes. */ p -> pib.search_type = 0; /* Set up dispatch code. */ end; else if p -> pib.elsize > 9 then /* Must we use packed array? */ do; /* Yes. */ p -> pib.search_type = 3; /* Remember dispatch code. */ substr (p -> pib.readlist, 1, total_bits) = substr (readlist, 1, total_bits); /* Copy the string. */ end; else /* Element size less than 9 bits. */ do; /* We may use bit table. */ p -> pib.search_type = 2; /* Set dispatch code. */ p -> pib.readlist = ""b; /* Clear the table. */ j = 0; /* Set up index of first delimiter. */ do i = 1 to p -> pib.nreads; /* Start copy loop. */ byte = substr (readlist, j + 1, p -> pib.elsize); /* Extract the byte. */ substr (p -> pib.readlist, fixed (byte, 9) + 1, 1) = "1"b; /* Mark the table entry. */ j = j + p -> pib.elsize; /* Move index to next delimiter. */ end; end; go to good; /* Give happy return. */ /* */ file_getdelim: entry (pibp1, nbreaks, breaklist, nreads, readlist, status6); sp = addr (status6); /* Get pointer to status string. */ p = pibp1; /* Copy pointer to control data. */ nbreaks = 0; /* We have no break characters. */ go to get (p -> pib.search_type); /* Dispatch on delimiter code. */ get (0): get_none: /* Case of no delimiters. */ nreads = 0; /* Set caller's count. */ go to good; /* Return to caller. */ get (1): get_1_char: /* Special case. */ nreads = 1; /* Give caller number of delimiters. */ substr (readlist, 1, 9) = substr (p -> pib.readlist, 1, 9); /* Give caller the character. */ go to good; /* Return to caller. */ get (2): get_bit_table: /* Case of 256-entry bit table. */ base, j = 0; /* Reset bit and byte indices. */ do nreads = 0 by 1; /* Count bytes returned. */ i = index (substr (p -> pib.readlist, base + 1), "1"b); /* Find next marked entry. */ if i = 0 then /* No more? */ go to good; /* Return to caller. */ substr (readlist, j + 1, p -> pib.elsize) = bit (base + i - 1, 9); /* Form matching code. */ j = j + p -> pib.elsize; /* Update output array index. */ base = base + i; /* Update search base. */ end; go to good; /* Return to caller. */ get (3): get_packed: /* Case of packed array of bytes. */ nreads = p -> pib.nreads; /* Give caller the number of read delimiters. */ total_bits = p -> pib.nreads * p -> pib.elsize; /* Compute number of bits required. */ substr (readlist, 1, total_bits) = substr (p -> pib.readlist, 1, total_bits); /* Give them to caller. */ go to good; /* Give happy return. */ /* */ file_seek: entry (pibp1, ptrname2, ptrname3, offset4, status5); dcl (ptrname2, ptrname3) character (*); dcl offset4 fixed binary (35); p = pibp1; sp = addr (status5); pointer_name = ptrname3; /* Copy name of reference pointer. */ call pointerdecode (pointer_name, ptrbit3, switch); if switch = 0 then /* Was name recognizable? */ do; code = error_table_$undefined_ptrname; /* Unrecognizable ptrname3. */ go to bad; end; offset = add (ptrbit3, multiply (offset4, p -> pib.elsize, 35, 0), 35, 0); /* Compute new pointer value. */ if offset < 0 then do; code = error_table_$new_offset_negative; /* Resultant offset improper. */ go to bad; end; pointer_name = ptrname2; /* Copy name of pointer to be set. */ call pointerdecode (pointer_name, ptrbit2, switch); go to seek (switch); /* Dispatch on pointer name. */ seek (0): seek_0: code = error_table_$undefined_ptrname; /* Improper ptrname2. */ go to bad; seek (1): seek_first: code = error_table_$change_first; /* Attempt to change value of first pointer. */ go to bad; /* Give error return. */ seek (2): seek_read: if ^ p -> pib.r then /* Do we have read permission? */ do; /* No. */ code = error_table_$invalid_read; /* Set Error code. */ go to bad; /* Give error return. */ end; p -> pib.readbit = min (offset, p -> pib.lastbit); go to good; seek (3): seek_write: if ^ p -> pib.w then /* Do we have write permission? */ do; /* No. */ code = error_table_$invalid_write; /* Set error code. */ go to bad; /* Give error return. */ end; p -> pib.writebit = min (offset, p -> pib.lastbit); go to good; seek (4): seek_last: if ^ p -> pib.w then /* May we write on this file? */ do; /* No. */ if offset > p -> pib.highbit then do; code = error_table_$invalid_seek_last_bound; /* Give error return. */ go to bad; end; p -> pib.lastbit = offset; go to good; end; p -> pib.lastbit = min (offset, p -> pib.boundbit); p -> pib.highbit = p -> pib.lastbit; go to truncate; seek (5): seek_bound: if ^ p -> pib.w then /* Do we have write permission? */ do; /* No. */ code = error_table_$invalid_seek_last_bound; /* Give error return. */ go to bad; end; p -> pib.boundbit = offset; if p -> pib.lastbit > offset then /* Does change to bound necessitate change to last? */ do; /* Yes. */ p -> pib.lastbit = offset; /* Perform necessary truncation. */ truncate: p -> pib.changed = "1"b; /* Mark for later setting bit count. */ end; /* Truncate read, write pointers if necessary. */ p -> pib.readbit = min (p -> pib.readbit, p -> pib.lastbit); p -> pib.writebit = min (p -> pib.writebit, p -> pib.lastbit); go to good; /* */ file_tell: entry (pibp1, ptrname2, ptrname3, offset4, status5); p = pibp1; sp = addr (status5); pointer_name = ptrname3; /* Copy name of reference pointer. */ call pointerdecode (pointer_name, ptrbit3, switch); if switch = 0 then /* Was name recognizable? */ do; code = error_table_$undefined_ptrname; /* Unrecognizable ptrname3. */ go to bad; /* Give error return. */ end; pointer_name = ptrname2; /* Copy name of pointer whose value is wanted. */ call pointerdecode (pointer_name, ptrbit2, switch); if switch = 0 then /* Was name recognizable? */ do; code = error_table_$undefined_ptrname; /* Unrecognizable ptrname2. */ go to bad; /* Give error return. */ end; offset4 = divide (add (ptrbit2, - ptrbit3, 35, 0), p -> pib.elsize, 35, 0); go to good; /* */ set_detached_bit: sp -> status.ioname_detached = "1"b; /* Indicate detachment. */ bad: sp -> status.code = code; go to done; good: sp -> status.successful = "1111"b; /* Indicate initiation/termination. */ sp -> status.code = 0; /* set return code to zero */ done: sp -> status.transaction_terminated = "1"b; /* Indicate we are done. */ if sp -> status.ioname_detached then /* Was this a detach call? */ return; if p -> pib.readbit >= p -> pib.lastbit then sp -> status.end_of_data = "1"b; /* Set EOF indicator. */ return; /* Return to caller. */ /* */ pointerdecode: /* Procedure to decode pointer name. */ procedure (pointername, pointerbit, switch); /* Returns pointer value and dispatch index. */ dcl pointername character (8) aligned; /* Symbolic pointer name. */ dcl pointerbit fixed binary (35); /* Returned value of the pointer. */ dcl switch fixed binary; /* Label index. */ if pointername = "first " then do; pointerbit = 0; switch = 1; end; else if pointername = "read " then do; pointerbit = p -> pib.readbit; switch = 2; end; else if pointername = "write " then do; call round (p -> pib.writebit); /* Round write pointer to integral element. */ pointerbit = p -> pib.writebit; switch = 3; end; else if pointername = "last " then do; call round (p -> pib.lastbit); /* Round last pointer to integral elements. */ pointerbit = p -> pib.lastbit; switch = 4; end; else if pointername = "bound " then do; pointerbit = p -> pib.boundbit; switch = 5; end; else pointerbit, switch = 0; end pointerdecode; /* Return to caller. */ /* */ round: procedure (offset); /* Procedure to round subject to upper limit. */ dcl offset fixed binary (35); /* Bit offset in file. */ dcl (overage, underage) fixed binary (24); /* Element size and errors. */ overage = mod (offset, p -> pib.elsize); /* Calculate amount of offset over integral elements. */ if overage ^= 0 then /* If zero, we are OK. */ do; underage = p -> pib.elsize - overage; /* Get amount of increase necessary. */ if add (infinity, - offset, 35, 0) >= underage then /* Is there room for increase? */ offset = add (offset, underage, 35, 0); /* Yes, round up. */ else offset = add (offset, - overage, 35, 0); /* No, truncate down. */ end; end round; end file;  file_.alm 11/11/89 1133.6r w 11/11/89 0800.7 11781 " *********************************************************** " * * " * Copyright, (C) Honeywell Bull Inc., 1987 * " * * " * Copyright, (C) Honeywell Information Systems Inc., 1982 * " * * " * Copyright (c) 1972 by Massachusetts Institute of * " * Technology and Honeywell Information Systems, Inc. * " * * " *********************************************************** " Outer Module Transfer Vector for the file outer module. entry filemodule entry file_module filemodule: file_module: tra *+1,6 go to proper transfer instruction tra |[file_attach] tra |[file_detach] tra |[file_read] tra |[file_write] tra |[no_entry] tra |[file_order] tra |[no_entry] tra |[no_entry] tra |[file_setsize] tra |[file_getsize] tra |[file_setdelim] tra |[file_getdelim] tra |[file_seek] tra |[file_tell] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] tra |[no_entry] end  file_util.pl1 11/11/89 1133.6r w 11/11/89 0800.7 116901 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ file_util: procedure; /* File System Interface Module utility procedures. */ /* Modified 13 August 1972, M J Grady - Honeywell. */ /* Modified July 1973 by E. Stone to work both for 64k and 256k MSFs */ /* Modified 750915 by PG to be able to attach to branches with many names */ dcl code2 fixed binary (35); /* Error code (returned). */ dcl pibp pointer; /* Pointer to file control block. */ dcl ap pointer; /* Temporary pointer. */ dcl b36 (0: 1) based fixed binary (35); /* Overlay to access thirtysix-bit elements (words). */ dcl bit_count fixed binary (24); /* Bits in segment or segments in directory. */ dcl bits_per_seg fixed bin (24); dcl dname based character (168) aligned; /* Overlay for directory path name. */ dcl ename based character (32) aligned; /* Overlay for entry name. */ dcl entry character (32) aligned; /* Temporary for lower level entry name. */ dcl ep pointer; /* Pointer to entry structure. */ dcl error_table_$bad_ms_file external fixed binary (35); dcl error_table_$moderr external fixed binary (35); /* File system error codes. */ dcl error_table_$noentry external fixed binary (35); dcl error_table_$toomanylinks external fixed binary (35); dcl error_table_$seg_unknown external fixed bin (35); dcl i fixed bin; /* Index. */ dcl infinity static fixed binary (35) initial (34359738367); /* 2 .P. 35 - 1 */ dcl kind fixed binary (2); /* Entry type. */ dcl max_length fixed bin (19); /* max length of component in words */ dcl msf_sw bit (3) aligned; /* bit switch for msf_manager_$adjust. */ dcl n fixed bin; /* Temporary length. */ dcl p pointer; /* Pointer to file control block. */ dcl path character (168) aligned; /* Aligned storage for path name. */ dcl suffix fixed binary; /* Suffix of desired segment. */ dcl sys_info$max_seg_size ext fixed bin (19); /* system maximum segment size in words */ dcl expand_path_ entry (pointer, fixed binary, pointer, pointer, fixed binary (35)); dcl hcs_$get_max_length entry (char (*) aligned, char (*) aligned, fixed bin (19), fixed bin (35)); dcl hcs_$status_long entry (character (*) aligned, character (*) aligned, fixed binary (1), pointer, pointer, fixed binary (35)); dcl hcs_$status_minf entry (character (*) aligned, character (*) aligned, fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35)); dcl ioa_$rsnnl entry options (variable); /* Variable argument list. */ dcl msf_manager_$open entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35)), msf_manager_$get_ptr entry (ptr, fixed bin, bit (1), ptr, fixed bin (24), fixed bin (35)), msf_manager_$adjust entry (ptr, fixed bin, fixed bin (24), bit (3) aligned, fixed bin (35)), msf_manager_$close entry (ptr); dcl (addr, baseno, baseptr, bit, divide, fixed, empty, mod, null, substr) builtin; dcl 1 branch, /* Branch structure filled by status_long. */ 2 ((dir, seg) bit (1), nnames bit (16), nrp bit (18)), /* Type, number of names, pointer to names. */ 2 dtm bit (36), /* Date-time segment modified. */ 2 dtu bit (36), /* Date-time used. */ 2 ((t, r, e, w, a) bit (1), pad1 bit (13), records bit (18)), /* Mode, number of records. */ 2 dtd bit (36), /* Date-time dumped. */ 2 dtem bit (36), /* Date-time entry modified. */ 2 acct bit (36), /* Account ID. */ 2 (curlen bit (12), bit_count bit (24)), /* Current length, bit count. */ 2 ((did, mdid) bit (4), copysw bit (1), pad2 bit (9), rb (3) bit (6)), /* Dev. ID's, copy sw., rings. */ 2 uid bit (36); /* Unique ID. */ /* Single element from file control block. */ % include file_pib; dcl 1 seg1 based aligned, /* Overlay for word of ring memory. */ 2 (no bit (18), used bit (1), key bit (17)) unaligned; /* */ file_util$attach_file: /* Entry to attach file */ entry (pibp, code2); p = pibp; /* Copy pointer to file control block. */ ap = addr (p -> pib.device_name.name_string); /* Get pointer to input string. */ n = p -> pib.device_name.name_size; /* Compute total number of characters. */ ep = addr (branch); /* Get pointer to branch structure. */ call expand_path_ (ap, n, addr (p -> pib.dir_name), addr (p -> pib.entry_name), code2); if code2 ^= 0 then /* Error in path name? */ do; /* Yes. */ p -> pib.call = 1; /* Mark place of failure. */ return; /* Give error return. */ end; call hcs_$status_long (p -> pib.dir_name, p -> pib.entry_name, 1, ep, null, code2); if code2 ^= 0 then /* Some error? */ do; /* Yes. */ if code2 = error_table_$noentry then /* Is the entry missing? */ if p -> pib.w then /* Can we create it? */ do; /* Yes. */ p -> pib.level = ""b; /* File is at top level. */ /* Initialize actual length. */ p -> pib.writebit, p -> pib.lastbit = 0; p -> pib.bits_per_segment = sys_info$max_seg_size * 36; go to attach_common; /* Go do common stuff. */ end; p -> pib.call = 2; /* Mark point of failure. */ return; /* Call foul. */ end; if branch.seg then /* Is the entry a segment? */ do; /* Yes. */ /* Check for requested mode. */ if ^ branch.r & p -> pib.r | ^ branch.w & p -> pib.w then do; /* No. */ code2 = error_table_$moderr; /* Report discrepancy. */ return; end; p -> pib.level = ""b; /* File is at upper level. */ /* Set write, last pointers according to bit count. */ p -> pib.writebit, p -> pib.lastbit = fixed (branch.bit_count, 35); call hcs_$get_max_length (p -> pib.dir_name, p -> pib.entry_name, max_length, code2); if code2 ^= 0 then do; p -> pib.call = 3; return; end; p -> pib.bits_per_segment = max_length * 36; go to attach_common; /* Go set other initial values. */ end; if branch.dir then /* Is the entry a directory? */ do; /* Yes. */ suffix = fixed (branch.bit_count, 24) - 1; /* Get suffix of last segment. */ if suffix < 0 then /* Was "bit count" zero? */ do; /* Yes. */ suffix = 0; /* Set number of complete segments to zero. */ go to attach_length_zero; /* Continue attach of zero-length file. */ end; call create_lower_level_names (null, suffix, addr (path), addr (entry)); /* Examine statistics. */ call hcs_$status_minf (path, entry, 0, kind, bit_count, code2); if code2 ^= 0 then /* Successful? */ do; /* No. */ if code2 = error_table_$noentry then /* Is segment missing? */ if p -> pib.w then /* May we create it? */ do; /* Yes. */ attach_length_zero: bit_count = 0; /* Assume zero bits in this segment. */ max_length = sys_info$max_seg_size; /* And system maximum for max length */ go to attach_lower_level; /* Go compute total bit count. */ end; p -> pib.call = 4; /* Mark point of failure. */ return; /* Reflect error. */ end; if kind ^= 1 then /* Is this a segment? */ do; /* No. */ code2 = error_table_$bad_ms_file; /* Set error code. */ return; /* Give error return. */ end; call hcs_$get_max_length (path, entry, max_length, code2); if code2 ^= 0 then do; p -> pib.call = 5; return; end; attach_lower_level: p -> pib.level = "1"b; /* File is at lower level. */ /* Set up current size. */ p -> pib.bits_per_segment = max_length * 36; p -> pib.writebit, p -> pib.lastbit = p -> pib.bits_per_segment * suffix + bit_count; go to attach_common; /* Do common initialization. */ end; code2 = error_table_$toomanylinks; return; attach_common: /* Some of this initialization should be moved to caller. */ p -> pib.changed = ""b; /* Mark bit count as as yet unchanged. */ p -> pib.elsize = 9; /* Default size is one character. */ p -> pib.readbit = 0; /* Begin reading from beginning. */ p -> pib.highbit = p -> pib.lastbit; p -> pib.boundbit = infinity - mod (infinity, 9); /* Default bound is 2 .P. 35 - 1. */ p -> pib.lastcomp = -1; /* init lastcomp to null */ p -> pib.lastseg = null; /* init ptr null too */ ap = addr (p -> pib.seg); /* Get pointer to ring memory. */ do i = 0 to 9; /* Initialize each element. */ ap -> b36 (i) = 011111111111111111b; /* Not used, null key. */ end; p -> pib.search_type = 1; /* Special case of delimiter search. */ p -> pib.nreads = 1; /* Default is one read delimiter.. */ substr (p -> pib.readlist, 1, 9) = "000001010"b; /* .. a new-line character. */ call msf_manager_$open (p -> pib.dir_name, p -> pib.entry_name, p -> pib.fcb_ptr, code2); if code2 = error_table_$noentry then code2 = 0; return; /* Return to caller. */ /* */ file_util$detach_file: /* Entry to detach file. */ entry (pibp, code2); /* Returns IO system formatted codes. */ p = pibp; /* Copy pointer to control data. */ bits_per_seg = p -> pib.bits_per_segment; suffix = divide (p -> pib.lastbit, bits_per_seg, 17, 0); /* calc number of last segment. */ bit_count = mod (p -> pib.lastbit, bits_per_seg); /* bit count for last seg */ msf_sw = p -> pib.changed || p -> pib.changed || "1"b; /* this switch controls $adjust */ call msf_manager_$adjust (p -> pib.fcb_ptr, suffix, bit_count, msf_sw, code2); /* call to adjust last bit count and terminate all segs */ if code2 ^= 0 then if code2 ^= error_table_$seg_unknown & code2 ^= error_table_$noentry then return; call msf_manager_$close (p -> pib.fcb_ptr); p -> pib.fcb_ptr = null; code2 = 0; /* Detach successful. */ return; /* Return to caller. */ /* */ find_seg_ptr: /* Entry to get pointer to segment. */ entry (pibp, bv_can_create, which, seg, code5); /* Returns raw codes. */ /* parameters */ dcl bv_can_create bit (1) aligned parameter; /* ON if missing component can be created */ dcl which fixed binary; /* Number of desired segment in file. */ dcl seg pointer; /* Pointer to segment (returned). */ dcl code5 fixed binary (35); /* Error code (returned). */ p = pibp; /* Copy pointer to control block. */ i = mod (which, 10); /* Look in the ring memory. */ ap = addr (p -> pib.seg (i)); /* Get pointer to appropriate word. */ if ^ap -> seg1.used then goto skip_ck; /* Is this entry in use? */ if fixed (ap -> seg1.key, 17) = which then /* Is this it? */ do; /* Yes. */ seg = baseptr (ap -> seg1.no); /* Make up pointer to segment. */ go to have_seg; /* Give normal return. */ end; skip_ck: /* Call msf_manager_ to get ptr to component */ call msf_manager_$get_ptr (p -> pib.fcb_ptr, which, (bv_can_create & p -> pib.w), seg, bit_count, code5); if seg = null then return; /* Return with code5 set to reason */ ap = addr (p -> pib.seg (i)); ap -> seg1.no = baseno (seg); ap -> seg1.key = bit (which, 17); /* set entry in ring memory */ have_seg: ap -> seg1.used = "1"b; /* Indicate recent use of this segment. */ code5 = 0; /* No error: clear code. */ return; /* Return to caller. */ /* */ create_lower_level_names: /* Procedure to make up names of "multi"-segments. */ procedure (enp1, suffix, path, entry); dcl enp1 pointer, /* Pointer to entry name to append to directory name. */ suffix fixed binary, /* Suffix desired on entry name. */ (path, /* Pointer to storage for directory path name. */ entry) pointer, /* Pointer to storage for entry name. */ n fixed bin, /* Length of resultant string (ignored). */ enp pointer; /* Pointer to entry name in control block. */ if path ^= null then /* Is directory path name wanted? */ do; /* Yes. */ enp = enp1; /* Copy pointer to desired entry name. */ if enp = null then /* If none, use entry name in control block. */ enp = addr (p -> pib.entry_name); /* .. */ if substr (p -> pib.dir_name, 1, 4) = "> " then /* Is it the root directory? */ call ioa_$rsnnl (">^a", path -> dname, n, enp -> ename); else call ioa_$rsnnl ("^a>^a", path -> dname, n, p -> pib.dir_name, enp -> ename); end; if entry ^= null then /* Is entry name desired? */ call ioa_$rsnnl ("^d", entry -> ename, n, suffix); end create_lower_level_names; /* Return to caller. */ end file_util;  make_msf_.pl1 11/11/89 1133.6r w 11/11/89 0800.0 177795 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1982 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* format: style2,ind3 */ make_msf_: proc (dirname_arg, ename_arg, rbs, code); /* Modified July 1973 by E. Stone to work for both 64k and 256k MSFs */ /* Modified Jan 1976 by Vinograd to work if linkage error on delete_ (for ring 1 reload) */ /* Modified 7/26/77 by M. Asherman to respect safety_sw on msf components by not allowing reversion to ssf in this case */ /* Modified 05/05/78 by C. D. Tavares to use hcs_$create_branch_, propagating safety_sw, copy_sw, and priv_upgrade_sw, on SSF -> MSF and MSF -> SSF */ /* Modified 01/09/78 by CDT to set extended ring brackets on dir portion of MSF to match ring brackets of components */ /* Modified 11/26/80 W. Olin Sibert to use automatic area for status_long names because of extensible area problem */ /* Modified: 01/25/82 by Lindsey Spratt: to create an MSF when no SSF exists. Also, changed to always add status permission to *.*.* on the directory portion of the MSF. 03/24/82 by Lindsey Spratt: Changed error code analysis following call of get_link_target. 06/24/82 by Lindsey Spratt: Changed to use access_mode_values include file. 12/27/84 by Keith Loepere: Version 2 create_branch_info. 02/05/85 by Steve Herbst: Changed to set "s *.*.*" only if there is not already a *.*.* entry on the ACL. */ dcl ( dirname_arg char (*), ename_arg char (*), rbs (3) fixed bin (6), /* really an output arg??? */ code fixed bin (35) ) parameter; /* automatic */ dcl acl_count fixed bin, aclp ptr init (null), acl_area_ptr pointer, copysw bit (1), cur_ring fixed bin, dac fixed bin, dap ptr init (null), dir_rings (2) fixed bin (6), dirname char (168), ename char (32), (i, ii) fixed bin, known bit (1) aligned, max_length fixed bin (19), path char (168), remember_ptr ptr, safety_sw bit (1) aligned, star_star_sw bit (1) aligned, temp_acc bit (72) aligned, component_0_existed bit (1) aligned, SSF_existed bit (1) aligned, unique char (32), unique_dir char (168); /* This area is used to hold the nams returned by hcs_$status_long. Because it is automatic, things need not ever be freed from it. It must be used because hcs_$status_ and extensible areas do not interact at all well, due to the 18 bit rel ptrs in the status return structure. It has room for 500 names, which I trust will be sufficient. */ dcl names_area area (2000) automatic; /* static */ dcl sys_areap pointer internal static initial (null); /* based */ dcl free_area area based (sys_areap); /* external static */ dcl ( error_table_$safety_sw_on, error_table_$noentry, error_table_$segknown ) ext fixed bin (35) static; /* entries */ dcl cu_$level_get entry returns (fixed bin), delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)), get_group_id_$tag_star entry returns (char (32)), get_system_free_area_ entry returns (ptr), get_authorization_ entry () returns (bit (72) aligned), hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)), hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)), hcs_$add_inacl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin, fixed bin (35)), hcs_$append_branch entry (char (*), char (*), fixed bin (5), fixed bin (35)), hcs_$append_branchx entry (char (*), char (*), fixed bin (5), (3) fixed bin (6), char (*), fixed bin (1), fixed bin (1), fixed bin (24), fixed bin (35)), hcs_$chname_file entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$create_branch_ ext entry (char (*), char (*), pointer, fixed bin (35)), hcs_$delentry_file entry (char (*), char (*), fixed bin (35)), hcs_$fs_move_file entry (char (*), char (*), fixed bin (2), char (*), char (*), fixed bin (35)), hcs_$get_access_class ext entry (char (*), char (*), bit (72) aligned, fixed bin (35)), hcs_$get_link_target entry (char (*), char (*), char (*), char (*), fixed bin (35)), hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)), hcs_$get_safety_sw entry (char (*), char (*), bit (1) aligned, fixed bin (35)), hcs_$get_safety_sw_seg entry (ptr, bit (1) aligned, fixed bin (35)), hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)), hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)), hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)), hcs_$list_inacl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin, fixed bin (35)), hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)), hcs_$set_dir_ring_brackets entry (char (*), char (*), (2) fixed bin (6), fixed bin (35)), hcs_$set_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)), hcs_$set_safety_sw ext entry (char (*), char (*), bit (1) aligned, fixed bin (35)), hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)), hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)), unique_chars_ entry (bit (*)) returns (char (15)); /* builtins and conditions */ dcl (addr, binary, empty, max, null, pointer, prod, rtrim, substr, unspec) builtin; dcl (cleanup, linkage_error) condition; /* structures */ dcl 1 s_acl (acl_count) based (aclp) aligned, 2 userid char (32), 2 mode bit (4) unaligned, 2 mbz1 bit (32) unaligned, 2 mbz2 bit (36), 2 err_code fixed bin (35); dcl 1 d_acl (dac) based (dap) aligned, 2 userid char (32), 2 mode bit (3) unaligned, 2 mbz1 bit (33) unaligned, 2 err_code fixed bin (35); %include create_branch_info; dcl 1 cbi like create_branch_info aligned automatic; %include status_structures; %include access_mode_values; dcl 1 branch like status_branch aligned automatic; unspec (cbi) = ""b; cbi.version = create_branch_version_2; cbi.chase_sw = "1"b; if sys_areap = null then sys_areap = get_system_free_area_ (); status_area_ptr = addr (names_area); acl_area_ptr = sys_areap; status_ptr = addr (branch); unspec (branch) = ""b; on cleanup call free_allocated_storage; call hcs_$get_link_target (dirname_arg, ename_arg, dirname, ename, code); /* get real path name */ if code = 0 then do; SSF_existed = "1"b; call hcs_$initiate_count (dirname, ename, "", cbi.bitcnt, 0, remember_ptr, code); /* find out about seg */ if code = 0 then known = "0"b; else if code = error_table_$segknown then known = "1"b; else goto error_return; end; else if code = error_table_$noentry then do; dirname = dirname_arg; ename = ename_arg; SSF_existed = "0"b; known = "0"b; end; else goto error_return; cur_ring = cu_$level_get (); if SSF_existed then do; call hcs_$status_long (dirname, ename, 1, status_ptr, status_area_ptr, code); /* do status get names */ if code ^= 0 then go to error_return; rbs (*) = branch.ring_brackets (*); cbi.rings (*) = branch.ring_brackets (*); cbi.mode = substr (branch.raw_mode, 2, 3); cbi.userid = get_group_id_$tag_star (); cbi.copy_sw = branch.copy_switch; /* who are we to judge?? */ end; else do; rbs (*) = cur_ring; cbi.rings (*) = rbs (*); cbi.mode = SMA_ACCESS; cbi.userid = get_group_id_$tag_star (); cbi.copy_sw = "0"b; end; if SSF_existed then do; call hcs_$get_safety_sw (dirname, ename, safety_sw, code); if code ^= 0 then goto error_return; end; else safety_sw = "0"b; if SSF_existed then do; call hcs_$get_access_class (dirname, ename, cbi.access_class, code); if code ^= 0 then goto error_return; end; else cbi.access_class = get_authorization_ (); if prod (cbi.rings) = 1 & SSF_existed then do; /* ring brackets are 1, 1, 1 */ call hcs_$get_access_class (dirname, "", temp_acc, code); if code = 0 then if temp_acc ^= cbi.access_class then cbi.priv_upgrade_sw = "1"b; end; cbi.parent_ac_sw = ^cbi.priv_upgrade_sw; /* DRV - get volume backup switch from SSF here */ if SSF_existed then do; call hcs_$list_acl (dirname, ename, acl_area_ptr, aclp, null, acl_count, code); /* get acl on segment */ if code ^= 0 then do; acl_count = 0; if aclp ^= null then free s_acl in (free_area); end; end; else do; call hcs_$list_inacl (dirname, "", acl_area_ptr, aclp, null, acl_count, cur_ring, code); if code ^= 0 then do; acl_count = 0; if aclp ^= null then free s_acl in (free_area); end; end; if SSF_existed then unique = unique_chars_ (""b); /* make up a unique name */ else unique = ename; unique_dir = rtrim (dirname, " ") || ">" || unique; call hcs_$append_branchx (dirname, unique, 01111b, (7), (cbi.userid), 1, 0, 1, code); /* make a directory */ if code ^= 0 then go to error_return; call hcs_$add_inacl_entries (dirname, unique, aclp, acl_count, cur_ring, code); /* put seg acl on initial acl */ dac = acl_count + 1; /* set to make dir acl */ allocate d_acl in (free_area) set (dap); /* allocate room for it */ star_star_sw = "0"b; do ii = 1 to dac - 1; /* convert acl to dir acl */ d_acl (ii).userid = s_acl (ii).userid; /* copy user name */ if d_acl (ii).userid = "*.*.*" then do; star_star_sw = "1"b; d_acl (ii).mode = d_acl (ii).mode | "100"b; /* need at least s access to *.*.* */ end; substr (d_acl (ii).mode, 1, 1) = substr (s_acl (ii).mode, 1, 1); /* copy mode bits */ substr (d_acl (ii).mode, 2, 1) = substr (s_acl (ii).mode, 3, 1); substr (d_acl (ii).mode, 3, 1) = substr (s_acl (ii).mode, 3, 1); d_acl (ii).mbz1 = "0"b; end; if ^star_star_sw then do; /* add "s *.*.*" if not already a *.*.* entry */ d_acl (dac).userid = "*.*.*"; d_acl (dac).mode = "100"b; d_acl (dac).mbz1 = "0"b; end; else dac = dac - 1; call hcs_$add_dir_acl_entries (dirname, unique, dap, dac, code); free d_acl in (free_area); free s_acl in (free_area); call hcs_$set_safety_sw (dirname, unique, safety_sw, code); if code ^= 0 then goto error_return; dir_rings (1) = cbi.rings (1); dir_rings (2) = cbi.rings (3); call hcs_$set_dir_ring_brackets (dirname, unique, dir_rings, code); if code ^= 0 then goto error_return; call hcs_$create_branch_ (unique_dir, "0", addr (cbi), code); /* create component "0" */ if code ^= 0 then do; /* if can't do it */ del_dir: call hcs_$delentry_file (dirname, unique, 0); /* delete the unique directory */ go to error_return; /* give up */ end; if SSF_existed then do; call hcs_$get_max_length_seg (remember_ptr, max_length, code); /* Get the max length of the SSF. */ if code ^= 0 then go to del_zero; /* Cleanup - delete component zero and the directory. */ call hcs_$set_max_length (unique_dir, "0", max_length, code); /* Set the max length of component zero. */ if code ^= 0 then go to del_zero; /* Cleanup */ /* DRV - set component volume backup switch here */ call hcs_$fs_move_file (dirname, ename, 0, unique_dir, "0", code); /* move the SSF into component zero */ if code ^= 0 then do; /* if can't do it */ del_zero: call hcs_$delentry_file (unique_dir, "0", 0); /* delete the component zero, don't save code */ go to del_dir; /* and delete the directory, and give up */ end; call hcs_$terminate_file (dirname, ename, binary (known, 1), code); /* terminate the SSF, saving the segno if it was known */ if code ^= 0 then go to error_return; /* If reloading in ring 1, delete_ may not be found. If so try deleting with hcs */ on condition (linkage_error) begin; call hcs_$delentry_file (dirname, ename, code); goto revert_it; end; call delete_$path (dirname, ename, "100111"b, "", code); /* delete the SSF */ revert_it: revert linkage_error; if code ^= 0 then go to error_return; if known then do; /* if it was known */ call hcs_$initiate (unique_dir, "0", "", 1, 0, remember_ptr, code); /* initiate new on with old segno */ if code ^= 0 then go to error_return; end; do i = 1 to branch.nnames; /* add all the names */ call hcs_$chname_file (dirname, unique, "", (status_entry_names (i)), code); if code ^= 0 then go to error_return; end; call hcs_$chname_file (dirname, unique, unique, "", code); /* delete the unique name */ end; call hcs_$set_bc (dirname, ename, 1, code); /* remember that we have one already in MSF */ go to return_statement; /* Entry unmake_msf takes MSF path, and makes component zero if it exists into an SSF with the same name. Otherwise, it leaves a new, zero length segment, after deleting the MSF. */ unmake_msf_: entry (dirname_arg, ename_arg, copysw, rbs, code); cur_ring = cu_$level_get (); unspec (cbi) = ""b; cbi.version = create_branch_version_2; cbi.chase_sw = "1"b; cbi.parent_ac_sw = "1"b; /* for now */ cbi.rings = cur_ring; cbi.userid = get_group_id_$tag_star (); cbi.mode = "101"b; if sys_areap = null then sys_areap = get_system_free_area_ (); status_area_ptr = addr (names_area); acl_area_ptr = sys_areap; unspec (branch) = ""b; status_ptr = addr (branch); on cleanup call free_allocated_storage; call hcs_$get_link_target (dirname_arg, ename_arg, dirname, ename, code); /* get real path name */ if code ^= 0 then go to error_return; path = rtrim (dirname, " ") || ">" || ename; call hcs_$initiate_count (path, "0", "", cbi.bitcnt, 0, remember_ptr, code); /* see about component zero */ if code ^= 0 then if code ^= error_table_$segknown then do; component_0_existed = "0"b; /* not there */ known = "0"b; cbi.bitcnt = 0; /* zero bitcount */ end; else do; component_0_existed = "1"b; /* did exist */ known = "1"b; /* and was known in the process */ end; else do; component_0_existed = "1"b; /* existed */ known = "0"b; /* but wasn't known */ end; if component_0_existed /* component zero exists */ then do; /* make sure safety_sw is off */ call hcs_$get_safety_sw_seg (remember_ptr, safety_sw, code); if code = 0 then if safety_sw /* mustn't delete msf components */ then code = error_table_$safety_sw_on; if code ^= 0 /* error has occurred */ then go to error_return; /* abort */ call hcs_$get_access_class (path, "0", cbi.access_class, code); if code ^= 0 then goto error_return; call hcs_$get_access_class (path, "", temp_acc, code); if code ^= 0 then goto error_return; if cbi.access_class ^= temp_acc then cbi.priv_upgrade_sw = "1"b; cbi.parent_ac_sw = ^cbi.priv_upgrade_sw; /* DRV - get volume backup switch from component 0 here */ end; call hcs_$list_inacl (dirname, ename, acl_area_ptr, aclp, null, acl_count, cur_ring, code); /* get initial acl */ call hcs_$status_long (dirname, ename, 1, addr (branch), status_area_ptr, code); /* find out names */ if code ^= 0 then go to error_return; unique = unique_chars_ (""b); /* make up a unique name */ call hcs_$create_branch_ (dirname, unique, addr (cbi), code); if code ^= 0 then go to error_return; call hcs_$add_acl_entries (dirname, unique, aclp, acl_count, code); /* put initial acl back on again */ if component_0_existed then do; /* if comp. 0 used to exist */ call hcs_$get_max_length_seg (remember_ptr, max_length, code); if code ^= 0 then go to del_comp; /* Get max length of comp. 0. */ call hcs_$set_max_length (dirname, unique, max_length, code); if code ^= 0 then go to del_comp; /* Transfer max length of comp. 0 to SSF. */ if copysw then do; /* We want to save contents of comp. 0. */ call hcs_$fs_move_file (path, "0", 0, dirname, unique, code); /* move the old one into the new */ if code ^= 0 then do; /* error and recovery */ del_comp: call hcs_$delentry_file (dirname, unique, 0); go to error_return; end; end; /* DRV - set SSF volume backup switch here */ end; call delete_$path (dirname, ename, "100111"b, "", code); /* delete the old MSF */ if code ^= 0 then go to error_return; do i = 1 to branch.nnames; /* move in old names */ call hcs_$chname_file (dirname, unique, "", (status_entry_names (i)), code); if code ^= 0 then go to error_return; end; call hcs_$chname_file (dirname, unique, unique, "", code); /* delete unique name */ if known then do; /* if it was known */ call hcs_$initiate (dirname, ename, "", 1, 0, remember_ptr, code); /* initiate with old segno */ if code ^= 0 then go to error_return; end; return_statement: error_return: call free_allocated_storage; return; /* Internal proc free_allocated_storage looks at all the pointers used by this subroutine to point to free storage, and frees everything that hasn't been freed yet. */ free_allocated_storage: proc; if aclp ^= null then free s_acl in (free_area); if dap ^= null then free d_acl in (free_area); return; end free_allocated_storage; end make_msf_;  msf_manager_.pl1 11/11/89 1133.6r w 11/11/89 0800.0 444294 /****^ *********************************************************** * * * Copyright, (C) Honeywell Bull Inc., 1987 * * * * Copyright, (C) Honeywell Information Systems Inc., 1983 * * * * Copyright (c) 1972 by Massachusetts Institute of * * Technology and Honeywell Information Systems, Inc. * * * *********************************************************** */ /* msf_manager_ manipulates multi-segment files. It uses file control blocks, created by the open entry. */ /****^ HISTORY COMMENTS: 1) change(83-12-20,Margolin), approve(), audit(), install(): pre-hcom comments: Initially coded May 1972 by Dan Bricklin. Modified July 1973 by E. Stone to work for both 64k and 256k MSFs to terminate MSFs completely, and to save the bitcount in the adjust entry Modified April 1974 by E. Stone to add the acl_delete and acl_add entries to remove the obsolete entries list_acl and replace_acl which depended on CACLS Modified by Kobziar on 7-10-74 to have the acl commands change the msf dir acl last Modified 9/6/75 by Steve Herbst to chase links and store link target in fcb Modified 6/21/77 by M. Asherman to call hcs_$initiate and initiate_count with proper setting of the copy_ctl_sw argument Modified 7/26/77 by M. Asherman to honor setting of safety_switch on msf by not deleting components on call to adjust entry in this case Modified 05/05/78 by C. D. Tavares to add AIM-upgraded MSF capability. error_table_$inconsistent_msf added and error codes reworked 09/10/79 S. Herbst Modified: 06/08/82 by Lindsey Spratt: Added new entrypoint, msf_get_ptr, which guarantees the msf is always an MSF (i.e., even with only component 0 there is a directory with one component named "0"). Changed to use the pathname_ function to build fcb.path. 2/1/83 Jay Pattin to make ACL entries force access if necessary. 6/23/83 Jay Pattin to fix bug in access forcing change Repaired to properly return acls for users with null effective access, BIM, 831010. 12/20/83 by Matthew Pierret: Changed acl entries to always ensure that the MSF directory has an acl entry for *.*.* and that all MSF directory acl entries have modes no less than 's'. 2) change(84-01-19,Pierret), approve(), audit(), install(): Added substr around the (d e)name_arg args when assigning their values to fcb.(d e)name to avoid potential stringsize conditions. 12/27/84 by Keith Loepere for version 2 create_branch_info. 3) change(85-12-24,Margolin), approve(86-02-24,MCR7325), audit(86-06-19,Lippard), install(86-07-17,MR12.0-1097): Changed msf_manager_$adjust to truncate to the bit boundary instead of the word boundary. Fixed some declarations. 4) change(86-07-11,Margolin), approve(86-07-11,MCR7325), audit(86-07-11,GDixon), install(86-07-17,MR12.0-1097): Simplified code based upon new bit-boundary modifications of change (3). 5) change(87-01-07,GWMay), approve(87-01-07,PBF7325), audit(87-01-09,GDixon), install(87-01-12,MR12.0-1268): added the subroutines "msf_initiate_file_" and "msf_terminate_file_" to provide to needed functions of the system subroutines "initiate_file_" and "terminate_file_". The internal routines are needed because the system subroutines are located in the systems_standard_library and are not available at system reload time. The subroutines cannot be moved to system_library_1 because they also reference >sss subroutines. END HISTORY COMMENTS */ /* format: style2 */ msf_manager_: procedure; /**** * NOTE: This program contains a partial fix for a problem. The problem was that the dir acl was is changed to match the msf acl. Thus, when a user had null effective access to an MSF, she had null access to the msf dir, and could not list the acl of the first component. This was fixed partially by changing the acl entries to never change the acl such that 's' mode is removed from any entry. The remaining problem is that existing MSFs that have null access modes on the MSF dir are not helped by the change. This can be wrote around by using the acl of the dir itself to deduce the MSF acl. Unfortunately, there is no extended acl on the dir, so the extended modes are returned null. The complete fix is to run MSF's in ring 2, leaving s to * on the ring 2 dir, and thus allowing component zero's acl to be listed, always. This should be addresses at a later time. --BIM */ dcl aclp ptr; dcl areap ptr; dcl area_ret_ptr ptr; dcl acl_idx fixed bin; dcl bc fixed bin (24); dcl bitcount fixed bin (24); dcl cleanup condition; dcl (code, code1) fixed bin (35); dcl component fixed bin; dcl createsw bit (1); dcl force_msf_creation bit (1) aligned; dcl forced_access bit (1) aligned; dcl char builtin; dcl changed bit (1); dcl current_user char (32); dcl cu_$level_get entry returns (fixed bin (3)); dcl cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)); dcl dac fixed bin; dcl dap ptr init (null); dcl delete fixed bin static init (2) options (constant); dcl delete_$path entry (char (*), char (*), bit (6) aligned, char (*), fixed bin (35)); dcl delete_$ptr entry (ptr, bit (6) aligned, char (*), fixed bin (35)); dcl divide builtin; dcl dname_arg char (*); dcl ename_arg char (*); dcl entry_name char (32); dcl eptr ptr init (null); dcl error_table_$badpath ext fixed bin (35); dcl error_table_$badcall ext fixed bin (35); dcl error_table_$dirseg ext fixed bin (35); dcl error_table_$incorrect_access fixed bin (35) ext static; dcl error_table_$inconsistent_msf ext fixed bin (35); dcl error_table_$no_s_permission ext fixed bin (35); dcl error_table_$noentry ext fixed bin (35); dcl error_table_$nomatch ext fixed bin (35); dcl error_table_$not_seg_type ext fixed bin (35); dcl error_table_$safety_sw_on ext fixed (35); dcl fcbp ptr; dcl free_area area based (get_system_free_area_ ()); dcl get_group_id_ entry returns (char (32)); dcl get_group_id_$tag_star entry returns (char (32)); dcl get_system_free_area_ entry () returns (ptr); dcl hcs_$add_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$add_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$add_inacl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35)); dcl hcs_$create_branch_ entry (char (*), char (*), ptr, fixed bin (35)); dcl hcs_$delete_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_dir_acl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (35)); dcl hcs_$delete_inacl_entries entry (char (*), char (*), ptr, fixed bin, fixed bin (3), fixed bin (35)); dcl hcs_$get_access_class ext entry (char (*), char (*), bit (72) aligned, fixed bin (35)); dcl hcs_$get_link_target entry (char (*), char (*), char (168), char (32), fixed bin (35)); dcl hcs_$get_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl hcs_$get_max_length_seg entry (ptr, fixed bin (19), fixed bin (35)); dcl hcs_$get_ring_brackets entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl hcs_$get_user_effmode entry (char (*), char (*), char (*), fixed bin, fixed bin (5), fixed bin (35)); dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35)); dcl hcs_$list_dir_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$list_acl entry (char (*), char (*), ptr, ptr, ptr, fixed bin, fixed bin (35)); dcl hcs_$make_seg entry (char (*), char (*), char (*), fixed bin, pointer, fixed bin (35)); dcl hcs_$replace_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)); dcl hcs_$replace_dir_acl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (35)); dcl hcs_$replace_inacl entry (char (*), char (*), ptr, fixed bin, bit (1), fixed bin (3), fixed bin (35)); dcl hcs_$set_bc entry (char (*), char (*), fixed bin (24), fixed bin (35)); dcl hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35)); dcl hcs_$set_max_length entry (char (*), char (*), fixed bin (19), fixed bin (35)); dcl hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35)); dcl hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), fixed bin (35)); dcl hcs_$terminate_file entry (char (*), char (*), fixed bin (1), fixed bin (35)); dcl hcs_$terminate_noname entry (ptr, fixed bin (35)); dcl hcs_$truncate_file entry (char (*), char (*), fixed bin, fixed bin (35)); dcl hcs_$truncate_seg entry (ptr, fixed bin, fixed bin (35)); dcl ltrim builtin; dcl min builtin; dcl mod builtin; dcl pathname_ entry (char (*), char (*)) returns (char (168)); dcl i fixed bin; dcl index builtin; dcl ibp ptr; dcl j fixed bin; dcl lastp ptr init (null); dcl length builtin; dcl make_msf_ entry (char (*), char (*), (3) fixed bin (3), fixed bin (35)); dcl max builtin; dcl max_length fixed bin (19); dcl msf fixed bin static init (2) options (constant); dcl name char (32); dcl names (1000) char (32) based (nptr); dcl not_exists fixed bin static init (-1) options (constant); dcl nptr ptr init (null); dcl null builtin; dcl num_of_entries fixed bin; dcl P_switches bit (3) parameter; dcl ring fixed bin (3); dcl scode fixed bin (35); dcl saved_mode bit (36) aligned; dcl segptr ptr; dcl sds bit (1); dcl set_bc_sw bit (1) def (switches) pos (1); dcl ssf fixed bin static init (1) options (constant); dcl STAR_STAR_USERID init ("*.*.*") char (32) aligned internal static options (constant); dcl substr builtin; dcl switches bit (3); dcl sys_info$max_seg_size ext fixed bin (19); dcl temp_acc bit (72) aligned; dcl temp_segptr ptr; dcl terminate fixed bin static init (1) options (constant); dcl terminate_sw bit (1) def (switches) pos (3); dcl truncate_sw bit (1) def (switches) pos (2); dcl type fixed bin (2); dcl (addr, unspec) builtin; dcl unmake_msf_ entry (char (*), char (*), bit (1), (3) fixed bin (3), fixed bin (35)); dcl 1 s_acl (acl_count) based (aclp) aligned, 2 userid char (32), 2 mode bit (3) unaligned, 2 mbz1 bit (33) unaligned, 2 mbz2 bit (36), 2 err_code fixed bin (35), 1 d_acl (dac) based (dap) aligned, 2 userid char (32), 2 mode bit (3) unaligned, 2 mbz1 bit (33) unaligned, 2 err_code fixed bin (35), 1 d_acl_entry aligned like d_acl; %page; %include access_mode_values; %include acl_structures; %page; %include create_branch_info; %page; %include terminate_file; %page; %include system_constants; %page; dcl 1 branch_info aligned automatic like create_branch_info; dcl 1 entries (num_of_entries) based (eptr) aligned, 2 type bit (2) unal, 2 nname bit (16) unal, 2 nindex fixed bin (17) unal; dcl 1 fcb based (fcbp) aligned, /* the multi-segment file control block */ 2 version fixed bin, /* version of this structure - 0 now */ 2 type fixed bin, /* form of msf - ssf, msf, or not_exists */ 2 max_components fixed bin, /* maximum number of components (same as bitcount) */ 2 max_len fixed bin (19), /* Max number of words in each component. */ 2 pad (1) fixed bin, 2 pathnames unaligned, /* dirnname, ename, and combined of the file */ 3 dname char (168), 3 ename char (32), 3 path char (168), 2 initiated_components, /* information about the initiated components in the file */ 3 number fixed bin, /* how many are initiated */ 3 highest_value fixed bin, /* the highest component value of those inited */ 3 listp ptr, /* ptr to head of the list of inited segs */ 2 rbs (3) fixed bin (3), /* save ring bracks */ 2 upgrade_sw bit (1) aligned, /* if components are multiclass segments */ 2 access_class bit (72) aligned; /* acc if upgrade_sw ON */ /* DRV - add volume backup switch to FCB here */ dcl 1 initiation_bead based (ibp) aligned, /* one for each initiated component of the msf */ 2 component fixed bin, /* which component it is */ 2 bitcount fixed bin (24), /* its bitcount */ 2 segptr ptr, /* a ptr to it */ 2 next ptr; /* next bead in list or null */ /* */ /* The open entry creates a file control block, returning a ptr. It puts it in the area returned by get_system_free_area_. The file need not exist to have a file control block. */ open: entry (dname_arg, ename_arg, fcbp, code); fcbp = null; /* first set fcbp to null, in case of errors */ allocate fcb in (free_area) set (fcbp); /* allocate the file control block */ fcb.version = 0; /* set the version to the current version - 0 */ fcb.dname = substr (dname_arg, 1, min (length (fcb.dname), length (dname_arg))); fcb.ename = substr (ename_arg, 1, min (length (fcb.ename), length (ename_arg))); /* substr is used to prevent potential stringsize */ fcb.number = 0; /* none are initiated */ fcb.highest_value = 0; /* so no highest value of those initiated */ fcb.listp = null; /* no list of those initiated */ call hcs_$status_minf (fcb.dname, fcb.ename, 1, type, bitcount, code); /* find out about it */ if code = 0 | code = error_table_$no_s_permission then do; if type < 1 | type > 2 then go to BAD_MSF; fcb.type = type; /* if no error, then type of msf is type */ if code = 0 then call hcs_$get_link_target (fcb.dname, fcb.ename, fcb.dname, fcb.ename, code1); end; else do; /* else if error, then not_exists */ fcb.type = not_exists; fcb.max_len = sys_info$max_seg_size; /* File will grow to largest allowed size. */ fcb.rbs (*) = cu_$level_get (); fcb.upgrade_sw = ""b; /* DRV - initialize volume backup switch in FCB here */ end; /* concatenate the dname and ename to make a path name */ fcb.path = pathname_ ((fcb.dname), (fcb.ename)); if fcb.type = ssf then do; /* If single segment file. */ fcb.max_components = 1; /* Only one component. */ call hcs_$get_max_length (fcb.dname, fcb.ename, fcb.max_len, code); if code ^= 0 then go to free_it; /* Get max length of existing SSF. */ call hcs_$get_access_class (fcb.dname, fcb.ename, fcb.access_class, code); if code ^= 0 then goto free_it; call hcs_$get_access_class (fcb.dname, "", temp_acc, code); if code ^= 0 then do; code = 0; fcb.upgrade_sw = "0"b; end; else if fcb.access_class ^= temp_acc then fcb.upgrade_sw = "1"b; /* DRV - get volume backup switch from SSF here and insert it into FCB */ end; else if fcb.type ^= msf then fcb.max_components = 0; /* if not exists, then no components */ else do; /* is already an MSF */ if bitcount = 0 then do; /* if type directory, and zero bc, then error */ code = error_table_$dirseg; free_it: free fcbp -> fcb in (free_area); /* free the file control block */ return; end; fcb.max_components = bitcount; /* otherwise, get number of components from bitcount */ call hcs_$get_ring_brackets (fcb.path, "0", fcb.rbs, code); /* get ring brackets of component 0 */ if code ^= 0 then fcb.rbs (*) = cu_$level_get (); call hcs_$get_max_length (fcb.path, "0", fcb.max_len, code); /* Get max length of component 0. */ if code ^= 0 then fcb.max_len = sys_info$max_seg_size; call hcs_$get_access_class (fcb.path, "0", fcb.access_class, code); if code ^= 0 then fcb.upgrade_sw = ""b; else do; call hcs_$get_access_class (fcb.path, "", temp_acc, code); if code ^= 0 then fcb.upgrade_sw = ""b; else if temp_acc ^= fcb.access_class then fcb.upgrade_sw = "1"b; end; /* DRV - get volume backup switch from component 0 here */ code = 0; end; return; /* return to caller */ /* The msf_get_ptr entry works like the get_ptr entry (below) except it forces the creation of an MSF, even if only component 0 is referenced. If the file already exists as an SSF, however, it won't be converted as long as only component 0 is referenced. */ msf_get_ptr: entry (fcbp, component, createsw, segptr, bc, code); force_msf_creation = "1"b; goto GET_PTR_JOIN; /* The get_ptr entry will return a ptr to the specified component in the file. If not found, it will attempt to create it if createsw = "1"b. If the file is a single_segment_file (SSF), and a component greater than zero is requested, this entry will call make_msf_ to change the file from an SSF to an MSF. */ get_ptr: entry (fcbp, component, createsw, segptr, bc, code); force_msf_creation = "0"b; GET_PTR_JOIN: code = 0; segptr = null; /* start with a null return pointer */ if component < 0 then go to BAD_ARG; /* make a check on the request */ if fcb.type = not_exists then /* if the file did not previously exist then */ if ^createsw then go to NOT_FOUND; /* if the callers does not want it created, error */ else do; if ^force_msf_creation then do; call hcs_$make_seg (dname, ename, "", 01010b, segptr, code); /* otherwise, create a segment */ if segptr = null then return; /* if unable, then error */ call hcs_$get_link_target (dname, ename, fcb.dname, fcb.ename, code); /* store target in fcb */ if code ^= 0 then return; i = index (fcb.dname, " "); if i = 0 then if fcb.ename = "" then fcb.path = fcb.dname; else go to BAD_PATH; else fcb.path = substr (fcb.dname, 1, i - 1) || ">" || fcb.ename; bc = 0; /* bitcount starts at zero */ fcb.type = ssf; /* starts as an ssf */ fcb.max_components = 1; /* with only one component */ if component = 0 then go to fill_in_bead; /* if caller only wants comp. zero, then almost done */ end; call make_msf_ (dname, ename, fcb.rbs, code); /* otherwise, change it to an msf */ if code ^= 0 then return; /* error */ fcb.type = msf; /* now it is an msf */ call delete_$path (path, "0", "100100"b, "", code); /* delete the zero component */ if code ^= 0 then return; fcb.max_components = 0; /* none inited now */ go to make_seg_msf; /* now pretend that we started with an msf */ end; if fcb.type = ssf then do; /* if it was an ssf */ if component ^= 0 then /* if caller wants other than comp. zero */ if createsw then do; /* and wants it to be created then */ call make_msf_ (dname, ename, fcb.rbs, code); /* change to an msf */ if code ^= 0 then return; fcb.type = msf; go to make_seg_msf; /* and pretend we started that way */ end; else go to NOT_FOUND; /* else, if not to be created, error */ if initiated_components.number = 1 then do; /* if a component has already been inited */ ibp = fcb.listp; /* only can be one - component zero, what we want */ already_initiated: bc = initiation_bead.bitcount;/* we have the bitcount saved from an init call */ segptr = initiation_bead.segptr; /* and the ptr saved */ return; /* that's it, finished */ end; else do; /* else, if not already inited */ call hcs_$initiate_count (dname, ename, "", bc, 1, segptr, code); /* try to initiated it */ if segptr = null then return; /* error */ go to fill_in_bead; /* make an initiation bead */ end; end; if fcb.type ^= msf then go to BAD_CONTROL_BLOCK; /* bad type field in fcb */ ibp = find_component (component); /* see if comp. already was initiated */ if ibp ^= null then go to already_initiated; /* if so, return the old values */ not_initiated: call hcs_$initiate_count (path, make_char (component), "", bc, 1, segptr, code); /* else try to initiate it */ if segptr ^= null then go to fill_in_bead; /* ok, so make an initiation bead */ if ^createsw then return; /* if not to create it, then give up */ make_seg_msf: current_user = get_group_id_$tag_star (); entry_name = make_char (component); unspec (branch_info) = ""b; branch_info.version = create_branch_version_2; branch_info.chase_sw = ""b; branch_info.priv_upgrade_sw = fcb.upgrade_sw; branch_info.parent_ac_sw = ^branch_info.priv_upgrade_sw; branch_info.access_class = fcb.access_class; branch_info.mode = "101"b; branch_info.rings = fcb.rbs; branch_info.userid = current_user; call hcs_$create_branch_ (path, entry_name, addr (branch_info), code); if code ^= 0 then return; call hcs_$set_max_length (path, entry_name, fcb.max_len, code); if code ^= 0 then return; /* DRV - set volume backup switch on new seg here */ call hcs_$initiate (path, entry_name, "", 0, 1, segptr, code); if segptr = null then return; /* if failed, then give up */ bc = 0; /* bitcount starts at zero */ if component + 1 > fcb.max_components then do; /* if max_components needs to be upped */ fcb.max_components = component + 1; call hcs_$set_bc (dname, ename, component + 1, code); if code ^= 0 then return; end; fill_in_bead: allocate initiation_bead in (free_area) set (ibp);/* make an initiation bead */ initiation_bead.component = component; /* fill it in */ initiation_bead.bitcount = bc; initiation_bead.segptr = segptr; initiation_bead.next = fcb.listp; /* thread this at the head of the list */ /* open initializes first fcb.listp to null */ if component >= fcb.max_components then fcb.max_components = component + 1; fcb.highest_value = max (fcb.highest_value, component); /* remember highest value */ fcb.listp = ibp; /* thread into list */ fcb.number = fcb.number + 1; code = 0; return; /* thats it */ /* The adjust entry can set the bitcount, truncate, and terminate the components of an MSF. It is given a maximum component, and bitcount within that component. All components before that component are given bitcount sys_info$max_seg_size, and all after are deleted. What it is to do is determined by switches: "bxt"b, where b is set bitcount, x is truncate, and t is terminate. */ adjust: entry (fcbp, component, bc, P_switches, code); switches = P_switches; if component < 0 then go to BAD_ARG; /* check argument */ if fcb.type = not_exists then go to NOT_FOUND; /* see if file is around */ if fcb.type = ssf then do; /* if only a single segment */ if component ^= 0 then go to SEGMENT; /* can't adjust to that length (>0) */ ibp = find_component (0); /* see if it was initiated */ adjust_ssf: if truncate_sw & (mod (bc, 36) ^= 0) then if ibp = null then begin; /* have to zero extra bits */ temp_segptr = null; on cleanup begin; if temp_segptr ^= null then call msf_terminate_file_ (temp_segptr, 0, TERM_FILE_TERM, (0)); end; call msf_initiate_file_ (dname, ename, W_ACCESS, temp_segptr, (0), code); if code ^= 0 then return; if set_bc_sw then do; call msf_terminate_file_ (temp_segptr, bc, TERM_FILE_TRUNC_BC_TERM, code); set_bc_sw = "0"b; end; else call msf_terminate_file_ (temp_segptr, bc, (TERM_FILE_TRUNC | TERM_FILE_TERM), code); if code ^= 0 then return; truncate_sw = "0"b; end; else do; if set_bc_sw then do; call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC_BC, code); initiation_bead.bitcount = bc; set_bc_sw = "0"b; end; else call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC, code); if code ^= 0 then return; truncate_sw = "0"b; end; if set_bc_sw then do; /* if we are to set the bitcount */ if ibp = null then call hcs_$set_bc (dname, ename, bc, code); /* use normal entry if no pointer to set bc */ else call hcs_$set_bc_seg (initiation_bead.segptr, bc, code); /* else use faster ptr entry if we have it */ if code ^= 0 then return; if ibp ^= null then initiation_bead.bitcount = bc; end; if truncate_sw then do; /* shall we truncate it? */ if ibp = null then call hcs_$truncate_file (dname, ename, divide (bc, 36, 17, 0), code); /* use the truncate entries */ else call hcs_$truncate_seg (initiation_bead.segptr, divide (bc, 36, 17, 0), code); if code ^= 0 then return; end; if terminate_sw then do; /* shall we terminate it */ if ibp = null then call hcs_$terminate_file (dname, ename, 0, code); else call remove_bead (terminate); /* remove the initiation bead while terming it */ code = 0; /* set code to 0 */ end; return; end; if fcb.type ^= msf then go to BAD_CONTROL_BLOCK; /* not msf */ if component = 0 then do; /* it msf, and want to end up with ssf */ lastp = null; /* terminate and remove beads of all ^=0 */ ibp = fcb.listp; do i = 1 to fcb.number while (ibp ^= null); if initiation_bead.component ^= 0 then call remove_bead (terminate); else lastp = ibp; if lastp = null then ibp = fcb.listp; else ibp = lastp -> initiation_bead.next; end; if fcb.listp = null then fcb.number = 0; /* if none left (0 not inited) */ else fcb.number = 1; /* if zero was initied */ call unmake_msf_ (dname, ename, (bc ^= 0), fcb.rbs, code); /* make an ssf, copy only if bc>0 */ if code ^= 0 then if code ^= error_table_$safety_sw_on /* real error */ then return; /* abort */ else go to adjust_loop; /* still zero contents */ fcb.type = ssf; fcb.max_components = 1; go to adjust_ssf; /* pretend we are an ssf */ end; if component > fcb.max_components then go to BAD_ARG; /* component too high */ adjust_loop: forced_access = "0"b; on cleanup call free_allocated_storage; /* in case we are quitted out of, cleanup area */ call hcs_$star_ (path, "**", 2, get_system_free_area_ (), num_of_entries, eptr, nptr, code); /* find all the names(i.e. components) */ if code ^= 0 then go to finished_adjust; /* error */ do i = 1 to num_of_entries; /* do for each entry */ name = names (entries (i).nindex); /* find the i-th name */ j = cv_dec_check_ (name, code); /* see that it is a number */ if code ^= 0 then go to BAD_MSF; if j < 0 then go to BAD_MSF; /* check that it is ok */ ibp = find_component (j); /* see if we perchance have a ptr to it */ if j = component then /* if the adjusting component */ if truncate_sw then do; /* shall we truncate that one? */ if mod (bc, 36) = 0 then do; if ibp = null then call hcs_$truncate_file (path, name, divide (bc, 36, 17, 0), code); else call hcs_$truncate_seg (initiation_bead.segptr, divide (bc, 36, 17, 0), code); if code ^= 0 then go to finished_adjust; end; else if ibp = null then begin; /* have to initiate it to zero the bits */ temp_segptr = null; on cleanup begin; if temp_segptr ^= null then call msf_terminate_file_ (temp_segptr, 0, TERM_FILE_TERM, (0)); end; call msf_initiate_file_ (path, name, W_ACCESS, temp_segptr, (0), code); if code ^= 0 then go to finished_adjust; if set_bc_sw then call msf_terminate_file_ (temp_segptr, bc, TERM_FILE_TRUNC_BC_TERM, code); else call msf_terminate_file_ (temp_segptr, bc, (TERM_FILE_TRUNC | TERM_FILE_TERM), code); if code ^= 0 then go to finished_adjust; end; else do; if set_bc_sw then call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC_BC, code); else call msf_terminate_file_ (initiation_bead.segptr, bc, TERM_FILE_TRUNC, code); if code ^= 0 then go to finished_adjust; end; end; if j <= component then do; /* up to and including adjusting comp */ if set_bc_sw then do; /* shall we set the bitcount? */ if j = component then bitcount = bc; /* adjusting - do to "bc" */ else do; /* else an entire file's worth */ if ibp = null then call hcs_$get_max_length (path, name, max_length, code); else call hcs_$get_max_length_seg (initiation_bead.segptr, max_length, code); if code ^= 0 then go to finished_adjust; bitcount = 36 * max_length; end; if ^(truncate_sw & (j = component) & (mod (bc, 36) ^= 0)) /** truncate_sw processing handles last component in this case **/ then do; if ibp = null then call hcs_$set_bc (path, name, bitcount, code); /* set the bitcount */ else call hcs_$set_bc_seg (initiation_bead.segptr, bitcount, code); if code ^= 0 then go to finished_adjust; end; if ibp ^= null then initiation_bead.bitcount = bitcount; end; if terminate_sw then do; /* shall we terminate it? */ if ibp = null then call hcs_$terminate_file (path, name, 0, code); else call remove_bead (terminate); /* remove initiation bead while terming */ code = 0; /* set code to 0 */ end; end; else do; /* components after the adjusting one */ if ibp = null then call delete_$path (path, name, "000100"b, "", code); /* delete it */ else do; call remove_bead (delete); code = scode; end; if code ^= 0 then if code = error_table_$safety_sw_on then do; /* still zero contents */ call hcs_$truncate_file (path, name, 0, code); if code ^= 0 then go to finished_adjust; /* abort */ call hcs_$set_bc (path, name, 0, code); if code ^= 0 then go to finished_adjust; else code = error_table_$safety_sw_on; /* prevents resetting max_components */ end; else go to finished_adjust; end; end; if (code = 0) & (component + 1 ^= fcb.max_components) then do; /* have to reset the max_components */ fcb.max_components = component + 1; call hcs_$set_bc (dname, ename, component + 1, code); end; finished_adjust: if code ^= 0 then if code = error_table_$safety_sw_on /* not an error to user */ then code = 0; call free_allocated_storage; /* clean up */ return; /* The close entry frees the file control block. It will terminate all components that are still thought to be initiaed, freeing their initiation beads. */ close: entry (fcbp); lastp = null; ibp = fcb.listp; do i = 1 to fcb.number + 1 while (ibp ^= null); call remove_bead (terminate); ibp = fcb.listp; end; free fcbp -> fcb in (free_area); return; /* The acl_list entry returns the acl on the MSF */ acl_list: /* entry for listing acls */ entry (fcbp, areap, area_ret_ptr, aclp, acl_count, code); if fcb.type = msf then do; eptr, nptr, dap = null; forced_access = "0"b; on cleanup call free_allocated_storage (); /* in case we are quitted out of, cleanup area */ call ensure_access ("1"b); ring = cu_$level_get (); /* get validation level */ call hcs_$list_acl (path, "0", areap, area_ret_ptr, aclp, acl_count, code); if code = error_table_$incorrect_access then call DEDUCE_ACL_FROM_DIR_ACL; if code = error_table_$noentry | code = error_table_$dirseg then code = error_table_$inconsistent_msf; call free_allocated_storage (); end; else if fcb.type = ssf then call hcs_$list_acl (dname, ename, areap, area_ret_ptr, aclp, acl_count, code); else go to BAD_CONTROL_BLOCK; return; /* The acl_delete entry deletes the acl on an MSF */ acl_delete: /* entry for deleting acls */ entry (fcbp, aclp, acl_count, code); if fcb.type = not_exists then go to NOT_FOUND; /* dumb move */ if fcb.type = ssf then do; /* one segment simple case */ call hcs_$delete_acl_entries (dname, ename, aclp, acl_count, code); /* do it */ return; end; if fcb.type ^= msf then go to BAD_CONTROL_BLOCK; eptr, nptr, dap = null; forced_access = "0"b; on cleanup call free_allocated_storage; /* in case we are quitted out of, cleanup area */ call ensure_access ("0"b); ring = cu_$level_get (); /* get current level */ call hcs_$delete_inacl_entries (dname, ename, aclp, acl_count, ring, code); /* remove entries from inacl */ if code ^= 0 then go to error_return; call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code); /* get all names */ if code ^= 0 then if code = error_table_$nomatch then go to DEL_DIR; else go to error_return; do i = 1 to num_of_entries; /* go through list */ call hcs_$delete_acl_entries (path, names (entries (i).nindex), aclp, acl_count, code); if code ^= 0 then do; INCONSISTENT: code = error_table_$inconsistent_msf; go to error_return; end; end; call free_allocated_storage; DEL_DIR: /* delete the directory acl entries on the msf directory */ call hcs_$delete_dir_acl_entries (dname, ename, aclp, acl_count, code); /* remove entries from dir acl */ if code ^= 0 then go to error_return; /* the *.*.* entry should not be removed from the directory acl */ /* see if that entry is included in the segment acl */ do acl_idx = 1 to acl_count while (s_acl (acl_idx).userid ^= STAR_STAR_USERID); end; if acl_idx <= acl_count then do; /* the *.*.* entry was deleted - return it */ d_acl_entry.userid = STAR_STAR_USERID; d_acl_entry.mode = S_ACCESS; d_acl_entry.mbz1 = "0"b; d_acl_entry.err_code = 0; call hcs_$add_dir_acl_entries (dname, ename, addr (d_acl_entry), 1 /* acl count */, code); /* add the directory acl entry for *.*.* */ if code ^= 0 then go to error_return; end; return; /* The acl_add entry adds the acl on an MSF */ acl_add: /* entry for adding acls */ entry (fcbp, aclp, acl_count, code); if fcb.type = not_exists then go to NOT_FOUND; /* dumb move */ if fcb.type = ssf then do; /* one segment simple case */ call hcs_$add_acl_entries (dname, ename, aclp, acl_count, code); /* do it */ return; end; if fcb.type ^= msf then go to BAD_CONTROL_BLOCK; eptr, nptr, dap = null; forced_access = "0"b; on cleanup call free_allocated_storage; /* in case we are quitted out of, cleanup area */ call ensure_access ("0"b); ring = cu_$level_get (); /* get current level */ call hcs_$add_inacl_entries (dname, ename, aclp, acl_count, ring, code); /* add entries to inacl */ if code ^= 0 then go to error_return; call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code); /* get all names */ if code ^= 0 then if code = error_table_$nomatch then go to ADD_DIR; else go to error_return; do i = 1 to num_of_entries; /* go through list */ call hcs_$add_acl_entries (path, names (entries (i).nindex), aclp, acl_count, code); if code ^= 0 then go to INCONSISTENT; end; ADD_DIR: /* add the directory acl on the msf directory */ dac = acl_count; /* the directory and segment acl's have the same number of entries */ call GET_DIR_ACL; /* get structure for directory acls */ call hcs_$add_dir_acl_entries (dname, ename, dap, dac, code); /* add entries to dir acl */ if code ^= 0 then go to error_return; call free_allocated_storage; return; /* The acl_replace entry replaces the acl on an MSF */ acl_replace: /* entry for replacing acls */ entry (fcbp, aclp, acl_count, sds, code); if fcb.type = not_exists then go to NOT_FOUND; /* dumb move */ if fcb.type = ssf then do; /* one segment simple case */ call hcs_$replace_acl (dname, ename, aclp, acl_count, sds, code); /* do it */ return; end; if fcb.type ^= msf then go to BAD_CONTROL_BLOCK; eptr, nptr, dap = null; forced_access = "0"b; on cleanup call free_allocated_storage; /* in case we are quitted out of, cleanup area */ call ensure_access ("0"b); ring = cu_$level_get (); /* get current level */ call hcs_$replace_inacl (dname, ename, aclp, acl_count, sds, ring, code); /* put new acl on inacl */ if code ^= 0 then go to error_return; call hcs_$star_ (path, "**", 3, get_system_free_area_ (), num_of_entries, eptr, nptr, code); /* get all names */ if code ^= 0 then if code = error_table_$nomatch then go to RPL_DIR; else go to error_return; do i = 1 to num_of_entries; /* go through list */ call hcs_$replace_acl (path, names (entries (i).nindex), aclp, acl_count, sds, code); if code ^= 0 then go to INCONSISTENT; end; RPL_DIR: /* replace the directory acl on the msf directory */ /* is there an entry for *.*.* in the given acl? */ do acl_idx = 1 to acl_count while (s_acl (acl_idx).userid ^= STAR_STAR_USERID); end; if acl_idx <= acl_count then dac = acl_count; /* a *.*.* entry is in the segment acl */ else dac = acl_count + 1; /* no *.*.* entry is in the segment acl - the directory acl needs an extra entry */ call GET_DIR_ACL; /* allocate a directory acl (d_acl) and convert the segment acl */ /* entries into directory acl entries */ if dac > acl_count then do; /* add an entry for *.*.* */ d_acl (dac).userid = STAR_STAR_USERID; d_acl (dac).mode = S_ACCESS; d_acl (dac).mbz1 = "0"b; d_acl (dac).err_code = 0; end; call hcs_$replace_dir_acl (dname, ename, dap, dac, sds, code); /* put on dir acl */ error_return: call free_allocated_storage; return; /* I N T E R N A L P R O C E D U R E S */ find_component: /* sees if initiation bead exists for which */ proc (which) returns (ptr); dcl ip ptr, which fixed bin; if fcb.highest_value < component then return (null); /* greater than highest value inited, so not there */ ip = fcb.listp; /* start at begining of list */ lastp = null; do while (ip ^= null); /* look through whole list */ if ip -> initiation_bead.component = which then return (ip); /* if comp "which", then return ptr to bead */ lastp = ip; /* lastp points to last bead */ ip = ip -> initiation_bead.next; /* now look for next */ end; return (null); /* not found */ end find_component; remove_bead: /* remove an initiation bead */ proc (how); /* how says to delete or terminate */ dcl how fixed bin; if how = terminate then call hcs_$terminate_noname (initiation_bead.segptr, scode); /* if terminate,then do it */ else if how = delete then call delete_$ptr (initiation_bead.segptr, "000100"b, "", scode); /* else if delete,then delete it */ if lastp = null then fcb.listp = ibp -> initiation_bead.next; /* if no bead before it in list */ else lastp -> initiation_bead.next = ibp -> initiation_bead.next; /* else fill in bead before it, to unthread */ fcb.number = fcb.number - 1; /* decrement number inited */ free ibp -> initiation_bead in (free_area); /* free the initiation bead */ return; /* that's it for this routine */ end remove_bead; %page; GET_DIR_ACL: /* transform segment acls to directory acls */ proc; /* for adding or replacing the acl of the MSF itself */ /* 'dac' must be set to the number of directory acl entries */ dcl acl_idx fixed bin; allocate d_acl in (free_area) set (dap); do acl_idx = 1 to acl_count; /* copy segment acl to directory acl */ d_acl (acl_idx).userid = s_acl (acl_idx).userid; /* copy user name */ if (s_acl (acl_idx).mode & W_ACCESS) = ""b then d_acl (acl_idx).mode = S_ACCESS; /* all dir entries must have at least 's' */ else d_acl (acl_idx).mode = SMA_ACCESS; /* 'w' on msf requires 'sma' on dir */ d_acl (acl_idx).mbz1 = "0"b; d_acl (acl_idx).err_code = 0; end; end GET_DIR_ACL; %page; ensure_access: proc (list_switch); declare list_switch bit (1) aligned, mode fixed bin (5), 1 one_acl aligned, 2 name char (32), 2 mode bit (36), 2 code fixed bin (35); call hcs_$get_user_effmode (dname, ename, "", -1, mode, code); if code ^= 0 then return; /* let actual acl error be reported */ if mode >= SM_ACCESS_BIN then return; /* have sufficient access */ one_acl.name = get_group_id_ (); call hcs_$list_dir_acl (dname, ename, null (), null (), addr (one_acl), 1, (0)); changed = (one_acl.code = 0); saved_mode = one_acl.mode; one_acl.mode = SMA_ACCESS; forced_access = "1"b; call hcs_$add_dir_acl_entries (dname, ename, addr (one_acl), 1, (0)); if ^list_switch then do i = 1 to acl_count; /* if we are going to frob it, don't put it back */ if s_acl.userid (i) = one_acl.name then do; forced_access = "0"b; return; end; end; return; end ensure_access; remove_access: proc (); declare 1 delete_acl aligned, 2 name char (32), 2 code fixed bin (35), 1 one_acl aligned, 2 name char (32), 2 mode bit (36), 2 code fixed bin (35); if changed then do; one_acl.name = get_group_id_ (); one_acl.mode = saved_mode; call hcs_$add_dir_acl_entries (dname, ename, addr (one_acl), 1, (0)); end; else do; delete_acl.name = get_group_id_ (); call hcs_$delete_dir_acl_entries (dname, ename, addr (delete_acl), 1, (0)); end; return; end remove_access; %page; free_allocated_storage: /* clean up routine */ proc; if forced_access then call remove_access (); if nptr ^= null then free names in (free_area); if eptr ^= null then free entries in (free_area); if dap ^= null then free dap -> d_acl in (free_area); return; end free_allocated_storage; /* */ make_char: proc (c_number) returns (char (32)); /* change a number into a char(32) string */ dcl c_number fixed bin; return (ltrim (char (c_number))); end make_char; /* */ /* Error reporting statements */ BAD_ARG: BAD_CONTROL_BLOCK: code = error_table_$badcall; return; BAD_MSF: code = error_table_$inconsistent_msf; return; BAD_PATH: code = error_table_$badpath; return; NOT_FOUND: code = error_table_$noentry; return; SEGMENT: code = error_table_$not_seg_type; return; msf_initiate_file_: procedure (P_dirname, P_entryname, P_mode, P_seg_ptr, P_bit_count, P_code); /* parameters */ declare P_bit_count fixed binary (24); declare P_code fixed binary (35); declare P_dirname char (*); declare P_entryname char (*); declare P_mode bit (*); declare P_seg_ptr pointer; /* automatic */ declare bit_count fixed binary (24); declare code fixed binary (35); declare 1 effective_mode, 2 pad1 bit (1), 2 read bit (1), 2 execute bit (1), 2 write bit (1), 2 pad2 bit (1); declare effective_mode_bin fixed binary (5); declare 1 required_mode, 2 read bit (1), 2 execute bit (1), 2 write bit (1); /* builtin */ declare (bit, null, string) builtin; /* external static */ declare error_table_$no_e_permission fixed binary (35) external static; declare error_table_$no_r_permission fixed binary (35) external static; declare error_table_$no_w_permission fixed binary (35) external static; declare hcs_$fs_get_mode entry (pointer, fixed binary (5), fixed binary (35)); declare hcs_$initiate_count entry (char (*), char (*), char (*), fixed binary (24), fixed binary (2), pointer, fixed binary (35)); string (required_mode) = P_mode; P_seg_ptr = null; P_bit_count = 0; P_code = 0; call hcs_$initiate_count (P_dirname, P_entryname, "", bit_count, 0, P_seg_ptr, code); if P_seg_ptr = null then return; call hcs_$fs_get_mode (P_seg_ptr, effective_mode_bin, code); if code = 0 then do; string (effective_mode) = bit (effective_mode_bin); if required_mode.read & ^effective_mode.read then code = error_table_$no_r_permission; else if required_mode.write & ^effective_mode.write then code = error_table_$no_w_permission; else if required_mode.execute & ^effective_mode.execute then code = error_table_$no_e_permission; end; if code ^= 0 then do; call msf_terminate_file_ (P_seg_ptr, 0, TERM_FILE_TERM, 0); P_code = code; P_bit_count = 0; end; else P_bit_count = bit_count; return; end msf_initiate_file_; %page; msf_terminate_file_: procedure (P_seg_ptr, P_bit_count, P_switches, P_code); declare P_seg_ptr pointer; declare P_bit_count fixed binary (24); declare P_switches bit (*); declare P_code fixed binary (35); /* automatic */ declare bit_count fixed binary (24); declare code fixed binary (35); declare 1 tfs aligned like terminate_file_switches; /* based */ declare segment bit (BITS_PER_SEGMENT) based; /* builtin */ declare (divide, mod, null, pointer, string, substr) builtin; /* entry */ declare hcs_$set_bc_seg entry (pointer, fixed binary (24), fixed binary (35)); declare hcs_$terminate_noname entry (pointer, fixed binary (35)); declare hcs_$truncate_seg entry (pointer, fixed binary (19), fixed binary (35)); P_code = 0; bit_count = P_bit_count; string (tfs) = P_switches; if P_seg_ptr = null then return; P_seg_ptr = pointer (P_seg_ptr, 0); if tfs.truncate then do; substr (P_seg_ptr -> segment, bit_count + 1, mod (-bit_count, 36)) = ""b; call hcs_$truncate_seg (P_seg_ptr, divide (bit_count + 35, 36, 19), code); if code ^= 0 then P_code = code; end; if tfs.set_bc then do; call hcs_$set_bc_seg (P_seg_ptr, bit_count, code); if code ^= 0 & P_code = 0 then P_code = code; end; if tfs.terminate then do; call hcs_$terminate_noname (P_seg_ptr, code); if code ^= 0 & P_code = 0 then P_code = code; P_seg_ptr = null; end; end msf_terminate_file_; %page; DEDUCE_ACL_FROM_DIR_ACL: procedure; declare 1 dracl (dracl_count) aligned like directory_acl_entry based (dracl_ptr); declare dracl_ptr pointer; declare dracl_count fixed bin; declare ax fixed bin; code = 0; dracl_ptr = null (); on cleanup begin; if dracl_ptr ^= null then do; free dracl; dracl_ptr = null (); end; end; if aclp = null () then call FULL_DEDUCE_ACL; else call SPECIFIC_DEDUCE_ACL; return; FULL_DEDUCE_ACL: procedure; declare user_area area based (areap); call hcs_$list_dir_acl (fcb.dname, fcb.ename, get_system_free_area_ (), dracl_ptr, null (), dracl_count, code); if code ^= 0 then return; acl_count = dracl_count; allocate segment_acl_array in (user_area); do ax = 1 to dracl_count; segment_acl_array (ax).access_name = dracl (ax).access_name; segment_acl_array (ax).mode = TRANSLATE_MODE (dracl (ax).mode); segment_acl_array (ax).extended_mode = ""b; /* This is WRONG, but we cannot fix it. */ segment_acl_array (ax).status_code = 0; end; free dracl; area_ret_ptr = acl_ptr; return; end FULL_DEDUCE_ACL; SPECIFIC_DEDUCE_ACL: procedure; declare system_area area based (get_system_free_area_ ()); dracl_count = acl_count; allocate dracl in (system_area); dracl (*) = segment_acl_array (*), by name; call hcs_$list_dir_acl (fcb.dname, fcb.ename, null (), null (), dracl_ptr, dracl_count, code); if code ^= 0 then do; segment_acl_array (*).status_code = dracl (*).status_code; free dracl; return; end; do ax = 1 to acl_count; segment_acl_array (ax).mode = TRANSLATE_MODE (dracl (ax).mode); segment_acl_array (ax).extended_mode = ""b; end; free dracl; return; end SPECIFIC_DEDUCE_ACL; end DEDUCE_ACL_FROM_DIR_ACL; TRANSLATE_MODE: procedure (Dir_bits) returns (bit (36) aligned); declare Dir_bits bit (36) aligned; return (substr (Dir_bits, 1, 1) || "0"b || substr (Dir_bits, 2, 1)); end TRANSLATE_MODE; end msf_manager_; bull_copyright_notice.txt 08/30/05 1008.4r 08/30/05 1007.3 00020025 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group Bull including Bull HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell Bull Inc., Groupe Bull and Bull HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato.Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, Bull or Bull HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by Bull HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved