{  +---------------------------------------------------------------------------+
   |									       |
   |  [WHO]SEARCH.PAS				 Target Analysis and Scanning  |
   |  Scott Bailey, Xerox Corporation		     Created October 27, 1990  |
   |									       |
   |  Modification History						       |
   |  V1.0-000 10/27/90 RSB	Original version			       |
   |									       |
   +---------------------------------------------------------------------------+
}
[ident('V1.0-000'),environment('search'),
inherit('sys$library:starlet',
	'sys$library:pascal$str_routines',
	'sys$library:pascal$lib_routines',
	'sys$library:pascal$ots_routines',
	'uafdef',
	'whodefs')]
module search(infile);

  type
    search_type = (exact_user,			{ Explicit username }
		wild_user,			{ Username containing wildcards }
		full_uic,			{ Explicit UIC }
		wild_uic,			{ [*,*] }
		group,				{ All users in this group }
		member,				{ All users w/ this member }
		owner,				{ Substring of ownername }
		indirect,			{ Indirect file reference }
		invalid);			{ Temporary for parse only }

    search_specification = record		{ Parsed search input }
      link : ^search_specification;		{ Link to next specification }
      case kind : search_type of		{ Type of search for this spec }
	exact_user: (				{ Username search }
	  usr : ascii_32); {padded_string(uaf$s_username));} { Username to match }
	wild_user: (				{ Wildcarded username }
	  pat : varying [uaf$s_username] of char; { Match pattern }
	  cut : integer);			{ Length of exact prefix }
	full_uic: (				{ UIC search (or identifier) }
	  uic : uic_type);			{ UIC to match }
	wild_uic: ();				{ No extra info required }
	group: (				{ Match all in a UIC group }
	  grp : word_int);			{ Group number to match }
	member: (				{ Match all w/ same member }
	  mem : word_int);			{ Member number to match }
	owner: (				{ Owner substring to match }
	  own : varying [uaf$s_owner] of char);	{ Substring to look for }
	indirect: (				{ Indirect file (special case) }
	  back : ^search_specification);	{ List backlink for removal }
    end; {record search_specification}
    search_pointer = ^search_specification;

    file_specification = record
      next_file : ^file_specification;		{ Next file in input list }
      filename : varying [64] of char;		{ Name of this file }
      insert_point,				{ Put this where? }
      spec_head,				{ First search spec in file }
      spec_tail : ^search_specification;	{ Last search spec in file }
    end; {record file_specification}

  var
    infile : text;				{ Indirect input file(s) }

{
A specialized routine for reporting parsing problems.  It accepts the string
which we choked on, and the status indicating the problem.  This will be
used to generate a "friendly" message to the user.  Control may be returned
if the severity of the error is low enough.
}
  procedure parse_error(
    bad_input : packed array [l1..u1:integer] of char;
    bad_status : integer);

  begin {procedure parse_error}
    lib$signal(%ref who$_invpattern,1,%stdescr bad_input,bad_status);
  end; {procedure parse_error}

{
Parse the input specifications.  Parse command line input first, then we'll
sequentially scan all referenced indirect input files and collapse everything
into a single linked list of specifications.  The parameter is a file block
which will serve as list header for this information.
}
  procedure parse_input(
    var speclist : search_pointer);

    var
      curr_spec,				{ Current search rule }
      new_spec : ^search_specification;		{ Newly scanned search rule }
      last_file,				{ Last file in list }
      curr_file,				{ Current indirect file }
      new_file : ^file_specification;		{ Newly referenced file }
      have_spec,				{ Do we have a specification? }
      eoi : boolean;				{ End-of-Input flag }
      buff2, buff3,				{ More buffers.... }
      buff : [volatile] varying [64] of char;	{ Working buffer }
      comma,					{ Location of comma }
      stat : integer;				{ Return status from calls }
      cmdline : [volatile] file_specification;	{ Working treehead }
      validchar : [static,readonly] set of char	{ Valid username characters }
	value ['0'..'9','A'..'Z','$','_','*','%'];
      badchar : boolean;			{ Bad characters present? }

  begin {procedure parse_input}
    cmdline := zero;				{ Clear our header pointers }
    curr_file := address(cmdline);		{ We start at command line }
    last_file := address(cmdline);		{ which is the only file }
    curr_spec := nil;				{ with no information }
    eoi := false;
{
Time to read another search specification from the current input file.  If
no file is specified (as is the case initially) then input comes from the CLI.
The first section inside this loop must keep processing until input is
exhausted or it has a specification to pass on to the interpreter.
}
    repeat
      repeat
	have_spec := false;
	if curr_file = address(cmdline) then begin { At command line? }
	  stat := cli$get_value('USERLIST',buff.body,buff.length);
	  have_spec := (stat <> cli$_absent);	{ Did we get something? }
	end {then}
	else begin				{ At an indirect file }
	  if eof(infile) then			{ If at end of file }
	    close(infile)			{ then close & move on }
	  else begin
	    readln(infile,buff);		{ otherwise read next record }
	    have_spec := true;			{ and get on to parsing it }
	  end; {else}
	end; {else}
{
If at this point we have no specification we must move on to the next file.
If there is no other file, we signal end of input.
}
	if not have_spec then begin
	  curr_file := curr_file^.next_file;
	  if curr_file = nil then		{ If there are no more files, }
	    eoi := true				{ then scan is finished }
	  else begin				{ Otherwise open next file }
	    open(file_variable := infile,
		 file_name := curr_file^.filename,
		 history := readonly,
		 sharing := readwrite);
	    reset(infile);
	    curr_spec := nil;			{ Start a new list }
	  end; {else}
	end; {then}
      until eoi or have_spec;			{ Keep trying... }
{
Okay, probably have a specification to parse.  However, we must handle one
special case first.  If we are at command level and are reading a UIC, the
parser will have split the UIC at the comma.  To fix these cases, we need
to read the other half of the UIC.  They are detectable by a direct read of
a parameter beginning with a "[" and with no closing "]".
}
      if have_spec then begin
	if (curr_file = address(cmdline)) and (buff.body[1] = '[')
	and (index(buff,']') = 0) then begin
	  check(cli$get_value('USERLIST',buff2.body,buff2.length));
	  buff := buff + ',' + buff2;
	end; {then}
{
Time to start munging.  Capitalize the input (makes file input consistent
with DCL) and allocate a descriptor for this information.
}
	str$upcase(buff.body,buff.body);
	new(new_spec);
	new_spec^.kind := invalid;		{ Assume bogus user input }
{
An indirect file specification is easiest to recognize, it begins with an
angle-bracket.  A leading indirect specification can give us problems
because of the backlink, so create a dummy record if required.
}
	if buff.body[1] = '<' then begin	{ If indirect, }
	  new_spec^.kind := indirect;		{ record that }
	  if curr_spec = nil then begin		{ If we are at listhead, }
	    new(curr_spec);			{ Create a dummy entry }
	    curr_spec^.kind := invalid;		{ Keep it unused }
	    curr_file^.spec_head := curr_spec;	{ Make it the listhead }
	  end; {then}				{ and business as usual }
	  new_spec^.back := curr_spec;		{ Set backlink at insert point }
	  new(new_file);			{ Get a new file descriptor }
	  new_file^ := zero;			{ and fill it in }
	  new_file^.filename := substr(buff,2,length(buff)-1);
	  new_file^.insert_point := new_spec;	{ Point to insert point }
	  last_file^.next_file := new_file;	{ Add it to end of list }
	  last_file := new_file;		{ and move along pointer }
	end {then}
{	  
If the string is enclosed in quotation marks, then it is an ownername substring
match.
}
	else if ((buff.body[1] = '"') and (buff.body[buff.length] = '"')) then begin
	  new_spec^.kind := owner;		{ Yup... }
	  new_spec^.own := substr(buff,2,length(buff)-2); { Drop quotes }
	end {else..then}
{
If the string is enclosed in square brackets, then it should be some type of
UIC or identifier specification.
}
	else if ((buff.body[1] = '[') and (buff.body[buff.length] = ']')) then begin
	  buff := substr(buff,2,length(buff)-2); { Remove the brackets }
	  comma := index(buff,',');		{ Look for a comma }
{
Without a comma, it must be an identifier.  Convert it and stash it.  If the
conversion fails because the identifier does not exist, discard but do not
report this.  (That way nonexisting identifiers and those owned by accounts
which are not visible to the user are treated identically.)
}
	  if comma = 0 then begin
	    new_spec^.kind := full_uic;		{ This is what we'll get... }
	    stat := $asctoid(buff,%ref new_spec^.uic); { Try to translate }
	    if stat <> ss$_normal then begin	{ Translation didn't work }
	      new_spec^.kind := invalid;	{ so dump it }
	      if stat <> ss$_nosuchid then	{ Hide NOSUCHID, otherwise }
		parse_error('['+buff+']',stat);	{ report the error }
	    end; {then}
	  end {then}
{
We must have a UIC.  However, either or both parts of it could be wildcarded.
Only full wildcards are allowed, however, so this becomes slightly easier.
}
	  else begin
	    buff2 := substr(buff,1,comma-1);	{ Group }
	    buff3 := substr(buff,comma+1,length(buff)-comma); { Member }
	    if buff2 = '*' then begin		{ Wild group? }
	      if buff3 = '*' then		{ Wild member? }
		new_spec^.kind := wild_uic	{ Both... }
	      else begin			{ Only wild group }
		new_spec^.kind := member;	{ Scan for specific member no. }
		stat := ots$cvt_to_l(buff3,new_spec^.mem,2,1); { Get member }
		if not odd(stat) then begin	{ Ooops, that didn't work }
		  parse_error('['+buff+']',stat); { Whine about it }
		  new_spec^.kind := invalid;	{ and throw it away }
		end; {then}
	      end; {else}
	    end {then}
	    else if buff3 = '*' then begin	{ Wild member only? }
	      new_spec^.kind := group;		{ Find everybody in a group }
	      stat := ots$cvt_to_l(buff2,new_spec^.grp,2,1); { Get group }
	      if not odd(stat) then begin	{ Oops, bad conversion }
		parse_error('['+buff+']',stat);	{ Whine }
		new_spec^.kind := invalid;	{ and trash }
	      end; {then}
	    end {else..then}
	    else begin				{ Full UIC specified }
	      new_spec^.kind := full_uic;
	      stat := ots$cvt_to_l(buff2,new_spec^.uic.group,2,1); { Get group }
	      if odd(stat) then
		stat := ots$cvt_to_l(buff3,new_spec^.uic.member,2,1); { & member }
	      if not odd(stat) then begin	{ Something died }
		parse_error('['+buff+']',stat);
		new_spec^.kind := invalid;
	      end; {then}
	    end; {else}
	  end; {else}
	end {else..then}
{
That takes care of all the specially-formatted inputs.  Anything left is
some sort of username.  The only case we must distinguish is wildcarding.
For wildcards, the number of characters before the first wildcard is
important for optimizing searches later.

To be valid, the string should be alphanumeric + "_" + "$" + wildcards.
}
	else begin
	  badchar := false;
	  stat := 1;
	  while (stat <= length(buff)) and (not badchar) do begin
	    badchar := not (buff.body[stat] in validchar);
	    stat := stat + 1;
	  end; {while}
	  if badchar then begin
	    parse_error(buff,lib$_invsymnam);	{ Whine about bad characters }
	    new_spec^.kind := invalid;		{ and dump specification }
	  end {then}
	  else begin
	    stat := index(buff,'*');		{ Is there an asterisk? }
	    comma := index(buff,'%');		{ How about percent? }
	    if (stat = 0) and (comma = 0) then begin { No wildcarding }
	      new_spec^.kind := exact_user;
	      new_spec^.usr := buff;
	    end {then}
	    else begin				{ Wildcarded username }
	      new_spec^.kind := wild_user;
	      new_spec^.pat := buff;		{ Remember pattern }
	      if ((comma <> 0) and (comma < stat)) or (stat = 0) then
	        new_spec^.cut := comma - 1
	      else
	        new_spec^.cut := stat - 1;
	    end; {else}
	  end; {else}
	end; {else}
{
At this point, parsing of the current specification is completed.  If it
still appears to be invalid, discard it.  Otherwise, link it into the list.
}
	if new_spec^.kind = invalid then	{ Dump bogus one }
	  dispose(new_spec)
	else begin				{ Attach good one }
	  if curr_spec <> nil then
	    curr_spec^.link := new_spec		{ At at end of existing list }
	  else
	    curr_file^.spec_head := new_spec;	{ Beginning of new list }
	  curr_file^.spec_tail := new_spec;	{ Update tail pointer }
	  curr_spec := new_spec;		{ Move up trailing pointer }
	end; {else}
      end; {then}
    until eoi;
{
All input has been parsed and stashed.  However, it is not in completely
correct order at this point.  Records from each indirect file need to be
inserted back into the search list at the point the file was referenced.
The "keeper" specification is kept in case there are references to it,
but it will not normally appear in a later scan (it is hopefully detached.)
}
    curr_file := cmdline.next_file;		{ Point to first file }
    while curr_file <> nil do begin		{ While files are left }
      curr_spec := curr_file^.insert_point;	{ Find file's call point }
{
Remove the call point and insert the file's records at this point in the
list.  This is facilitated by the backlink in the call record and the
trailing pointer for each file header.
}
      if curr_file^.spec_head <> nil then begin	{ If something to transfer }
	curr_spec^.back^.link := curr_file^.spec_head; { Attach front }
	curr_file^.spec_tail^.link := curr_spec^.link; { Attach rear }
      end; {then}
      new_file := curr_file;			{ Remember this file }
      curr_file := curr_file^.next_file;	{ Move to next one }
      dispose(new_file);			{ Get rid of crud }
    end; {while}
    speclist := cmdline.spec_head;		{ Pass back the final list }
  end; {procedure parse_input}

{
Position current record pointer at the first record in the specified file which
matches the specified target.  This does not guarantee that the record returned
will match the search criteria.  Additionally, some searches do not even ensure
that ANY record will be made current.  The function status returns true/false
to indicate a valid record is present in the buffer.
}
  function position_file(
    var uaf : authorization_file;		{ Opened file to scan }
    target : search_specification		{ What are we looking for? }
    ) : boolean;				{ Is valid record returned? }

    var
      search_uic : uic_type;			{ Scratch for wildcard builds }
      bogus : boolean;				{ What are chances at record? }

  begin {function position_file}
{
Each kind of search requires a different approach.  With most, we hopefully can
make a direct lookup to what should be the first match (if any will be found.)
Interesting keys are 0 (Username) and 2 (Extended UIC, i.e. uic_type).
}
    bogus := false;				{ Assume we'll start search }
    with target do case kind of
      exact_user:				{ Explicit username }
	findk(uaf,0,usr,EQL,error:=CONTINUE);
      wild_user:				{ Wildcarded username }
	if cut > 0 then				{ If it starts with literal, }
	  findk(uaf,0,substr(pat,1,cut),NXTEQL,error:=CONTINUE) { use key }
	else					{ If it starts w/ wildcard, }
	  resetk(uaf,0,error:=CONTINUE);	{ start at front of file }
      full_uic:					{ Explicit UIC }
	findk(uaf,2,uic,EQL,error:=CONTINUE);
      wild_uic:					{ Everybody, in UIC order }
	resetk(uaf,2,error:=CONTINUE);
      group, member: begin			{ Half-wild UIC }
	search_uic := zero;
	if kind = group then
	  search_uic.group := grp		{ Fill in group if known }
	else
	  search_uic.member := mem;		{ Fill in member if known }
	findk(uaf,2,search_uic,NXTEQL,error:=CONTINUE);
      end; {select}
      owner:					{ Owner substring, ack... }
	resetk(uaf,0,error:=CONTINUE);		{ full scan will be needed }
      otherwise					{ If weird internal markers }
	bogus := true;				{ just skip them completely }
    end; {case}
{
If we tried for and got a record, unlock it.  Remember if we got nothing.
}
    if not bogus then				{ Did we try an I/O? }
      if status(uaf) = 0 then			{ If successful, }
	unlock(uaf)				{ unlock record }
      else
	bogus := true;				{ Barf if any error }
    position_file := not bogus;			{ Final return status }
  end; {function position_file}			{ Back to caller }

{
This function tests the current file buffer and determines if it matches the
supplied search rule.  It also returns an indication of whether or not further
searches might match the given rule.
}
  function matched(
    var uaf : authorization_file;		{ Record to check }
    target : search_specification;		{ What are we looking for? }
    var more : boolean				{ More searches justified? }
    ) : boolean;				{ Current record matches? }

    var
      good : boolean;				{ Is this record a match? }
      temp : varying [32] of char;		{ Temporary ownername }
      i : integer;

  begin {function matched}
{
Check key area with supplied value.  Also, in cases where we can tell we have
passed valid range, set flag to abort additional searches.
}
    more := true;				{ Assume there's more matches }
    with target do case kind of
      exact_user: begin				{ Exact username }
	good := (usr = uaf^.username);		{ Does username match? }
	more := false;				{ Username is unique }
      end; {select}
      wild_user: begin				{ Wildcarded username }
	i := length(uaf^.username);
	while uaf^.username[i] = ' ' do		{ Strip trailing blanks }
	  i := i - 1;
	good := (str$match_wild(substr(uaf^.username,1,i),pat) = str$_match);
	if (cut > 0) and_then			{ If initial literal exists }
	(substr(uaf^.username,1,cut) <> substr(pat,1,cut)) then { & no match }
	  more := false;			{ then no more will occur }
      end; {select}
      full_uic:					{ Exact UIC }
	good := ((uic.group = uaf^.uic.group)	{ All of UIC must match }
	and (uic.member = uaf^.uic.member)
	and (uic.sub_id = uaf^.uic.sub_id));	{ (May not be unique) }
      wild_uic:					{ Fully wild UIC }
	good := true;				{ Everything matches :-) }
      group: begin				{ All members of group }
	good := (grp = uaf^.uic.group);	
	more := good;				{ If out of group, we're done }
      end; {select}
      member:					{ Everybody w/ same member }
	good := (mem = uaf^.uic.member);
      owner: begin				{ Owner substring }
	str$upcase(temp.body,uaf^.owner.data);	{ Uppercase owner name }
	temp.length := uaf^.owner.length;
	good := (index(temp,own) > 0);		{ String in owner name? }
      end; {select}
      otherwise					{ Should never happen }
	good := false;
	more := false;
    end; {case}
{
One last feature.  Check the record type.  If it isn't user data, then this is
a bad match.  (But prospects for more remain as originally defined above.)
}
    if good and (uaf^.rtype <> uaf$c_user_id) then
      good := false;
    matched := good;				{ Return final status }
  end; {function matched}

{
Position current record pointer to the next record which might match the
specified target.  This assumes that position_file was called previously
for this key and has the same caveats as that routine.
}
  function find_next(
    var uaf : authorization_file;		{ File to scan }
    target : search_specification		{ What to look for }
    ) : boolean;				{ At valid record? }

    var
      search_uic : uic_type;			{ Scratch for wildcard builds }
      bogus : boolean;				{ What are chances at record? }

  begin {function find_next}
{
We have fewer kinds of searches to worry about at this point.  Pretty much
everything will use sequential reads except for weird UIC searches.
}
    bogus := false;
    with target do case kind of
      exact_user, wild_user, full_uic, wild_uic, group, owner:
	get(uaf,error:=CONTINUE);		{ Sequential read, current idx }
      member: begin				{ [*,member] searches }
	get(uaf,error:=CONTINUE);		{ Check for duplicate UIC }
	if (status(uaf) = 0) and_then (mem <> uaf^.uic.member) then begin
	  unlock(uaf);				{ Free unwanted record }
	  search_uic := uaf^.uic;		{ Grab UIC of this record }
	  if search_uic.member > mem then
	    search_uic.group := search_uic.group + 1; { Next possible match }
	  search_uic.member := mem;
	  findk(uaf,2,search_uic,NXTEQL,error:=CONTINUE); { Go right to it }
	end; {then}
      end; {select}
      otherwise					{ Should never happen }
	bogus := true;				{ Squelch this one fast }
    end; {case}
{
If we tried for and got a record, unlock it.  Remember if we got nothing.
}
    if not bogus then				{ Did we try an I/O? }
      if status(uaf) = 0 then			{ If successful, }
	unlock(uaf)				{ unlock record }
      else
	bogus := true;				{ Barf if any error }
    find_next := not bogus;			{ Final return status }
  end; {function find_next}			{ Back to caller }
end. {module search}