{  +---------------------------------------------------------------------------+
   |									       |
   |  [WHO]MASKS.PAS			     Bitmask Interpretation Utilities  |
   |  Scott Bailey, Xerox Corporation		     Created October 24, 1990  |
   |									       |
   |  Modification History						       |
   |  V1.1-003 11/09/90 RSB	Add limited access field parsing	       |
   |  V1.0-002 11/07/90 RSB	Fix masking for "ALL" keyword		       |
   |  V1.0-001 11/03/90 RSB	Massage mask parameter passing		       |
   |  V1.0-000 10/24/90 RSB	Initial version				       |
   |									       |
   +---------------------------------------------------------------------------+

This group of routines provides for conversion between bitmasks and ASCII
string representations of them.  Bitmasks are passed by address of the bitmask.
Varying of character variables are used for the string representation. 
Translation is accomplished by an array of varying strings, implicitly 0-based,
where the i'th string is the representation of the i'th bit in the mask (when
it is set).  Note that the length of the bitmask is implicitly defined by the
number of entries in the translation array.  Masks must be byte-aligned.

These routines require at least Pascal V4.0 and VMS V5.2 to compile.
}
[ident('V1.1-003'),
environment('masks'),
inherit('sys$library:starlet',
	'sys$library:pascal$lib_routines',
	'sys$library:pascal$str_routines',
	'uafdef')]
module masks;
{
A few definitions to fix bogus DEC environment definitions...
}
[asynchronous,external(str$element)] function rsb$element(
  var destination_string : varying [$l1] of char;
  element_number : integer;
  delimiter_string : [class_s] packed array [$l3..$u3:integer] of char;
  source_string : [class_s] packed array [$l4..$u4:integer] of char
  ) : integer; external;

  type
    mask_type = array [1..2] of unsigned;
    mask_ptr = ^mask_type;
{
Invert a bitmask.
}
  [asynchronous,unbound]
  procedure notmask(var mask : mask_type);

  begin {procedure notmask}
    mask[1] := unot(mask[1]);
    mask[2] := unot(mask[2]);
  end; {procedure notmask}

{
Translate bitmask to ASCII string.  Return status is:

SS$_NORMAL	Conversion was successful
LIB$_OUTSTRTRU	Buffer was too small; output has been truncated
}
  [asynchronous,unbound]
  function bits_to_string(
    mask : mask_type;
    var maskstr : [volatile] varying [l0] of char;
    xlate : array [l1..u1:integer] of varying [l2] of char
    ) : integer;

    var
      bitidx,					{ Current bit to test }
      status : integer;				{ Intermediate status }

  begin {function bits_to_string}
    maskstr.length := 0;			{ Clear output buffer }
    status := ss$_normal;			{ Assume all will be okay }
    for bitidx := l1 to u1 do			{ Test each bit in mask }
      if lib$extzv(bitidx-l1,1,%ref mask) <> 0 then begin
	if length(maskstr) + length(xlate[bitidx]) < length(maskstr.body) then
	  maskstr := maskstr + xlate[bitidx] + ',' { Add translation }
	else					{ If buffer is too small }
	  status := lib$_outstrtru;		{ Signal truncation }
      end; {then}
    if length(maskstr) > 0 then			{ If we generated output }
      maskstr.length := maskstr.length - 1;	{ drop trailing comma }
    bits_to_string := status;			{ Return result status }
  end; {function bits_to_string}

{
Translate ASCII string to bitmask.  This is more complicated because we allow
for (unambiguous) abbreviation as well as "ALL" (all bits set) and negated
bit specifications.  Routine is case-insensitive.  Note that "ALL" will always
be interpreted as "set all bits" even if a bit name begins with "ALL."
Return code is:

SS$_NORMAL	Conversion was successful
LIB$_INVSYMNAM	An unrecognized bit name was encountered
LIB$_AMBSYMDEF	An ambiguously abbreviated bit name was encountered
}
  [asynchronous,unbound]
  function string_to_bits(
    maskstr : varying [l0] of char;
    var mask : mask_type;
    xlate : array [l1..u1:integer] of varying [l2] of char
    ) : integer;

    var
      namidx,					{ Input element index }
      bitidx,					{ Bit scan index }
      setbit,					{ Value for this bit }
      bitbase,					{ Loop counter for ALL }
      matches,					{ Matches for element }
      status : integer;				{ Intermediate status }
      element : varying [64] of char;		{ Current element }
      done : boolean;				{ Drop-dead flag }

  begin {function string_to_bits}
{
Begin by zeroing the output mask, 32 bits at a time.
}
    bitbase := 0;				{ Start at head of mask }
    bitidx := u1 - l1 + 1;			{ Length of mask }
    while bitidx > 1 do begin
      lib$insv(0,bitbase,min(bitidx,32),%ref mask); { Clear this chunk }
      bitidx := bitidx - 32;			{ Count off bits }
      bitbase := bitbase + 32;			{ Move to next chunk }
    end; {while}
    done := false;
    namidx := 0;
    str$upcase(maskstr.body,maskstr.body);	{ Get input in uppercase }
    repeat
      status := rsb$element(element,namidx,',',maskstr); { Get next element }
      if status = str$_noelem then begin
	done := true;				{ Quit at end of string }
	status := ss$_normal;			{ So conversion worked okay }
      end {then}
      else begin
	namidx := namidx + 1;			{ Move pointer past this one }
	if (length(element) > 2) and_then (substr(element,1,2) = 'NO') then begin
	  setbit := 0;				{ This bit will be cleared }
	  element := substr(element,3,length(element)-2); { Remove the 'NO' }
	end {then}
	else
	  setbit := -1;				{ This bit will be set }
{
If we find 'ALL' then get all bits in the mask.  By using "0" and "-1" for the
bit source (in setbit) we can handle chunks of bits up to the size of setbit
analoguously to the inital clear operation above.
}
	if element = 'ALL' then begin		{ Special case - set all bits }
	  bitbase := 0;				{ Start at head of field }
	  bitidx := u1 - l1 + 1;		{ Number of bits to zap }
	  while bitidx > 1 do begin		{ While bits remain, }
	    lib$insv(setbit,bitbase,min(bitidx,bitsize(setbit)),%ref mask);
	    bitidx := bitidx - 32;		{ Count off zapped bits }
	    bitbase := bitbase + 32;		{ Move over to next group }
	  end; {while}
	end {then}
{
We look for a match against the translation array.  Exactly one match must be
found to be successful, too many is ambiguous, none means a typo etc.
}
	else begin
	  bitidx := l1;				{ Prepare to scan table }
	  matches := 0;				{ Nothing matched yet }
	  repeat
	    if (length(xlate[bitidx]) >= length(element)) and_then
	    (substr(xlate[bitidx],1,length(element)) = element) then begin
	      matches := matches + 1;		{ Remember we matched it }
	      status := bitidx;			{ Remember where we are }
	    end; {then}
	    bitidx := bitidx + 1;		{ Move on to next bit }
	  until (matches > 1) or (bitidx > u1);	{ Finish our testing }
{
Matches is now 0, 1, or 2.  Update routine status accordingly, and in the
case of exactly one match, zap the appropriate bit in the mask.
}
	  case matches of
	    0: begin
	      status := lib$_invsymnam;		{ No match, bogus symbol }
	      done := true;			{ Abort further conversion }
	      end; {select}
	    1: lib$insv(setbit,status,1,%ref mask); { Zap the matched bit }
	    2: begin
	      status := lib$_ambsymdef;		{ Multiple matches, boo... }
	      done := true;			{ Abort further conversion }
	      end; {select}
	  end; {case}
	end; {else}				{ Translation array scan }
      end; {else}				{ Current element processed }
    until done;					{ Input string exhausted }
{
Set final return status and we're finished
}
    string_to_bits := status;
  end; {function string_to_bits}

{
Translate access bitmasks to ASCII string.  This provides a limited display
of a pair of access masks; each mask is translated as "All" if it is zero,
"None" if it is -1, and "Some" otherwise.  The pair will be reported as a
single value if the same string is returned, otherwise "primary,secondary".
Note that the sense of this comparison is that set bits deny access.

Return status is:

SS$_NORMAL	Conversion was successful
LIB$_OUTSTRTRU	Buffer was too small; output has been truncated
}
  [asynchronous,unbound]
  function access_to_string(
    mask : access_type;
    var maskstr : [volatile] varying [l0] of char
    ) : integer;

    type
      one_field = varying [4] of char;		{ We need this for each mask }

    var
      first, second : one_field;		{ Results for each half }
      final : varying [9] of char;		{ Final output buffer }

    function test(bits : byt3_int) : one_field;
    begin {function test}
      case bits of
	0: test := 'All';			{ All bits clear }
	16777215: test := 'None';		{ All bits set }
	otherwise test := 'Some';		{ Mixed results }
      end; {case}
    end; {function test}

  begin {function access_to_string}
    first := test(mask[primary]);		{ Primary day access }
    second := test(mask[secondary]);		{ Secondary day access }
    if first = second then
      final := first				{ Same, use just one }
    else
      final := first + ',' + second;		{ Different, include both }
    if length(maskstr.body) >= length(final) then begin
      maskstr := final;				{ Copy the entire thing }
      access_to_string := ss$_normal;		{ No problems }
    end else begin				{ Ooops, not long enough }
      maskstr := substr(final,1,length(maskstr.body)); { Truncate output }
      access_to_string := lib$_outstrtru;	{ and tell caller }
    end; {else}
  end; {function access_to_string}
end. {module masks}