autom4te.in

来自「LINUX下的源码工具,可自己分析,或者直接装在系统上作为应用」· IN 代码 · 共 1,233 行 · 第 1/3 页

Copyright 2002 Free Software Foundation, Inc.
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
EOF


## ---------- ##
## Routines.  ##
## ---------- ##


# $OPTION
# files_to_options (@FILE)
# ------------------------
# Transform Autom4te conventions (e.g., using foo.m4f to designate a frozen
# file) into a suitable command line for M4 (e.g., using --reload-state).
sub files_to_options (@)
{
  my (@file) = @_;
  my @res;
  foreach my $file (@file)
    {
      if ($file =~ /\.m4f$/)
	{
	  push @res, "--reload-state=$file";
	}
      else
	{
	  push @res, $file;
	}
    }
  return join ' ', @res;
}


# load_configuration ($FILE)
# --------------------------
# Load the configuration $FILE.
sub load_configuration ($)
{
  my ($file) = @_;
  use Text::ParseWords;

  my $cfg = new Autom4te::XFile ($file);
  my $lang;
  while ($_ = $cfg->getline)
    {
      chomp;
      # Comments.
      next
	if /^\s*(\#.*)?$/;

      my @words = shellwords ($_);
      my $type = shift @words;
      if ($type eq 'begin-language:')
	{
	  error "$file:$.: end-language missing for: $lang"
	    if defined $lang;
	  $lang = lc $words[0];
	}
      elsif ($type eq 'end-language:')
	{
	  error "$file:$.: end-language mismatch: $lang"
	    if $lang ne lc $words[0];
	  $lang = undef;
	}
      elsif ($type eq 'args:')
	{
	  error "$file:$.: no current language"
	    unless defined $lang;
	  push @{$language{$lang}}, @words;
	}
      else
	{
	  error "$file:$.: unknown directive: $type";
	}
    }
}


# parse_args ()
# -------------
# Process any command line arguments.
sub parse_args ()
{
  # We want to look for the early options, which should not be found
  # in the configuration file.  Prepend to the user arguments.
  # Perform this repeatedly so that we can use --language in language
  # definitions.  Beware that there can be several --language
  # invocations.
  my @language;
  do {
    @language = ();
    use Getopt::Long;
    Getopt::Long::Configure ("pass_through", "permute");
    GetOptions ("l|language=s" => \@language);

    foreach (@language)
      {
	error "unknown language: $_"
	  unless exists $language{lc $_};
	unshift @ARGV, @{$language{lc $_}};
      }
  } while @language;

  # --debug is useless: it is parsed below.
  if (exists $ENV{'AUTOM4TE_DEBUG'})
    {
      print STDERR "$me: concrete arguments:\n";
      foreach my $arg (@ARGV)
	{
	  print STDERR "| $arg\n";
	}
    }

  # Process the arguments for real this time.
  my @trace;
  my @prepend_include;
  getopt
    (
     # Operation modes:
     "o|output=s"   => \$output,
     "W|warnings=s" => \@warning,
     "m|mode=s"     => \$mode,
     "M|melt"       => \$melt,

     # Library directories:
     "B|prepend-include=s" => \@prepend_include,
     "I|include=s"         => \@include,

     # Tracing:
     # Using a hash for traces is seducing.  Unfortunately, upon `-t FOO',
     # instead of mapping `FOO' to undef, Getopt maps it to `1', preventing
     # us from distinguishing `-t FOO' from `-t FOO=1'.  So let's do it
     # by hand.
     "t|trace=s"     => \@trace,
     "p|preselect=s" => \@preselect,

     # Freezing.
     "F|freeze" => \$freeze,

     # Caching.
     "C|cache=s" => \$cache,
     "no-cache"  => sub { $cache = undef; },
    );

  error "too few arguments
Try `$me --help' for more information."
    unless @ARGV;

  # Freezing:
  # We cannot trace at the same time (well, we can, but it sounds insane).
  # And it implies melting: there is risk not to update properly using
  # old frozen files, and worse yet: we could load a frozen file and
  # refreeze it!  A sort of caching :)
  error "cannot freeze and trace"
    if $freeze && @trace;
  $melt = 1
    if $freeze;

  # Names of the cache directory, cache directory index, trace cache
  # prefix, and output cache prefix.  If the cache is not to be
  # preserved, default to a temporary directory (automatically removed
  # on exit).
  $cache = $tmp
    unless $cache;
  $icache = "$cache/requests";
  $tcache = "$cache/traces.";
  $ocache = "$cache/output.";

  # Normalize the includes: the first occurrence is enough, several is
  # a pain since it introduces a useless difference in the path which
  # invalidates the cache.  And strip `.' which is implicit and always
  # first.
  @include = grep { !/^\.$/ } uniq (reverse(@prepend_include), @include);

  # Convert @trace to %trace, and work around the M4 builtins tracing
  # problem.
  # The default format is `$f:$l:$n:$%'.
  foreach (@trace)
    {
      /^([^:]+)(?::(.*))?$/ms;
      $trace{$1} = defined $2 ? $2 : '$f:$l:$n:$%';
      $trace{$m4_builtin_alternate_name{$1}} = $trace{$1}
	if exists $m4_builtin_alternate_name{$1};
    }

  # Work around the M4 builtins tracing problem for @PRESELECT.
  push (@preselect,
	map { $m4_builtin_alternate_name{$_} }
	grep { exists $m4_builtin_alternate_name{$_} } @preselect);

  # If we find frozen files, then all the files before it are
  # discarded: the frozen file is supposed to include them all.
  #
  # We don't want to depend upon m4's --include to find the top level
  # files, so we use `find_file' here.  Try to get a canonical name,
  # as it's part of the key for caching.  And some files are optional
  # (also handled by `find_file').
  my @argv;
  foreach (@ARGV)
    {
      if (/\.m4f$/)
	{
	  # Frozen files are optional => pass a `?' to `find_file'.
	  my $file = find_file ("$_?", @include);
	  if (!$melt && $file)
	    {
	      @argv = ($file);
	    }
	  else
	    {
	      s/\.m4f$/.m4/;
	      push @argv, find_file ($_, @include);
	    }
	}
      else
	{
	  my $file = find_file ($_, @include);
	  push @argv, $file
	    if $file;
	}
    }
  @ARGV = @argv;
}


# handle_m4 ($REQ, @MACRO)
# ------------------------
# Run m4 on the input files, and save the traces on the @MACRO.
sub handle_m4 ($@)
{
  my ($req, @macro) = @_;

  # The warnings are the concatenation of 1. application's defaults,
  # 2. $WARNINGS, $3 command line options, in that order.
  # Set them in the order expected by the M4 macros: the converse.
  my $m4_warnings =
    lc join (',', reverse (split (',', ($ENV{'WARNINGS'} || '')),
			   map { split /,/ } @warning));

  # GNU m4 appends when using --error-output.
  unlink ($tcache . $req->id . "t");

  # Run m4.
  #
  # Neutralize its stdin, so that GNU M4 1.5 doesn't neutralize SIGINT.
  #
  # We don't output directly to the cache files, to avoid problems
  # when we are interrupted (that leaves corrupted files).
  xsystem ("$m4"
	   . join (' --include=', '', @include)
	   . " --define=m4_warnings=$m4_warnings"
	   . ' --debug=aflq'
	   . (!exists $ENV{'AUTOM4TE_NO_FATAL'} ? ' --fatal-warning' : '')
	   . " --error-output=$tcache" . $req->id . "t"
	   . join (' --trace=',   '', sort @macro)
	   . " " . files_to_options (@ARGV)
	   . ' </dev/null'
	   . " >$ocache" . $req->id . "t");

  # Everything went ok: preserve the outputs.
  foreach my $file (map { $_ . $req->id } ($tcache, $ocache))
    {
      use File::Copy;
      move ("${file}t", "$file")
	or error "cannot not rename ${file}t as $file: $!";
    }
}


# warn_forbidden ($WHERE, $WORD, %FORBIDDEN)
# ------------------------------------------
# $WORD is forbidden.  Warn with a dedicated error message if in
# %FORBIDDEN, otherwise, a simple `error: possibly undefined macro'
# will do.
my $first_warn_forbidden = 1;
sub warn_forbidden ($$%)
{
  my ($where, $word, %forbidden) = @_;
  my $message;

  for my $re (sort keys %forbidden)
    {
      if ($word =~ $re)
	{
	  $message = $forbidden{$re};
	  last;
	}
    }
  $message ||= "possibly undefined macro: $word";
  warn "$where: error: $message\n";
  if ($first_warn_forbidden)
    {
      warn <<EOF;
      If this token and others are legitimate, please use m4_pattern_allow.
      See the Autoconf documentation.
EOF
      $first_warn_forbidden = 0;
    }
}


# handle_output ($REQ, $OUTPUT)
# -----------------------------
# Run m4 on the input files, perform quadrigraphs substitution, check for
# forbidden tokens, and save into $OUTPUT.
sub handle_output ($$)
{
  my ($req, $output) = @_;

  verbose "creating $output";

  # Load the forbidden/allowed patterns.
  handle_traces ($req, "$tmp/patterns",
		 ('m4_pattern_forbid' => 'forbid:$1:$2',
		  'm4_pattern_allow'  => 'allow:$1'));
  my @patterns = new Autom4te::XFile ("$tmp/patterns")->getlines;
  chomp @patterns;
  my %forbidden =
    map { /^forbid:([^:]+):.+$/ => /^forbid:[^:]+:(.+)$/ } @patterns;
  my $forbidden = join ('|', map { /^forbid:([^:]+)/ } @patterns) || "^\$";
  my $allowed   = join ('|', map { /^allow:([^:]+)/  } @patterns) || "^\$";

  verbose "forbidden tokens: $forbidden";
  verbose "forbidden token : $_ => $forbidden{$_}"
    foreach (sort keys %forbidden);
  verbose "allowed   tokens: $allowed";

  # Read the (cached) raw M4 output, produce the actual result.  We
  # have to use the 2nd arg to have Autom4te::XFile honor the third, but then
  # stdout is to be handled by hand :(.  Don't use fdopen as it means
  # we will close STDOUT, which we already do in END.
  my $out = new Autom4te::XFile;
  if ($output eq '-')
    {
      $out->open (">$output");
    }
  else
    {
      $out->open($output, O_CREAT | O_WRONLY | O_TRUNC, oct ($mode));
    }
  error "cannot create $output: $!"
    unless $out;
  my $in = new Autom4te::XFile ($ocache . $req->id);

  my %prohibited;
  my $res;
  while ($_ = $in->getline)
    {
      s/\s+$//;
      s/__oline__/$./g;
      s/\@<:\@/[/g;
      s/\@:>\@/]/g;
      s/\@S\|\@/\$/g;
      s/\@%:\@/#/g;

      $res = $_;

      # Don't complain in comments.  Well, until we have something
      # better, don't consider `#include' etc. are comments.
      s/\#.*//
	unless /^\#\s*(if|include|endif|ifdef|ifndef|define)\b/;
      foreach (split (/\W+/))
	{
	  $prohibited{$_} = $.
	    if /$forbidden/o && !/$allowed/o && ! exists $prohibited{$_};
	}

      # Performed *last*: the empty quadrigraph.
      $res =~ s/\@&t\@//g;

      print $out "$res\n";
    }

  # If no forbidden words, we're done.
  return
    if ! %prohibited;

  # Locate the forbidden words in the last input file.
  # This is unsatisfying but...
  my $prohibited = '\b(' . join ('|', keys %prohibited) . ')\b';
  my $file = new Autom4te::XFile ($ARGV[$#ARGV]);
  $exit_status = 1;

  while ($_ = $file->getline)
    {
      # Don't complain in comments.  Well, until we have something
      # better, don't consider `#include' etc. are comments.
      s/\#.*//
	unless /^\#(if|include|endif|ifdef|ifndef|define)\b/;

      # Complain once per word, but possibly several times per line.
      while (/$prohibited/)
	{
	  my $word = $1;
	  warn_forbidden ("$ARGV[$#ARGV]:$.", $word, %forbidden);
	  delete $prohibited{$word};
	  # If we're done, exit.
	  return
	    if ! %prohibited;
	  $prohibited = '\b(' . join ('|', keys %prohibited) . ')\b';
	}
    }
  warn_forbidden ("$output:$prohibited{$_}", $_, %forbidden)
    foreach (sort { $prohibited{$a} <=> $prohibited{$b} } keys %prohibited);
}


## --------------------- ##
## Handling the traces.  ##