package HeaderDoc::MacroFilter;
BEGIN {
foreach (qw(Mac::Files)) {
$MOD_AVAIL{$_} = eval "use $_; 1";
}
}
use lib "/System/Library/Perl/Extras/5.8.6/";
use HeaderDoc::BlockParse qw(blockParse);
use HeaderDoc::ParserState;
use HeaderDoc::ParseTree;
use HeaderDoc::APIOwner;
use File::Basename qw(basename);
use strict;
use vars qw(@ISA @EXPORT $VERSION);
$HeaderDoc::MacroFilter::VERSION = '$Revision: 1298084578 $';
@ISA = qw(Exporter);
@EXPORT = qw(ignoreWithinCPPDirective filterFileString run_macro_filter_tests
matchesconstraints doit printconstraint newchild newsibling
unrolltoparen walkTree hasReturnOrBreak);
my $debug = 0;
my $matchdebug = 0;
my $debug_hrb = 0;
my $stackDebug = 0;
my $isMacOS;
my $pathSeparator;
if ($^O =~ /MacOS/io) {
$pathSeparator = ":";
$isMacOS = 1;
} else {
$pathSeparator = "/";
$isMacOS = 0;
}
my $debugging = 0;
my $theTime = time();
my ($sec, $min, $hour, $dom, $moy, $year, @rest);
($sec, $min, $hour, $dom, $moy, $year, @rest) = localtime($theTime);
$year += 1900;
my $dateStamp = HeaderDoc::HeaderElement::strdate($moy, $dom, $year, "UTF-8");
%HeaderDoc::filter_macro_definition_state = (
);
%HeaderDoc::filter_macro_definition_value = (
);
sub run_macro_filter_tests
{
my $lang = "C";
my $sublang = "C";
$HeaderDoc::lang = $lang;
$HeaderDoc::sublang = $sublang;
my $headerObj = HeaderDoc::APIOwner->new("LANG" => $lang, "SUBLANG" => $sublang);
$headerObj->lang($lang);
$headerObj->sublang($sublang);
$HeaderDoc::headerObject = $headerObj;
%HeaderDoc::filter_macro_definition_state = (
"FOO" => 1,
"BAR" => 1,
"BAZ" => 1,
"DEFZ" => 1,
"NDEF" => -1,
"LANGUAGE_OBJECTIVE_C" => -1,
"LANGUAGE_JAVASCRIPT" => 1
);
%HeaderDoc::filter_macro_definition_value = (
"FOO" => 1,
"BAR" => 2,
"BAZ" => 3,
"DEFZ" => 0,
"LANGUAGE_JAVASCRIPT" => 1
);
my $good = 0;
my $bad = 0;
print STDERR "-= Running macro filter tests =-\n\n";
if (dotest("if ((10 < 3) && 10 < 5 || 10 > 9)", 1, $lang, $sublang)) { $good++; } else { $bad++; } if (dotest("if (BAT && (FOO || BAR) && BAZ && BAG)", -3, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && (FOO || BAR) && !BAZ && BAG)", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && (FOO || BAR) && BAZ && !BAG)", -3, $lang, $sublang)) { $good++; } else { $bad++; } if (dotest("if (!BAT && (FOO || BAR) && BAZ && !BAG)", -3, $lang, $sublang)) { $good++; } else { $bad++; } if (dotest("if (BAT && !(FOO || BAR) && BAZ && !BAG)", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && !(BAG) && BAZ && !BAG)", -3, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && !(FOO) && BAZ && !BAG)", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && (FOO < BAR) && BAZ && BAG)", -3, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (BAT && (FOO > BAR) && BAZ && BAG)", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (0)", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (1)", 1, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (defined(FOO))", 1, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (defined(BAG))", -3, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (defined(NDEF))", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (defined(DEFZ))", 1, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (!defined(FOO))", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (!defined(BAG))", -3, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (!defined(NDEF))", 1, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (!defined(DEFZ))", 0, $lang, $sublang)) { $good++; } else { $bad++; }
if (dotest("if (FOO && 1)", 1, $lang, $sublang)) { $good++; } else { $bad++; }
print STDERR "\n";
return ($good, $bad);
}
sub ignoreWithinCPPDirective($$$)
{
my $cpp_command = shift;
my $text = shift;
my $curshow = shift;
my $localDebug = 0;
my ($expression, $rest) = split(/\n/s, $text, 2);
if (!$curshow && ($cpp_command ne "#elif")) {
return (0, "", "");
}
while ($expression =~ /\\\s*$/) {
my ($a, $b) = split(/\n/s, $rest, 2);
$expression =~ s/\\\s*$//s;
$expression .= " ".$a;
$rest = $b;
}
print STDERR "EXPRESSION: $expression\n" if ($localDebug);
my $ignore = 0;
my $tree = undef;
my @junk = undef;
if ($cpp_command eq "#if" || $cpp_command eq "#elif") {
print STDERR "#if/#elif\n" if ($localDebug);
($tree, @junk) = doit("if (".$expression.")");
} elsif ($cpp_command eq "#ifdef") {
print STDERR "#ifdef\n" if ($localDebug);
($tree, @junk) = doit("if (defined(".$expression."))");
} elsif ($cpp_command eq "#ifndef") {
print STDERR "#ifndef\n" if ($localDebug);
($tree, @junk) = doit("if (!defined(".$expression."))");
} else {
die("Unknown CPP command $cpp_command in ignoreWithinCPPDirective\n");
}
my $matches = matchesconstraints($tree);
print STDERR "MATCHES: $matches\n" if ($localDebug);
return ($matches, $rest, $tree->{IFDECLARATION});
}
sub doit
{
my $block = shift;
my $lang = shift;
my $sublang = shift;
my $return_hrb = 0;
my $hierDebug = 0;
my @inputLines = split(/\n/, $block);
my $firstconstraint = newconstraint();
my $constraint = $firstconstraint;
my $inputCounter = 0;
my $nlines = $ print STDERR "Root constraint is $constraint\n" if ($debug);
print STDERR "$nlines $inputCounter $debug\n" if ($debug);
my ($case_sensitive, $keywordhashref) = $HeaderDoc::headerObject->keywords();
my @cparray = ();
while ($inputCounter <= $nlines) {
my ($newInputCounter, $dec, $type, $name, $pt, $value, $pplref, $returntype, $pridec, $parseTree, $simpleTDcontents, $bpavail, $fileoff, $conformsToList, $functionContents, $parserState) = &blockParse("myheader.h", 0, \@inputLines, $inputCounter, 0, \%HeaderDoc::ignorePrefixes, \%HeaderDoc::perHeaderIgnorePrefixes, \%HeaderDoc::perHeaderIgnoreFuncMacros, $keywordhashref, $case_sensitive, $lang, $sublang);
print STDERR "FC: $functionContents\n" if ($debug);
print STDERR "TYPE: $type NAME: $name\n" if ($debug);
$inputCounter = $newInputCounter;
print STDERR "GOT DEC:\n" if ($debug || $hierDebug);
print STDERR $parseTree->textTree() if ($debug || $hierDebug);
print STDERR "END DEC.\n\n" if ($debug || $hierDebug);
$constraint = newsibling($constraint, $constraint);
$constraint->{IFDECLARATION} = $parseTree->textTree();
my ($junk1, $junk2) = walkTree($parseTree, $constraint, $constraint, $constraint);
my %temp = ();
$temp{CONSTRAINT} = $constraint;
$temp{FUNCTIONCONTENTS} = $functionContents;
push(@cparray, \%temp);
my $ifHRB = 0;
my $elseHRB = 0;
if ($parserState->{ifContents}) {
print STDERR "HAS IF\n" if ($hierDebug);
}
if ($parserState->{elseContents}) {
print STDERR "HAS ELSE\n" if ($hierDebug);
}
if ($parserState->{ifContents}) {
print STDERR "IF CONTENTS:\n" if ($hierDebug);
print STDERR $parserState->{ifContents} if ($hierDebug);
print STDERR "END IF CONTENTS\n" if ($hierDebug);
print STDERR "RECURSE IN (IF)\n" if ($hierDebug);
my ($tree2, @cparray2) = doit($parserState->{ifContents}, $lang, $sublang);
print STDERR "RECURSE OUT (IF)\n" if ($hierDebug);
$constraint->{IFGUTS} = $parserState->{ifContents};
$constraint->{IFTREE} = $tree2;
print STDERR "ADDED $tree2 AS IFTREE OF $constraint\n" if ($hierDebug);
}
if ($parserState->{elseContents}) {
print STDERR "ELSE CONTENTS:\n" if ($hierDebug);
print STDERR $parserState->{elseContents} if ($hierDebug);
print STDERR "END ELSE CONTENTS\n" if ($hierDebug);
print STDERR "RECURSE IN (ELSE)\n" if ($hierDebug);
my ($tree2, @cparray2) = doit($parserState->{elseContents}, $lang, $sublang);
print STDERR "RECURSE OUT (ELSE)\n" if ($hierDebug);
$constraint->{ELSEGUTS} = $parserState->{elseContents};
$constraint->{ELSETREE} = $tree2;
print STDERR "ADDED $tree2 AS ELSETREE OF $constraint\n" if ($hierDebug);
}
if ($parserState->{functionContents}) {
print STDERR "SWITCH CONTENTS:\n" if ($hierDebug);
print STDERR $parserState->{functionContents} if ($hierDebug);
print STDERR "END SWITCH CONTENTS\n" if ($hierDebug);
print STDERR "RECURSE IN (SWITCH)\n" if ($hierDebug);
my ($tree2, @cparray2) = doit($parserState->{functionContents}, $lang, $sublang);
print STDERR "RECURSE OUT (SWITCH)\n" if ($hierDebug);
$constraint->{SWITCHGUTS} = $parserState->{functionContents};
$constraint->{SWITCHTREE} = $tree2;
print STDERR "ADDED $tree2 AS SWITCHTREE OF $constraint\n" if ($hierDebug);
}
}
if (!$matchdebug) {
$debug = 0;
}
return ($firstconstraint->{NEXT}, @cparray)
}
sub newconstraint
{
my $constraint = ();
$constraint->{PARENT} = undef;
$constraint->{FIRSTCHILD} = undef;
$constraint->{NEXT} = undef;
$constraint->{LASTJOIN} = undef;
return $constraint;
}
sub printconstraint
{
my $constraint = shift;
my $nodeonly = 0;
if (@_) {
$nodeonly = shift;
}
my $prespace = "";
if (@_) {
$prespace = shift;
}
if (!$constraint) { return; }
my $printconstraintanyway = 1;
print STDERR "$prespace"."Constraint $constraint\n" if ($debug || $printconstraintanyway);
if (isnullconstraint($constraint)) {
print STDERR "$prespace NULL CONSTRAINT\n" if ($debug || $printconstraintanyway);
} else {
my %constrainthash = %{$constraint};
foreach my $key (keys %constrainthash) {
print STDERR "$prespace $key => ".$constraint->{$key}."\n" if ($debug || $printconstraintanyway);
}
}
if (isnullconstraint($constraint)) {
print STDERR "$prespace END NULL CONSTRAINT\n" if ($debug || $printconstraintanyway);
}
if ($nodeonly) {
return;
}
printconstraint($constraint->{PARENTREE}, 0, "$prespace PAREN ");
printconstraint($constraint->{IFTREE}, 0, "$prespace IFGUTS_X ");
printconstraint($constraint->{ELSETREE}, 0, "$prespace ELSEGUTS_X ");
printconstraint($constraint->{SWITCHTREE}, 0, "$prespace SWITCHGUTS_X ");
printconstraint($constraint->{FIRSTCHILD}, 0, "$prespace ");
printconstraint($constraint->{NEXT}, 0, $prespace);
}
sub walkTree($$$$)
{
my $parseTree = shift;
my $constraint = shift;
my $parenconstraint = shift;
my $topconstraint = shift;
my $token = $parseTree->token();
my $longtoken = $token;
print STDERR "TOKEN: $token\n" if ($debug || $debug_hrb);
my $concat = "";
if ($constraint->{TOKENCONCAT}) {
$concat = $constraint->{TOKENCONCAT};
$longtoken = $constraint->{TOKENCONCAT}.$token;
$constraint->{TOKENCONCAT} = "";
}
print STDERR "in walkTree. token: \"$token\" longtoken: \"$longtoken\" constraint: $constraint lastjoin: $constraint->{LASTJOIN}\n" if ($debug);
if ($HeaderDoc::interpret_case && $token eq "case") {
while ($constraint && $constraint->{NEXT}) {
$constraint = $constraint->{NEXT};
}
$constraint = newsibling($constraint);
print STDERR "$constraint\n" if ($debug);
$constraint->{GROUP} = 1;
$constraint->{LASTJOIN} = undef;
$constraint->{PREVPAREN} = $parenconstraint;
print STDERR "Parenthesis constraint changed from $parenconstraint to " if ($debug);
$parenconstraint = $constraint;
print STDERR "$parenconstraint\n" if ($debug);
print STDERR "Constraint changed from $constraint to " if ($debug);
$constraint = newchild($constraint);
print STDERR "$constraint\n" if ($debug);
} elsif ($token eq "(" && (!$constraint->{DEFINED})) {
my $newconstraint_not = 0;
if ($concat eq "!") {
$newconstraint_not = 1;
}
print STDERR "Constraint changed from $constraint to " if ($debug);
$constraint->{NOT} = $newconstraint_not;
$constraint->{ISPAREN} = 1;
print STDERR "$constraint\n" if ($debug);
$constraint->{GROUP} = 1;
$constraint->{LASTJOIN} = "(";
$constraint->{PREVPAREN} = $parenconstraint;
print STDERR "Parenthesis constraint changed from $parenconstraint to " if ($debug);
$parenconstraint = $constraint;
print STDERR "$parenconstraint\n" if ($debug);
print STDERR "Constraint changed from $constraint to " if ($debug);
$constraint = newparenguts($constraint);
print STDERR "$constraint\n" if ($debug);
$constraint->{LASTJOIN} = "(";
} elsif ($token eq "(") {
if (!$constraint->{DEFINEDSKIPCP}) {
$constraint->{DEFINEDSKIPCP} = 1;
} else {
$constraint->{DEFINEDSKIPCP}++;
}
} elsif ($longtoken eq ">" || $longtoken eq "<" || $longtoken eq "<=" || $longtoken eq ">=" || $longtoken eq "==" || $longtoken eq "!=") {
print STDERR "got comparison: $longtoken\n" if ($debug);
$constraint->{WAITINGCOMPARISON} = $longtoken;
} elsif ($token eq "defined") {
my $constraint_not = 0;
if ($concat eq "!") {
$constraint_not = 1;
}
$constraint->{NOT} = $constraint_not;
$constraint->{DEFINED} = 1;
} elsif ($token =~ /\s*\w+\s*/ && $token ne "if" && $token ne "else" && ((!$HeaderDoc::interpret_case) || ($token ne "case" && $token ne "switch"))) {
print STDERR "got token of interest: $token\n" if ($debug);
if ($constraint->{WAITINGCOMPARISON}) {
print STDERR "Already saw comparison.\n" if ($debug);
print STDERR "LJ: $constraint->{LASTJOIN}\n" if ($debug);
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, $constraint->{WAITINGCOMPARISON}, $token);
$constraint->{WAITINGTOKEN} = undef;
$constraint->{WAITINGCOMPARISON} = undef;
$constraint->{LASTJOIN} = undef
} else {
print STDERR "CONSTRAINT IS $constraint\n" if ($debug);
print STDERR "WAITINGTOKEN -> $token\n" if ($debug);
$constraint->{WAITINGTOKEN} = $token;
print STDERR "TOKENCONCAT IS ".$constraint->{TOKENCONCAT}."\n" if ($debug);
if ($concat eq "!") {
print STDERR "INVERSE MATCH\n" if ($debug);
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, "==", "0"); $constraint->{TOKENCONCAT} = undef;
$constraint->{WAITINGTOKEN} = undef;
$constraint->{WAITINGCOMPARISON} = undef;
$constraint->{LASTJOIN} = undef
}
}
} elsif ($longtoken eq "||") {
if ($constraint->{WAITINGTOKEN}) {
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, "!=", "0"); }
print STDERR "OR\n" if ($debug);
print STDERR "Constraint changed from $constraint to " if ($debug);
$constraint = newsibling($constraint, $parenconstraint);
print STDERR "$constraint\n" if ($debug);
} elsif ($longtoken eq "&&") {
if ($constraint->{WAITINGTOKEN}) {
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, "!=", "0"); $constraint->{WAITINGTOKEN} = undef;
$constraint->{LASTJOIN} = undef
}
print STDERR "AND\n" if ($debug);
print STDERR "Constraint changed from $constraint to " if ($debug);
my $oldcons = $constraint;
$constraint = newchild($constraint);
print STDERR "$constraint\n" if ($debug);
} elsif ($HeaderDoc::interpret_case && $token eq ":" && $constraint->{WAITINGTOKEN}) {
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, $token); } elsif ($token eq ")" && !$constraint->{DEFINEDSKIPCP}) {
if ($constraint->{WAITINGTOKEN}) {
$constraint = adjconstraint($constraint, $parenconstraint, $topconstraint, $constraint->{WAITINGTOKEN}, "!=", "0"); $constraint->{WAITINGTOKEN} = undef;
$constraint->{LASTJOIN} = undef
}
print STDERR "Constraint changed from $constraint to " if ($debug);
my $oldparenconstraint = $parenconstraint;
($constraint, $parenconstraint) = unrolltoparen($constraint, $parenconstraint, 1);
print STDERR "$constraint\n" if ($debug);
print STDERR "Parenthesis constraint changed from $oldparenconstraint to $parenconstraint\n" if ($debug);
} elsif ($token eq ")") {
$constraint->{DEFINEDSKIPCP}--;
} elsif ($token eq "&" || $token eq "|" || $token eq "!" || $token eq "=") {
print STDERR "CONSTRAINT IS -> $constraint\n" if ($debug);
$constraint->{TOKENCONCAT} = $token;
print STDERR "TOKENCONCAT -> ".$constraint->{TOKENCONCAT}."\n" if ($debug);
} elsif ($token =~ /\S/) {
print STDERR "Unexpected token \"$token\". Resetting\n" if ($debug);
$constraint->{WAITINGTOKEN} = undef;
$constraint->{WAITINGCOMPARISON} = undef;
if (attop($topconstraint, $constraint)) {
print STDERR "Full reset\n" if ($debug);
$constraint->{LASTJOIN} = undef;
$constraint = $topconstraint;
$parenconstraint = $topconstraint;
$constraint = newsibling($topconstraint, $parenconstraint);
$parenconstraint = $constraint;
print STDERR "New top node: $constraint\n" if ($debug);
print STDERR "New paren constraint: $parenconstraint\n" if ($debug);
}
}
if ($token =~ /if/) {
print STDERR "IF FOUND\n" if ($debug || $debug_hrb);
} elsif ($token =~ /else/) {
print STDERR "ELSE FOUND\n" if ($debug || $debug_hrb);
} elsif ($token =~ /switch/) {
print STDERR "FOUND $token\n" if ($debug || $debug_hrb);
} elsif ($token =~ /{/) {
print STDERR "FOUND $token\n" if ($debug || $debug_hrb);
} elsif ($token =~ /}/ || $token =~ /;/) {
print STDERR "FOUND $token\n" if ($debug || $debug_hrb);
} elsif (($token =~ /break/) || ($token =~ /return/)) {
print STDERR "FOUND $token\n" if ($debug || $debug_hrb);
$constraint->{HASRETURNORBREAK} = 1;
}
if ($parseTree->firstchild()) {
($constraint, $parenconstraint) = walkTree($parseTree->firstchild(), $constraint, $parenconstraint, $topconstraint);
}
if ($parseTree->next()) {
return walkTree($parseTree->next(), $constraint, $parenconstraint, $topconstraint);
}
return ($constraint, $parenconstraint);
}
sub adjconstraint($$$$$$)
{
my $constraint = shift;
my $parenconstraint = shift;
my $topconstraint = shift;
my $lefttoken = shift;
my $comparison = shift;
my $righttoken = shift;
print STDERR "in adjconstraint\n" if ($debug);
print STDERR "CONSTRAINT: $constraint LJ: $constraint->{LASTJOIN}\n" if ($debug);
if (!defined($constraint->{LASTJOIN})) {
print STDERR "Constraint changed from $constraint to " if ($debug);
$constraint = newsibling($topconstraint, $parenconstraint);
print STDERR "$constraint\n" if ($debug);
}
my $leftmds = 1;
my $leftvalue = 0;
if ($lefttoken =~ /^0x[0-9a-fA-F]+$/ || $lefttoken =~ /^0b[01]+$/ ||
$lefttoken =~ /^0[0-9]+$/) {
$leftvalue = oct($lefttoken);
} elsif ($lefttoken =~ /^\d+$/) {
$leftvalue = $lefttoken;
} else {
$leftmds = $HeaderDoc::filter_macro_definition_state{$lefttoken};
if ($leftmds == 1) {
$leftvalue = $HeaderDoc::filter_macro_definition_value{$lefttoken};
}
if ($leftmds && length($lefttoken)) {$constraint->{LEFTISSYMBOL} = 1; }
}
my $rightmds = 1;
my $rightvalue = 0;
if ($righttoken =~ /^0x[0-9a-fA-F]+$/ || $righttoken =~ /^0b[01]+$/ ||
$righttoken =~ /^0[0-9]+$/) {
$rightvalue = oct($righttoken);
} elsif ($righttoken =~ /^\d+$/) {
$rightvalue = $righttoken;
} else {
$rightmds = $HeaderDoc::filter_macro_definition_state{$righttoken};
if ($rightmds == 1) {
$rightvalue = $HeaderDoc::filter_macro_definition_value{$righttoken};
}
if ($rightmds && length($righttoken)) {$constraint->{RIGHTISSYMBOL} = 1; }
}
$constraint->{LEFTVALUE} = $leftvalue;
$constraint->{LEFTTOKEN} = $lefttoken;
$constraint->{RIGHTVALUE} = $rightvalue;
$constraint->{RIGHTTOKEN} = $righttoken;
$constraint->{COMPARISON} = $comparison;
if (!$leftmds) { $constraint->{LEFTDONTCARE} = 1; }
if (!$rightmds) { $constraint->{RIGHTDONTCARE} = 1; }
print STDERR "IN ADJCONSTRAINT: LEFTVALUE IS $leftvalue LEFTMDS IS $leftmds\n" if ($debug);
print STDERR "RIGHTVALUE IS $rightvalue RIGHTMDS IS $rightmds\n" if ($debug);
print STDERR "CONSTRAINT $constraint:\nLEFT TOKEN: $lefttoken\nLEFT VALUE: ".$constraint->{LEFTVALUE}."\nLEFTDONTCARE: ".$constraint->{LEFTDONTCARE}."\nCOMPARISON: $comparison\nRIGHT TOKEN: $righttoken\nRIGHT VALUE: ".$constraint->{RIGHTVALUE}."\nRIGHTDONTCARE: ".$constraint->{RIGHTDONTCARE}."\n" if ($debug);
return $constraint;
}
sub unrolltoparen
{
my $constraint = shift;
my $parenconstraint = shift;
my $including = shift;
if ($including) {
if ($debug) {
print STDERR "QUICK UNROLLED TO $parenconstraint\n";
if (!$parenconstraint->{ISPAREN}) {
warn "NOT A PARENTHESIS!\n";
}
}
return ($parenconstraint, $parenconstraint->{PREVPAREN});
}
if ($constraint->{PARENWRAPPER}) {
print STDERR "PRETTY QUICK UNROLL: $constraint (parenconstraint is $parenconstraint)\n" if ($debug);
return $constraint->{PARENWRAPPER}->{PARENTREE};
}
print STDERR "SLOW UNROLL: $constraint (parenconstraint is $parenconstraint)\n" if ($debug);
my $lastconstraint = $constraint;
while ($constraint && $constraint != $parenconstraint) {
$lastconstraint = $constraint;
if ($constraint->{PREVIOUS}) { $constraint = $constraint->{PREVIOUS}; }
elsif ($constraint->{PARENT}) { $constraint = $constraint->{PARENT}; }
else { last; }
if ($debug) {
print STDERR "UNROLL: $constraint\n";
}
if ($constraint->{ISPAREN} && ($constraint != $parenconstraint) && !$HeaderDoc::interpret_case) {
warn "Oops. We hit a parenthesis. This should not happen.\n";
}
}
print STDERR "POSTUNROLL: $lastconstraint (compare to $parenconstraint)\n" if ($debug);
return ($lastconstraint, $parenconstraint);
}
sub newparenguts
{
my $constraint = shift;
my $parenconstraint = undef;
if (@_) {
$parenconstraint = shift;
}
my $nextconstraint = newconstraint();
print STDERR "Adding new sibling $nextconstraint to $constraint\n" if ($debug);
$nextconstraint->{PARENT} = $constraint->{PARENT};
$nextconstraint->{PARENWRAPPER} = $constraint;
$constraint->{PARENTREE} = $nextconstraint;
$constraint->{WAITINGCOMPARISON} = undef;
$constraint->{WAITINGTOKEN} = undef;
$nextconstraint->{LASTJOIN} = "||";
$nextconstraint->{PREVIOUS}=$constraint;
return $nextconstraint;
}
sub newsibling
{
my $constraint = shift;
my $parenconstraint = undef;
if (@_) {
$parenconstraint = shift;
}
if ($parenconstraint) {
($constraint, $parenconstraint) = unrolltoparen($constraint, $parenconstraint, 0);
}
while ($constraint->{NEXT}) {
$constraint = $constraint->{NEXT};
}
my $nextconstraint = newconstraint();
print STDERR "Adding new sibling $nextconstraint to $constraint\n" if ($debug);
$nextconstraint->{PARENT} = $constraint->{PARENT};
$constraint->{NEXT} = $nextconstraint;
$constraint->{WAITINGCOMPARISON} = undef;
$constraint->{WAITINGTOKEN} = undef;
$nextconstraint->{LASTJOIN} = "||";
$nextconstraint->{PREVIOUS} = $constraint;
$nextconstraint->{PARENWRAPPER} = $constraint->{PARENWRAPPER};
return $nextconstraint;
}
sub newchild
{
my $constraint = shift;
my $childconstraint = newconstraint();
my $localDebug = 0;
print STDERR "Adding new child $childconstraint to $constraint\n" if ($localDebug);
while ($constraint->{FIRSTCHILD}) {
$constraint = $constraint->{FIRSTCHILD};
}
print STDERR "Really adding new child $childconstraint to $constraint\n" if ($localDebug || $debug);
if ($constraint->{DEFINED}) { $childconstraint->{DEFINED} = $constraint->{DEFINED} + 1; }
$constraint->{FIRSTCHILD} = $childconstraint;
$childconstraint->{PARENT} = $constraint;
$constraint->{WAITINGCOMPARISON} = undef;
$constraint->{WAITINGTOKEN} = undef;
$childconstraint->{LASTJOIN} = "&&";
$childconstraint->{PARENWRAPPER} = $constraint->{PARENWRAPPER};
return $childconstraint;
}
sub localmatch
{
my $constraint = shift;
my $use_default_value = shift;
my $default_value = shift;
my $printing = 0;
if (@_) {
$printing = shift;
}
my $leftvalue = $constraint->{LEFTVALUE};
my $rightvalue = $constraint->{RIGHTVALUE};
print STDERR "Checking constraint $constraint\n" if ($debug);
printconstraint($constraint, 1) if ($debug && !$printing);
if ($constraint->{DEFINED}) {
my $def = $HeaderDoc::filter_macro_definition_state{$constraint->{LEFTTOKEN}};
if ($constraint->{NOT}) {
if ($def == 1) { return 0; } if ($def == -1) { return 1; } return -3; } else {
if ($def == -1) { return 0; } if ($def == 1) { return 1; } return -3; }
}
if ($constraint->{LEFTDONTCARE}) {
print STERR "LEFTDONTCARE\n" if ($debug);
if ($use_default_value && $constraint->{RIGHTISSYMBOL}) {
print STDERR "USING DEFAULT VALUE ($default_value) FOR LEFT (".$constraint->{LEFTTOKEN}." ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}.")\n" if ($debug);
$leftvalue = $default_value;
} elsif ($use_default_value) {
return -1;
} else {
return -3;
}
}
if ($constraint->{RIGHTDONTCARE}) {
print STERR "RIGHTDONTCARE\n" if ($debug);
if ($use_default_value && $constraint->{LEFTISSYMBOL}) {
print STDERR "USING DEFAULT VALUE ($default_value) FOR RIGHT (".$constraint->{LEFTTOKEN}." ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}.")\n" if ($debug);
$rightvalue = $default_value;
} elsif ($use_default_value) {
return -1;
} else {
return -3;
}
}
if ($constraint->{ALWAYSFALSE}) {
return 0;
}
if (!$constraint->{COMPARISON}) {
return -1;
}
if ($constraint->{COMPARISON} eq "==") {
if ($leftvalue == $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($HeaderDoc::enable_reverse_match && ($constraint->{COMPARISON} eq "!=") &&
(($HeaderDoc::reverse_match eq $constraint->{LEFTTOKEN} && !$constraint->{RIGHTISSYMBOL}) ||
($HeaderDoc::reverse_match eq $constraint->{RIGHTTOKEN} && !$constraint->{LEFTISSYMBOL})
)) {
if ($leftvalue == $rightvalue) {
return 1;
} else {
return 0;
}
} elsif ($constraint->{COMPARISON} eq "!=") {
if ($leftvalue != $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($constraint->{COMPARISON} eq "<") {
if ($leftvalue < $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($constraint->{COMPARISON} eq "<=") {
if ($leftvalue <= $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($constraint->{COMPARISON} eq ">") {
if ($leftvalue > $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($constraint->{COMPARISON} eq ">=") {
if ($leftvalue >= $rightvalue) {
return 1;
} else {
return 0;
}
}
if ($HeaderDoc::interpret_case && ($constraint->{COMPARISON} eq ":")) {
if ($constraint->{LEFTISSYMBOL} && $use_default_value &&
($leftvalue == $default_value)) {
return 1;
}
return 0;
}
die("Unknown comparison operator ".$constraint->{COMPARISON}."\n");
}
sub matchesconstraints
{
my $constraint = shift;
my $use_default_value = 0;
my $default_value = undef;
if (@_) {
$use_default_value = 1;
$default_value = shift;
}
my ($result, $poss) = matchesconstraints_sub($constraint, $use_default_value, $default_value);
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug);
print STDERR "TOP: RETURN($result, $poss): $constraint\n" if ($debug);
if ($poss == -3) { return -3; }
return $result;
}
sub matchesconstraints_sub
{
my $constraint = shift;
my $use_default_value = shift;
my $default_value = shift;
my $possmatch = 0;
my $localDebug = 0;
my $local = localmatch($constraint, $use_default_value, $default_value);
print STDERR "INMATCH: $constraint\n" if ($debug || $localDebug);
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}."/".$constraint->{LEFTDONTCARE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}."/".$constraint->{RIGHTDONTCARE}.")\n" if ($debug || $localDebug);
if ($constraint->{ISPAREN} && $constraint->{PARENTREE}) {
($local, $possmatch) = matchesconstraints_sub($constraint->{PARENTREE}, $use_default_value, $default_value);
print STDERR "PARENTHESIS: CHECKING NEXT" if ($debug || $localDebug);
if ($constraint->{NOT}) {
if ($local) {
$local = 0;
} elsif ($possmatch == -3) {
$local = -3;
} else {
$local = 1;
}
} else {
if ((!$local) && ($possmatch == -3)) {
$local = -3;
}
}
}
print STDERR "LOCAL STARTING AT $local\n" if ($debug || $localDebug);
if (($local == -3 || $local == -1) && $constraint->{SWITCHGUTS}) {
print STDERR "SWITCHGUTS FOUND\n" if ($debug || $localDebug);
print STDERR $constraint->{SWITCHGUTS}."\n" if ($debug || $localDebug);
print STDERR "SWITCHGUTS END\n" if ($debug || $localDebug);
my ($newlocal, $newpossmatch) = matchesconstraints_sub($constraint->{SWITCHTREE}, $use_default_value, $default_value);
print STDERR "SWITCHGUTS RETURNED $newlocal\n" if ($debug || $localDebug);
if ($newlocal == 1) {
$local = 1;
}
}
if (($local == -3 || $local == -1) && $constraint->{IFGUTS}) {
print STDERR "IFGUTS FOUND\n" if ($debug || $localDebug);
my ($newlocal, $newpossmatch) = matchesconstraints_sub($constraint->{IFTREE}, $use_default_value, $default_value);
print STDERR "IFGUTS RETURNED $newlocal\n" if ($debug || $localDebug);
if ($newlocal == 1) {
$local = 1;
} else {
my $elseguts = undef;
my $elsetree = undef;
if ($constraint->{ELSEGUTS}) {
$elseguts = $constraint->{ELSEGUTS};
$elsetree = $constraint->{ELSETREE};
} else {
my $next = $constraint->{NEXT};
while ($next) {
if ($next->{ELSEGUTS}) {
$elseguts = $next->{ELSEGUTS};
$elsetree = $next->{ELSETREE};
}
$next = $next->{NEXT};
}
}
if ($elseguts) {
print STDERR "ELSEGUTS FOUND\n" if ($debug || $localDebug);
my ($newlocal, $newpossmatch) = matchesconstraints_sub($elsetree, $use_default_value, $default_value);
print STDERR "IFGUTS RETURNED $newlocal\n" if ($debug || $localDebug);
if ($newlocal == 1) {
$local = 1;
}
}
}
}
if ($local) {
if ($constraint->{FIRSTCHILD}) {
print STDERR "Calling on FIRSTCHILD $constraint->{FIRSTCHILD}\n" if ($debug || $localDebug);
my ($childres, $childpos) = matchesconstraints_sub($constraint->{FIRSTCHILD}, $use_default_value, $default_value);
if ($childres) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[0]RETURN(1, 0): $constraint\n" if ($debug || $localDebug);
return ($local, 0);
}
if ($childpos == -3 && $local) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "SETTING POSSMATCH -> -3\n" if ($debug || $localDebug);
$possmatch = -3;
} elsif ($childpos) {
print STDERR "CHILDPOS IS $childpos\n" if ($debug || $localDebug);
if ($local == 1) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[3]RETURN(1, 0): $constraint\n" if ($debug || $localDebug);
return (1, 0);
} elsif ($local == -3) {
print STDERR "SETTING POSSMATCH -> -3\n" if ($debug || $localDebug);
$possmatch = -3;
} else {
if (!$HeaderDoc::interpret_case) { die "SETTING POSSMATCH -> 1\n"; }
$possmatch = 1;
}
}
} else {
if ($local == 1) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[4]RETURN(1, 0): $constraint\n" if ($debug || $localDebug);
return (1, 0);
} elsif ($local == -3) {
$possmatch = $local;
} else {
$possmatch = $local;
}
}
}
if ($constraint->{NEXT}) {
print STDERR "Calling on NEXT $constraint->{FIRSTCHILD}\n" if ($debug || $localDebug);
my ($nextres, $nextposs) = matchesconstraints_sub($constraint->{NEXT}, $use_default_value, $default_value);
if ($nextres) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[5]RETURN(1, 0): $constraint\n" if ($debug || $localDebug);
return (1, 0);
}
if ($nextposs == -3) {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[5A]RETURN(0, -3): $constraint\n" if ($debug || $localDebug);
return (0, -3);
} else {
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "[6]RETURN(0, 0): $constraint\n" if ($debug || $localDebug);
return (0, $possmatch);
}
}
print STDERR "TEST: ".$constraint->{LEFTTOKEN}." (".$constraint->{LEFTVALUE}.") ".$constraint->{COMPARISON}." ".$constraint->{RIGHTTOKEN}." (".$constraint->{RIGHTVALUE}.")\n" if ($debug || $localDebug);
print STDERR "AT END: RETURN(0, $possmatch): $constraint\n" if ($debug || $localDebug);
return (0, $possmatch);
}
sub isnullconstraint
{
my $constraint = shift;
my $olddebug = $debug;
my $printing = 0;
if (@_) {
$printing = shift;
}
if ($constraint->{IFGUTS}) { return 0; }
if ($constraint->{ELSEGUTS}) { return 0; }
if ($constraint->{ISPAREN}) { return 0; }
$debug = 0;
if (localmatch($constraint, 0, 0, $printing) == -1) {
$debug = $olddebug;
return 1;
}
$debug = $olddebug;
return 0;
}
sub attop
{
my $topconstraint = shift;
my $constraint = shift;
my $attopdebug = 1;
print STDERR "attop: $constraint\n" if ($debug && $attopdebug);
$constraint= $constraint->{PARENT};
while ($constraint && isnullconstraint($constraint)) {
print STDERR "attop_loop: $constraint\n" if ($debug && $attopdebug);
$constraint = $constraint->{PARENT};
}
print STDERR "attop_end: $constraint\n" if ($debug && $attopdebug);
if ($constraint) {
print STDERR "NOT NULL CONSTRAINT IN PATH:\n" if ($debug);
printconstraint($constraint) if ($debug);
return 0;
}
return 1;
}
sub dotest($$)
{
my $string = shift;
my $expected_value = shift;
my $lang = shift;
my $sublang = shift;
my $retval = 1;
$HeaderDoc::lang = $lang;
$HeaderDoc::sublang = $sublang;
my $temp = $HeaderDoc::parseIfElse;
$HeaderDoc::parseIfElse = 1;
my ($tree, @junk) = doit($string, $lang, $sublang);
my $mc = matchesconstraints($tree);
if ($mc != $expected_value) {
warn("$string: \e[31mFAILED\e[39m\nEXPECTED: $expected_value GOT: $mc\n");
printconstraint($tree);
$retval = 0;
} else {
warn("$string: \e[32mOK\e[39m\n");
}
$HeaderDoc::parseIfElse = $temp;
return $retval;
}
sub filterFileString($)
{
my $data = shift;
my $output = "";
my $localDebug = 0;
my @parts = split(/(\n\s*)(
my @curshow_stack = ();
my $curshow = 1;
my $handlenext = undef;
foreach my $part (@parts) {
print STDERR "PART: $part\n" if ($localDebug);
if ($part =~ / $curshow = pop(@curshow_stack);
print STDERR "POPPED $curshow\n" if ($localDebug);
if ($curshow) { $output .= $part; };
} elsif ($handlenext) {
my $rest = "";
if ($handlenext =~ /( print STDERR "PUSHING $curshow\n" if ($localDebug);
push(@curshow_stack, $curshow);
}
my $prevcurshow = $curshow;
my $ifDeclaration = "";
($curshow, $rest, $ifDeclaration) = ignoreWithinCPPDirective($handlenext, $part, $curshow);
if ($prevcurshow) { $output .= "#".$ifDeclaration."\n"; };
$handlenext = undef;
if ($curshow) { $output .= $rest; }
} elsif ($part =~ / my $tempcurshow = $curshow;
$curshow = pop(@curshow_stack);
if ($curshow) { $output .= $part."\n"; };
push(@curshow_stack, $curshow);
$curshow = $tempcurshow;
print STDERR "PREVIOUS SHOW WAS $curshow\n" if ($localDebug);
if ($curshow == 1) {
$curshow = 0;
} else {
print STDERR "curshow -> 1\n" if ($localDebug);
$curshow = 1;
}
} elsif ($part =~ /( $handlenext = $part;
} else {
if ($curshow) { $output .= $part; }
}
}
return $output;
}
sub hasReturnOrBreak($)
{
my $tree = shift;
my $localDebug = 0;
if (!$tree) { return 0; }
print STDERR "HRB CHECK $tree\n" if ($localDebug);
if ($tree->{HASRETURNORBREAK}) {
print STDERR "HRB LOCAL YES\n" if ($localDebug);
return 1;
}
my $ifHRB = 0;
my $elseHRB = 0;
if ($tree->{IFTREE} && $localDebug) {
print STDERR "HRB CHECKING IF\n";
print STDERR "BEGIN IF GUTS\n";
print STDERR $tree->{IFGUTS}."\n";
print STDERR "END IF GUTS\n";
}
if (hasReturnOrBreak($tree->{IFTREE})) {
print STDERR "HRB IF YES\n" if ($localDebug);
$ifHRB = 1;
}
my $elsetree = undef;
my $elseguts = undef;
if ($tree->{IFTREE}) {
print STDERR "HRB DONE CHECKING IF\n" if ($localDebug);
if ($tree->{ELSETREE}) {
$elsetree = $tree->{ELSETREE}
} else {
my $next = $tree->{NEXT};
while ($next) {
if ($next->{ELSETREE}) {
$elsetree = $next->{ELSETREE};
$elseguts = $next->{ELSEGUTS};
print STDERR "HRB CHAIN ($next) HAS ELSE\n" if ($localDebug);
last;
}
$next = $next->{NEXT};
}
}
}
if ($elsetree && $localDebug) {
print STDERR "HRB CHECKING ELSE\n";
print STDERR "BEGIN ELSE GUTS\n";
print STDERR $elseguts."\n";
print STDERR "END ELSE GUTS\n";
}
if (hasReturnOrBreak($elsetree)) {
print STDERR "HRB ELSE YES\n" if ($localDebug);
$elseHRB = 1;
}
if ($elsetree && $localDebug) {
print STDERR "HRB DONE CHECKING ELSE\n";
}
if ($ifHRB && $elseHRB && $localDebug) {
print STDERR "HRB IF AND ELSE YES\n";
}
return ($ifHRB && $elseHRB);
}
1;