#! /usr/bin/perl
#

$texscan_lib_set = 1;
$true = 1; $false = 0;
$texscan'true = 1; $texscan'false = 0;

#
#  some texscan package initialization
#

%texscan'cc = ('ESCAPE',  0, 'BGROUP',  1, 'EGROUP',  2, 'MATHSH',  3,    #'
               'ALIGNT',  4, 'RETURN',  5, 'MACROP',  6, 'SUPERS',  7, 
               'SUBS',    8, 'IGNORD',  9, 'SPACE',  10, 'LETTER', 11, 
               'OTHER',  12, 'ACTIVE', 13, 'COMMNT', 14, 'INVALD', 15  );
@texscan'cckey = ('ESCAPE', 'BGROUP', 'EGROUP', 'MATHSH',    #'
           	  'ALIGNT', 'RETURN', 'MACROP', 'SUPERS', 
           	  'SUBS',   'IGNORD', 'SPACE',  'LETTER', 
           	  'OTHER',  'ACTIVE', 'COMMNT', 'INVALD', );
@texscan'codechar = ("\\", "{", "}", "\$", "&", "\n", "#", "^\013",        #'
                     "_\001", "\0", " \t", 
                     "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ",
		     "!\"'()*+,-./0123456789:;<=>?@[]`|",
                     "~\014", "%", "\037"                              );

sub texscan'regexp_codechar {  #'
#
# return an associative array holding characters by their TeX catagory and 
#   whose values are suitable for use in a regular expression, with regexp 
#   metacharacters escaped.
#
    package texscan;

    local($tmp,%out,$i,$pre,$post);

    foreach $i (0 .. $#cckey) {
	($out{$cckey[$i]} = $codechar[$i]) =~ 
	    s/([\\\{\}\$\"\'\(\)\*\+\-\.\/\?\[\]\`\|\^\#])/\\$1/g;  #"
    }
    return %out;
}

sub esc_TeXmchars {
    local($in) = @_;
    local($out);
    ($out = $in) =~ s/([\\\{\}\$\"\'\(\)\*\+\-\.\/\?\[\]\`\|\^\#])/\\$1/g;  #"
    return $out;
}

sub grep_TeXmacro {
#
#  extract the substring from the input line containing the requested macro.
#
    package texscan;

    $main'tex_emsg = ''; #'
    local($macro,$input) = @_;
    local($pre,$match,$post,$out,$line,$comnt) = ('', '', '', '', '', '');
    local(%scc);

    if ($macro eq '') {
	$main'tex_emsg = 'No TeX macro specified';  #'
	return ($input, '', '', -1);
    }
    return ($input, '', '', 0) if ($input eq '');

    %scc = &regexp_codechar;
    if ($input =~ /[$scc{'RETURN'}][^\n]/) {
	$main'tex_emsg = 'input line contains imbedded newline';  #'
	return ($input, '', '', -1);
    }

    # remove comment
    $line = $input;
    if ($line =~ /[$scc{'COMMNT'}].*\n?$/) {
	$comnt = $&;
	$line =~ s/[$scc{'COMMNT'}].*\n?$//;
    }

    reset;
    SCAN: while ($out eq '' && $line ne '') {

	# find first occurance in $line
	last SCAN if ($line !~ ?$macro?);     
	$pre .= $`; $match = $&; $post = $';

	# skip if followed by something letter-like
	next SCAN if ($post =~ /^[$scc{'LETTER'}]/ ||
		      $post =~ /^[$scc{'SUPERS'}]{2}./ );

	# skip if not preceeded by an odd number of backslashes 
	next SCAN if ($pre !~ /[$scc{'ESCAPE'}]+$/);
	$tmp = $&;
	next SCAN if (($nb = ($tmp =~ s/[$scc{'ESCAPE'}]/X/g)) % 2 == 0);

	# we have a true match
	$out = substr($pre,length($pre)-1) . "$match";
	$pre = substr($pre,0,length($pre)-1);
	last SCAN;

    } continue {
	# set the $pre, $line ready for next scan
	$pre .= $match;
	$line = $post;
    }

    return ($out eq '') ? ($input, '', '', 0) : ($pre, $out, "$post$comnt", 1);
}


sub fgrep_TeXmacro {
#
#  search input file for requested macro and return its arguments
#
    package texscan;

    $main'tex_emsg = ''; #'
    local($macro,$infile,$nargs,$startn,$noccs) = @_;
    $nargs = 1 if ($nargs eq '');
    $startn = 1 if ($startn eq '');
    $noccs = -1 if ($noccs eq '');
    local($n,$m) = (0, 0);
    local(@args) = ();
    local($line,$pos,%scc,$incomplt);
    local(*TEXIN);
    local($[) = 0;

    return (0) if ($noccs == 0);
    if ($macro eq '') {
	$main'tex_emsg = 'No TeX macro specified';  #'
	return (-1);
    }
    if (! -r "$infile" || -d "$infile") {
	$main'tex_emsg = '$infile: No such file with read permission';  #'
	return (-2);
    }
    %scc = &regexp_codechar;

# open the input file

    open(TEXIN, "$infile") || die "$infile: $!";
    READ: while($line = <TEXIN>) {

	# remove comment
	$line =~ s/[$scc{'COMMNT'}].*$/\n/;

        SCAN: while ($line ne '') {

	    # find first occurance in $line
	    next READ if ($line !~ /$macro/);     
	    $pre = $`; $post = $';

	    # skip if followed by something letter-like
	    next SCAN if ($post =~ /^[$scc{'LETTER'}]/ ||
			  $post =~ /^[$scc{'SUPERS'}]{2}./ );

	    # skip if not preceeded by an odd number of backslashes 
	    next SCAN if ($pre !~ /[$scc{'ESCAPE'}]+$/);
	    $tmp = $&;
	    next SCAN if (($nb = ($tmp =~ s/[$scc{'ESCAPE'}]/X/g)) % 2 == 0);

	    # we have a true match
	    $m++;
	    next SCAN if ($m < $startn);
	    for($i=1; $i<=$nargs; $i++) {
		$incomplt=$true; $tok=''; $isgroup=$false; 

		# the argument is a group
		if ($post =~ /^[$scc{'SPACE'}]*[$scc{'BGROUP'}]/) {
		    $isgroup = $true;
		    $post =~ s/^[$scc{'SPACE'}]*[$scc{'BGROUP'}]//;
		}

		# get the argument
		STR: while ($incomplt) {
		    if ($isgroup) {
			($tmp, $post, $incomplt) = 
			    &main'gettexgroup($post,$incomplt);  #'
		    } else {
			($tmp, $post, $incomplt) = &main'gettextok($post); #'
		    }
		    $tok .= $tmp;
		    last STR if (! $incomplt);

		    # we need more input from file
		    if (! ($line = <TEXIN>)) {
			$main'tex_emsg =                  #'
			  "$infile: file ended before arguments were complete";
			return (-3, @args);
		    }
		    # remove comment from new line
		    $line =~ s/[$scc{'COMMNT'}].*$/\n/;
		    $post = $line;
		    $isgroup = $true 
			if ($tok eq '' && 
			    $post =~ /^[$scc{'SPACE'}]*[$scc{'BGROUP'}]/);
		}
		push(@args, $tok); 
	    }
	    $n++;
	    last READ if ($noccs > 0 && $n >= $noccs);
	} continue { 
	    # set the $line ready for next scan
	    $line = $post;
	}
    }
    close(TEXIN);

    return ((wantarray) ? ($n, @args) : $n);
}

sub gettexitem {
#
# pop off the first item (a token or group) from the input line.  What is 
#   actually returned is a 3-element array consisting of the token string,
#   the rest of the input line, and a status code.  The completion status 
#   code is less than 0 if an error occurred.  If the token is incomplete
#   (either only spaces were found or the group is unfinished), the status
#   will be equal to 1; otherwise it will be equal to 0.
#
    package texscan;

    $main'tex_emsg = '';        #'
    local($input) = @_;
    local($str,$tok,$rest,$use,$tmp,$comnt,%scc);
    local($comnt,$item) = ('','');

    %scc = &regexp_codechar;
    $str = $input;
    
    # remove comment
    if ($str =~ /[$scc{'COMMNT'}].*\n?$/) {
	$comnt = $&;
	$str =~ s/[$scc{'COMMNT'}].*\n?$//;
    }

    # return if there is nothing there
    return ('', $input, 1) 
	if ($str eq '' || $str =~ /^[$scc{'SPACE'}]*[$scc{'RETURN'}]?$/);

    # pop off leading spaces
    if ($str =~ /^[$scc{'SPACE'}]+/) {
	$item .= $&;
	$str =~ s/^[$scc{'SPACE'}]+//;
    }
    
    # do we get a group or a token?
    if ($str =~ /^[$scc{'BGROUP'}]/) {

	# we get a group
	$groupc = $&;
	$item .= $groupc;
	$str =~ s/^$groupc//;
	($tok, $rest, $stat) = &main'gettexgroup($str,1);      #'
	return ('', $input, $stat) if ($stat < 0);
	$tmp = &main'esc_TeXmchars($tok);                      #'
	if ($stat == 0 && $str =~ /^$tmp([$scc{'EGROUP'}])/ ) {
	    $groupc = $1;
	    $item .= "$tok$groupc";
	}
	else {
	    $item .= $tok;
	}

    }
    else {
	
	# we have a token
	($tok, $rest, $stat) = &main'gettextok($str);           #'
	return ('', $input, $stat) if ($stat < 0);
	$item .= $tok;
    }

    return ($item, $rest, $stat);
}

sub gettextok {
#
# Split the input line into its first token and everything else.  What is 
#   actually returned is a 3-element array consisting of the token string,
#   the rest of the input line, and a status code.  The completion status 
#   code is less than 0 if an error occurred.  If the token is incomplete, 
#   i.e. only spaces were found, the completion status will be equal to 1;
#   otherwise it will be equal to 0.  
#
    package texscan;

    $main'tex_emsg = '';        #'
    local($str) = @_;
    local($tok,$rest,%scc);

    %scc = &regexp_codechar;

    # remove leading spaces
    $str =~ s/^[$scc{'SPACE'}]+//g;
    return ('', $str, 1) if ($str eq '' || $str =~ /^[$scc{'RETURN'}]$/);

    # is this either a regular control sequence, a control sequence 
    #  containing ^^'ed characters, or just ^^'ed characters.
    if ($str =~ 
 /^[$scc{'ESCAPE'}]([$scc{'LETTER'}]*[$scc{'SUPERS'}]{2}[0-9a-f]{2}[$scc{'LETTER'}]*)+/
	|| $str =~ /^[$scc{'ESCAPE'}][$scc{'SUPERS'}]{2}./
	|| $str =~ /^[$scc{'ESCAPE'}][$scc{'LETTER'}]+/
	|| $str =~ /^[$scc{'ESCAPE'}][^$scc{'LETTER'}]/ 
	|| $str =~ /^[$scc{'SUPERS'}]{2}[0-9a-f]{2}/
	|| $str =~ /^[$scc{'SUPERS'}]{2}./) {

	$tok = $&; 
	$rest = substr($str,length($tok));
	return ($tok,$rest,0);
    }

    # is this a single character
    else {
	$tok = substr($str,0,1);
	$rest = substr($str,1);
	return ($tok, $rest, 0);
    }
}

sub gettexgroup {
#
# Split the input line into the rest of the current group and everything 
#   else.  The input is the string to process and (optionally) the number 
#   of close braces needed to close the group.  What is returned is a 
#   3-element array consisting of the token string, the rest of the input 
#   line, and a status code.  If the group is complete, i.e. the requested 
#   number of closing braces were encountered, the completion status will 
#   be equal to 0; otherwise, the status will be > 0 and equal to the number 
#   of close braces needed to complete the group.  When the group is found 
#   to be complete, the $rest string will begin just after the closing brace.
#
    package texscan;

    $main'tex_emsg = '';        #'
    local($str,$ncb) = @_;
    $ncb = 1 if ($ncb eq '');
    local($grp,$rest,%scc);

    return ('', $str, $ncb) if ($ncb <= 0);
    %scc = &regexp_codechar;
    return ($str, '', $ncb) if ($str !~ /[$scc{'BGROUP'}$scc{'EGROUP'}]/);

    # loop through brace-delimited substrings
    while ($str ne '' && $ncb > 0) {

	# get everything up to a brace
	if ($str =~ /[$scc{'BGROUP'}$scc{'EGROUP'}]/) {
	    $grp .= $`;
	    $brace = $&;
	    $str = $';

	    if ($brace =~ /[$scc{'BGROUP'}]/) {
		$ncb++;
		$grp .= $brace;
	    }
	    elsif ($brace =~ /[$scc{'EGROUP'}]/) {
		$ncb--;
		$grp .= $brace if ($ncb != 0);
	    }
	    else {
		die "gettexgroup: programming error: BGROUP=$scc{'BGROUP'}, "
		    . "EGROUP=$scc{'EGROUP'}";
	    }
	}
	else {
	    $grp .= $str;
	    $str = '';
	}
    }

    return ($grp, $str, $ncb);
}

sub remove_TeXcomment {
#
# remove the comment from a line of TeX code.  The input line should not
#   have any embedded newline characters.
#
    package texscan;

    $main'tex_emsg = ''; #'
    local($str) = @_;
    local($comnt) = "";
    local(%scc) = &regexp_codechar;
    local($pre) = "";
    local($tmp);
    
    # remove comment
    while ($str =~ /[$scc{'COMMNT'}].*\n?$/) {
	$comnt = $&;
	if ($str =~ /(\\+)[$scc{'COMMNT'}]/ && length($1) % 2 != 0) {
	    $tmp = "$`$&";
	    $pre .= $tmp;
	    $str = substr($str, length($tmp));
	}
	else {
	    $str =~ s/[$scc{'COMMNT'}].*\n?$//;
	}
    }
    $pre .= $str;

    return ($pre, $comnt);
}

sub TeXmacro_arg {
#
#  extract an argument of a macro from from the input line.
#  Input:  $input   the input line; no default.
#          $macro   the name of the macro to get a argument from (without
#                       a preceeding slash); no default.
#          $argnum  the index to the argument desired; zero means no argument
#                       value--simly parse the name from remaining text in 
#                       in line; default = 0.
#          $getmore if true, read more lines from the file handle INTEX; 
#                       default = false
# 
#  Output: $pre     the text just before the argument extracted, including 
#                       the macro name and any preceeding arguments.
#          $match   the requested argument.
#          $post    the text just after the argument extracted, 
#          $stat    the status which can be: 
#                       1   if the argument was successfully extracted
#                       0   if macro was not found in the input line
#                      -1   if $argnum < 0
#                      -2   if $getmore = true and the argument was incomplete
#                      -3   if a general format or read error occurred
#      
    package texscan;

    $main'tex_emsg = ''; #'
    local($input,$macro,$argnum,$getmore,$fh) = @_;
    $getmore = $false if ($getmore eq '');
    $fh = "INTEX" if ($fh eq '');
    local($nobrace) = $true;
    if ($argnum < 0) {
	$argnum *= -1;
	$nobrace = $false;
    }
    local($pre,$match,$post,$out,$tmp,$a,$nxt);
    local($intex) = "main'$fh";
    local(%scc) = &regexp_codechar;

    ($pre, $match, $post, $stat) = &main'grep_TeXmacro($macro, $input); #'
    return ($input, '', '', -1) if ($stat < 0);
    return ($input, '', '', 0) if (! $stat);

    $out = "$pre$match";
    $nxt = $post;
    $val = '';

    for($a=0; $a < $argnum; $a++) {
	($match, $post, $stat) = &main'gettexitem($nxt);                #'

	while ($stat != 0) {
	    return ("$out$nxt", '', '', -3) if ($stat < 0);
	    return ("$out$nxt", '', '', -2) if ($stat > 0 && ! $getmore);
	    $val .= $match;
	    return ($out, $val, '', -2) if (! ($nxt = <$intex>));
	    ($match, $post, $stat) = &main'gettexgroup($nxt);            #'
	    if ($stat == 0) {
		$tmp = &main'esc_TeXmchars($match);                      #'
		if ($nxt =~ /^$tmp([$scc{'EGROUP'}])/ ) {
		    $match .= $1;
		}
	    }
	}
	$val .= $match;

	if ($a < $argnum-1) {
	    $out .= $val;
	    $val = '';
	}
    }

    if ($nobrace) {
	$val =~ s/^\s*\{\s*//;
	$val =~ s/\s*\}\s*$//;
    }

    return ($out, $val, $post, 1);
}

1;