bin/autom4te.in

   1 #! @PERL@ -w
   2 # -*- perl -*-
   3 # @configure_input@
   4
   5 eval 'exec @PERL@ -S $0 ${1+"$@"}'
   6     if 0;
   7
   8 # autom4te - Wrapper around M4 libraries.
   9 # Copyright 2001 Free Software Foundation, Inc.
  10
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2, or (at your option)
  14 # any later version.
  15
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20
  21 # You should have received a copy of the GNU General Public License
  22 # along with this program; if not, write to the Free Software
  23 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  24 # 02111-1307, USA.
  25
  26
  27 BEGIN
  28 {
  29   my $datadir = ($ENV{'autom4te_perllibdir'} || '@datadir@');
  30   unshift @INC, "$datadir";
  31 }
  32
  33 ## --------- ##
  34 ## Request.  ##
  35 ## --------- ##
  36
  37 package Request;
  38
  39 use Data::Dumper;
  40 use Autom4te::General;
  41 use Autom4te::Struct;
  42 use Autom4te::XFile;
  43 use Carp;
  44 use strict;
  45
  46 # List of requests.
  47 # We can't declare it `my' as the loading, performed via `do',
  48 # would refer to another scope, and @request would not be updated.
  49 # It used to work with `my' vars, and I don't know whether the current
  50 # behavior (5.6) is wanted or not.
  51 use vars qw(@request);
  52
  53 struct
  54   (
  55    # The key of the cache files.
  56    'id' => "\$",
  57    # True iff %MACRO contains all the macros we want to trace.
  58    'valid' => "\$",
  59    # The include path.
  60    'path' => '@',
  61    # The set of input files.
  62    'input' => '@',
  63    # The set of macros currently traced.
  64    'macro' => '%',
  65   );
  66
  67
  68 # $REQUEST-OBJ
  69 # retrieve ($SELF, %ATTR)
  70 # -----------------------
  71 # Find a request with the same path and input.
  72 # Private.
  73 sub retrieve
  74 {
  75   my ($self, %attr) = @_;
  76
  77   foreach (@request)
  78     {
  79       # Same path.
  80       next
  81         if join ("\n", @{$_->path}) ne join ("\n", @{$attr{path}});
  82
  83       # Same inputs.
  84       next
  85         if join ("\n", @{$_->input}) ne join ("\n", @{$attr{input}});
  86
  87       # Found it.
  88       return $_;
  89     }
  90
  91   return undef;
  92 }
  93
  94
  95 # $REQUEST-OBJ
  96 # register ($SELF, %ATTR)
  97 # -----------------------
  98 # NEW should not be called directly.
  99 # Private.
 100 sub register ($%)
 101 {
 102   my ($self, %attr) = @_;
 103
 104   # path and input are the only ID for a request object.
 105   my $obj = $self->new ('path'  => $attr{path},
 106                         'input' => $attr{input});
 107   push @request, $obj;
 108
 109   # Assign an id for cache file.
 110   $obj->id ("$#request");
 111
 112   return $obj;
 113 }
 114
 115
 116 # $REQUEST-OBJ
 117 # request($SELF, %REQUEST)
 118 # ------------------------
 119 # Return a request corresponding to $REQUEST{path} and $REQUEST{input},
 120 # using a cache value if it exists.
 121 sub request ($%)
 122 {
 123   my ($self, %request) = @_;
 124
 125   my $req = Request->retrieve (%request) || Request->register (%request);
 126
 127   # If there are new traces to produce, then we are not valid.
 128   foreach (@{$request{'macro'}})
 129     {
 130       if (! exists ${$req->macro}{$_})
 131         {
 132           ${$req->macro}{$_} = 1;
 133           $req->valid (0);
 134         }
 135     }
 136
 137   # It would be great to have $REQ check that it up to date wrt its
 138   # dependencies, but that requires gettting traces (to fetch the
 139   # included files), which is out of the scope of Request
 140   # (currently?).
 141
 142   return $req;
 143 }
 144
 145 # Serialize a request or all the current requests.
 146 sub marshall
 147 {
 148   my ($caller) = @_;
 149   my $res = '';
 150
 151   if (ref ($caller))
 152     {
 153       # CALLER is an object: instance method.
 154       my $marshall = Data::Dumper->new ([$caller]);
 155       $marshall->Indent(2)->Terse(0);
 156       $res = $marshall->Dump . "\n";
 157     }
 158   else
 159     {
 160       # CALLER is the package: class method.
 161       my $marshall = Data::Dumper->new ([\@request], [qw (*request)]);
 162       $marshall->Indent(2)->Terse(0);
 163       $res = $marshall->Dump . "\n";
 164     }
 165
 166   return $res;
 167 }
 168
 169
 170 # includes_p (@MACRO)
 171 # -------------------
 172 # Does this request covers all the @MACRO.
 173 sub includes_p
 174 {
 175   my ($self, @macro) = @_;
 176
 177   foreach (@macro)
 178     {
 179       return 0
 180         if ! exists ${$self->macro}{$_};
 181     }
 182   return 1;
 183 }
 184
 185
 186 # SAVE ($FILENAME)
 187 # ----------------
 188 sub save
 189 {
 190   my ($self, $filename) = @_;
 191
 192   croak "$me: cannot save a single request\n"
 193     if ref ($self);
 194
 195   my $requests = new Autom4te::XFile ("> $filename");
 196   print $requests
 197     "# This file was created by $me.\n",
 198     "# It contains the lists of macros which have been traced.\n",
 199     "# It can be safely removed.\n",
 200     "\n",
 201     $self->marshall;
 202 }
 203
 204
 205 # LOAD ($FILE)
 206 # ------------
 207 sub load
 208 {
 209   my ($self, $file) = @_;
 210
 211   croak "$me: cannot load a single request\n"
 212     if ref ($self);
 213
 214   (my $return) = do "$file";
 215
 216   croak "$me: cannot parse $file: $@\n" if $@;
 217   croak "$me: cannot do $file: $!\n"    if $!;
 218   croak "$me: cannot run $file\n"       unless $return;
 219 }
 220
 221
 222 ## ---------- ##
 223 ## Autom4te.  ##
 224 ## ---------- ##
 225
 226 package Autom4te;
 227
 228 use Autom4te::General;
 229 use File::Basename;
 230 use Autom4te::XFile;
 231 use strict;
 232
 233 # Configuration file.
 234 my $datadir = $ENV{'AC_MACRODIR'} || '@datadir@';
 235 my $autom4te_cfg = $ENV{'AUTOM4TE_CFG'} || "$datadir/autom4te.cfg";
 236
 237 # $LANGUAGE{LANGUAGE} -- Automatic options for LANGUAGE.
 238 my %language;
 239
 240 my $output = '-';
 241
 242 # Mode of the output file except for traces.
 243 my $mode = "0666";
 244
 245 # If melt, don't use frozen files.
 246 my $melt = 0;
 247
 248 # Names of the cache directory, cache directory index, trace cache
 249 # prefix, and output cache prefix.
 250 my $cache = "$me.cache";
 251 my $icache = "$cache/requests";
 252 my $tcache = "$cache/traces.";
 253 my $ocache = "$cache/output.";
 254
 255 # The macros to trace mapped to their format, as specified by the
 256 # user.
 257 my %trace;
 258
 259 # The macros the user will want to trace in the future.
 260 # We need `include' to get the included file, `m4_pattern_forbid' and
 261 # `m4_pattern_allow' to check the output.
 262 #
 263 # FIXME: What about `sinclude'?
 264 my @preselect = ('include', 'm4_pattern_allow', 'm4_pattern_forbid');
 265
 266 # List of warnings.
 267 my @warning;
 268
 269 # M4 include path.
 270 my @include;
 271
 272 # 0 for EXIT_SUCCESS.
 273 my $exit_status = 0;
 274
 275 # $M4.
 276 my $m4 = $ENV{"M4"} || '@M4@';
 277 # Some non-GNU m4's don't reject the --help option, so give them /dev/null.
 278 die "$me: need GNU m4 1.4 or later: $m4\n"
 279   if system "$m4 --help </dev/null 2>&1 | fgrep reload-state >/dev/null";
 280
 281 # Set some high recursion limit as the default limit, 250, has already
 282 # been hit with AC_OUTPUT.  Don't override the user's choice.
 283 $m4 .= ' --nesting-limit=1024'
 284   if " $m4 " !~ / (--nesting-limit|-L) /;
 285
 286
 287 # @M4_BUILTIN -- M4 builtins and a useful comment.
 288 my @m4_builtin = `echo dumpdef | $m4 2>&1 >/dev/null`;
 289 map { s/:.*//;s/\W// } @m4_builtin;
 290
 291
 292 # %M4_BUILTIN_ALTERNATE_NAME
 293 # --------------------------
 294 # The builtins are renamed, e.g., `define' is renamed `m4_define'.
 295 # So map `define' to `m4_define' and conversely.
 296 # Some macros don't follow this scheme: be sure to properly map to their
 297 # alternate name too.
 298 #
 299 # This is because GNU M4 1.4's tracing of builtins is buggy.  When run on
 300 # this input:
 301 #
 302 # | divert(-1)
 303 # | changequote([, ])
 304 # | define([m4_eval], defn([eval]))
 305 # | eval(1)
 306 # | m4_eval(2)
 307 # | undefine([eval])
 308 # | m4_eval(3)
 309 #
 310 # it behaves this way:
 311 #
 312 # | % m4 input.m4 -da -t eval
 313 # | m4trace: -1- eval(1)
 314 # | m4trace: -1- m4_eval(2)
 315 # | m4trace: -1- m4_eval(3)
 316 # | %
 317 #
 318 # Conversely:
 319 #
 320 # | % m4 input.m4 -da -t m4_eval
 321 # | %
 322 #
 323 # So we will merge them, i.e.  tracing `BUILTIN' or tracing
 324 # `m4_BUILTIN' will be the same: tracing both, but honoring the
 325 # *last* trace specification.
 326 #
 327 # FIXME: This is not enough: in the output `$0' will be `BUILTIN'
 328 # sometimes and `m4_BUILTIN' at others.  We should return a unique name,
 329 # the one specified by the user.
 330 #
 331 # FIXME: To be absolutely rigorous, I would say that given that we
 332 # _redefine_ divert (instead of _copying_ it), divert and the like
 333 # should not be part of this list.
 334 my %m4_builtin_alternate_name;
 335 @m4_builtin_alternate_name{"$_", "m4_$_"} = ("m4_$_", "$_")
 336   foreach (grep { !/m4wrap|m4exit|dnl|ifelse|__.*__/ } @m4_builtin);
 337 @m4_builtin_alternate_name{"ifelse", "m4_if"}   = ("m4_if", "ifelse");
 338 @m4_builtin_alternate_name{"m4exit", "m4_exit"} = ("m4_exit", "m4exit");
 339 @m4_builtin_alternate_name{"m4wrap", "m4_wrap"} = ("m4_wrap", "m4wrap");
 340
 341
 342 # $HELP
 343 # -----
 344 $help = << "EOF";
 345 Usage: $0 [OPTION] ... [FILES]
 346
 347 Run GNU M4 on the FILES, avoiding useless runs.  If tracing, the output
 348 consists of the traces only, otherwise output the expansion of the FILES.
 349 The first of the FILES may be an M4 frozen file, but then must end in \`.m4f\'.
 350 Some files may be optional, i.e., will only be processed if found in the
 351 include path, but then must end in \`.m4?\';  the question mark is not part of
 352 the actual file name.
 353
 354 Operation modes:
 355   -h, --help               print this help, then exit
 356   -V, --version            print version number, then exit
 357   -v, --verbose            verbosely report processing
 358   -d, --debug              don\'t remove temporary files
 359   -o, --output=FILE        save output in FILE (defaults to \`-\', stdout)
 360   -f, --force              don\'t rely on cached values
 361   -W, --warnings=CATEGORY  report the warnings falling in CATEGORY
 362   -l, --language=LANG      specify the set of M4 macros to use
 363   -m, --mode=OCTAL         change the non trace output file mode (0666)
 364   -M, --melt               don\'t use M4 frozen files
 365
 366 Languages include:
 367   \`Autoconf\'   create Autoconf configure scripts
 368   \`Autotest\'   create Autotest test suites
 369   \`M4sh\'       create M4sh shell scripts
 370   \`M4sugar\'    create M4sugar output
 371
 372 Warning categories include:
 373   \`cross\'         cross compilation issues
 374   \`obsolete\'      obsolete constructs
 375   \`syntax\'        dubious syntactic constructs
 376   \`all\'           all the warnings
 377   \`no-CATEGORY\'   turn off the warnings on CATEGORY
 378   \`none\'          turn off all the warnings
 379   \`error\'         warnings are error
 380
 381 The environment variable \`WARNINGS\' is honored.
 382
 383 Library directories:
 384   -I, --include=DIR  look for FILES in DIR (cumulative)
 385
 386 Tracing:
 387   -t, --trace=MACRO      report the MACRO invocations
 388   -p, --preselect=MACRO  prepare to trace MACRO in a future run
 389
 390 Report bugs to <bug-autoconf\@gnu.org>.
 391 EOF
 392
 393 # $VERSION
 394 # --------
 395 $version =  <<"EOF";
 396 autom4te (@PACKAGE_NAME@) @VERSION@
 397 Written by Akim Demaille.
 398
 399 Copyright 2001 Free Software Foundation, Inc.
 400 This is free software; see the source for copying conditions.  There is NO
 401 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 402 EOF
 403
 404
 405 ## ---------- ##
 406 ## Routines.  ##
 407 ## ---------- ##
 408
 409
 410 # load_configuration ()
 411 # ---------------------
 412 # Load the configuration file.
 413 sub load_configuration ()
 414 {
 415   use Text::ParseWords;
 416
 417   my $cfg = new Autom4te::XFile ($autom4te_cfg);
 418   my $lang;
 419   while ($_ = $cfg->getline)
 420     {
 421       chomp;
 422       # Comments.
 423       next
 424         if /^\s*(\#.*)?$/;
 425
 426       my @words = shellwords ($_);
 427       my $type = shift @words;
 428       if ($type eq 'begin-language:')
 429         {
 430           $lang = lc $words[0];
 431         }
 432       elsif ($type eq 'end-language:')
 433         {
 434           die "$me: $autom4te_cfg:$.: end-language mismatch: $lang\n"
 435             if $lang ne lc $words[0];
 436         }
 437       elsif ($type eq 'args:')
 438         {
 439           push @{$language{$lang}}, @words;
 440         }
 441       else
 442         {
 443           die "$me: $autom4te_cfg:$.: unknown directive: $type\n";
 444         }
 445     }
 446 }
 447
 448
 449 # parse_args ()
 450 # -------------
 451 # Process any command line arguments.
 452 sub parse_args ()
 453 {
 454   # We want to look for the early options, which should not be found
 455   # in the configuration file.  Prepend to the user arguments.
 456   # Perform this repeatedly so that we can use --language in language
 457   # definitions.  Beware that there can be several --language
 458   # invocations.
 459   my @language;
 460   do {
 461     @language = ();
 462     Getopt::Long::Configure ("pass_through");
 463     getopt ("l|language=s" => \@language);
 464
 465     foreach (@language)
 466       {
 467         die "$me: unknown language: $_\n"
 468           unless exists $language{lc $_};
 469         unshift @ARGV, @{$language{lc $_}};
 470       }
 471   } while @language;
 472
 473   debug "arguments: @ARGV\n";
 474
 475   # Process the arguments for real this time.
 476   my @trace;
 477   Getopt::Long::Configure ("defaults");
 478   getopt
 479     (
 480      # Operation modes:
 481      "o|output=s"   => \$output,
 482      "W|warnings=s" => \@warning,
 483      "m|mode=s"     => \$mode,
 484      "M|melt"       => \$melt,
 485
 486      # Library directories:
 487      "I|include=s" => \@include,
 488
 489      # Tracing:
 490      # Using a hash for traces is seducing.  Unfortunately, upon `-t FOO',
 491      # instead of mapping `FOO' to undef, Getopt maps it to `1', preventing
 492      # us from distinguishing `-t FOO' from `-t FOO=1'.  So let's do it
 493      # by hand.
 494      "t|trace=s"     => \@trace,
 495      "p|preselect=s" => \@preselect,
 496     );
 497
 498   die "$me: too few arguments
 499 Try `$me --help' for more information.\n"
 500     unless @ARGV;
 501
 502   # Normalize the includes: the first occurrence is enough, several is
 503   # a pain since it introduces a useless difference in the path which
 504   # invalidates the cache.  And strip `.' which is implicit and always
 505   # first.
 506   @include = grep { !/^\.$/ } uniq (@include);
 507
 508   # Convert @trace to %trace, and work around the M4 builtins tracing
 509   # problem.
 510   # The default format is `$f:$l:$n:$%'.
 511   foreach (@trace)
 512     {
 513       /^([^:]+)(?::(.*))?$/ms;
 514       $trace{$1} = defined $2 ? $2 : '$f:$l:$n:$%';
 515       $trace{$m4_builtin_alternate_name{$1}} = $trace{$1}
 516         if exists $m4_builtin_alternate_name{$1};
 517     }
 518
 519   # Work around the M4 builtins tracing problem for @PRESELECT.
 520   push (@preselect,
 521         map { $m4_builtin_alternate_name{$_} }
 522         grep { exists $m4_builtin_alternate_name{$_} } @preselect);
 523
 524   # Only the first file can be frozen, but M4 doesn't complain if this
 525   # constraint is not honored.
 526   die "$me: the first file only can be frozen\n"
 527     if grep { /\.m4f/ } @ARGV[1 .. $#ARGV];
 528
 529   $ARGV[0] =~ s/\.m4f$/.m4/
 530     if $melt;
 531
 532   # We don't want to depend upon m4's --include to find the top level
 533   # files.  Try to get a canonical name, as it's part of the key for
 534   # caching.  And some files are optional.
 535   @ARGV = grep { defined $_ } map { find_file ($_, @include) } @ARGV;
 536 }
 537
 538
 539 # handle_m4 ($REQ, @MACRO)
 540 # ------------------------
 541 # Run m4 on the input files, and save the traces on the @MACRO.
 542 sub handle_m4 ($@)
 543 {
 544   my ($req, @macro) = @_;
 545
 546   my $files;
 547   foreach (@ARGV)
 548     {
 549       $files .= ' ';
 550       $files .= '--reload-state='
 551         if /\.m4f$/;
 552       $files .= "$_";
 553     }
 554
 555   # The warnings are the concatenation of 1. application's defaults,
 556   # 2. $WARNINGS, $3 command line options, in that order.
 557   # Set them in the order expected by the M4 macros: the converse.
 558   my $m4_warnings =
 559     lc join (',', reverse (split (',', ($ENV{'WARNINGS'} || '')),
 560                            map { split /,/ } @warning));
 561
 562   # GNU m4 appends when using --error-output.
 563   unlink ($tcache . $req->id);
 564
 565   # Run m4.
 566   #
 567   # Neutralize its stdin, so that GNU M4 1.5 doesn't neutralize SIGINT.
 568   #
 569   # Be extremely cautious to reverse the includes when talking to M4:
 570   # it doesn't speak the same --include as we do.
 571   my $command = ("$m4"
 572                  . join (' --include=', '', reverse @include)
 573                  . " --define=m4_warnings=$m4_warnings"
 574                  . ' --debug=aflq'
 575                  . " --error-output=$tcache" . $req->id
 576                  . join (' --trace=',   '', sort @macro)
 577                  . $files
 578                  . ' </dev/null'
 579                  . " >$ocache" . $req->id);
 580   verbose "running: $command";
 581   system $command;
 582   if ($?)
 583     {
 584       verbose "$m4: failed with exit status: " . ($? >> 8) . "\n";
 585       exit $? >> 8;
 586     }
 587 }
 588
 589
 590 # warn_forbidden ($WHERE, $WORD, %FORBIDDEN)
 591 # ------------------------------------------
 592 # $WORD is forbidden.  Warn with a dedicated error message if in
 593 # %FORBIDDEN, otherwise, a simple `error: possibly undefined macro'
 594 # will do.
 595 sub warn_forbidden ($$%)
 596 {
 597   my ($where, $word, %forbidden) = @_;
 598   my $message;
 599
 600   for my $re (sort keys %forbidden)
 601     {
 602       if ($word =~ $re)
 603         {
 604           $message = $forbidden{$re};
 605           last;
 606         }
 607     }
 608   $message ||= "possibly undefined macro: $word";
 609   warn "$where: error: $message\n";
 610 }
 611
 612
 613 # handle_output ($REQ, $OUTPUT)
 614 # -----------------------------
 615 # Run m4 on the input files, perform quadrigraphs substitution, check for
 616 # forbidden tokens, and save into $OUTPUT.
 617 sub handle_output ($$)
 618 {
 619   my ($req, $output) = @_;
 620
 621   verbose "creating $output";
 622
 623   # Load the forbidden/allowed patterns.
 624   handle_traces ($req, "$tmp/patterns",
 625                  ('m4_pattern_forbid' => 'forbid:$1:$2',
 626                   'm4_pattern_allow'  => 'allow:$1'));
 627   my @patterns = new Autom4te::XFile ("$tmp/patterns")->getlines;
 628   chomp @patterns;
 629   my %forbidden =
 630     map { /^forbid:([^:]+):.+$/ => /^forbid:[^:]+:(.+)$/ } @patterns;
 631   my $forbidden = join ('|', map { /^forbid:([^:]+)/ } @patterns) || "^\$";
 632   my $allowed   = join ('|', map { /^allow:([^:]+)/  } @patterns) || "^\$";
 633
 634   verbose "forbidden tokens: $forbidden";
 635   verbose "forbidden token : $_ => $forbidden{$_}"
 636     foreach (sort keys %forbidden);
 637   verbose "allowed   tokens: $allowed";
 638
 639   # Read the (cached) raw M4 output, produce the actual result.  We
 640   # have to use the 2nd arg to have Autom4te::XFile honor the third, but then
 641   # stdout is to be handled by hand :(.  Don't use fdopen as it means
 642   # we will close STDOUT, which we already do in END.
 643   my $out = new Autom4te::XFile;
 644   if ($output eq '-')
 645     {
 646       $out->open (">$output");
 647     }
 648   else
 649     {
 650       $out->open($output, O_CREAT | O_WRONLY | O_TRUNC, oct ($mode));
 651     }
 652   die "$me: cannot create $output: $!\n"
 653     unless $out;
 654   my $in = new Autom4te::XFile ($ocache . $req->id);
 655
 656   my %prohibited;
 657   my $res;
 658   while ($_ = $in->getline)
 659     {
 660       s/\s+$//;
 661       s/__oline__/$./g;
 662       s/\@<:\@/[/g;
 663       s/\@:>\@/]/g;
 664       s/\@S\|\@/\$/g;
 665       s/\@%:\@/#/g;
 666
 667       $res = $_;
 668
 669       # Don't complain in comments.  Well, until we have something
 670       # better, don't consider `#include' etc. are comments.
 671       s/\#.*//
 672         unless /^\#\s*(if|include|endif|ifdef|ifndef|define)\b/;
 673       foreach (split (/\W+/))
 674         {
 675           $prohibited{$_} = $.
 676             if /$forbidden/o && !/$allowed/o && ! exists $prohibited{$_};
 677         }
 678
 679       # Performed *last*: the empty quadrigraph.
 680       $res =~ s/\@&t\@//g;
 681
 682       print $out "$res\n";
 683     }
 684
 685   # If no forbidden words, we're done.
 686   return
 687     if ! %prohibited;
 688
 689   # Locate the forbidden words in the last input file.
 690   # This is unsatisfying but...
 691   my $prohibited = '\b(' . join ('|', keys %prohibited) . ')\b';
 692   my $file = new Autom4te::XFile ($ARGV[$#ARGV]);
 693   $exit_status = 1;
 694
 695   while ($_ = $file->getline)
 696     {
 697       # Don't complain in comments.  Well, until we have something
 698       # better, don't consider `#include' etc. are comments.
 699       s/\#.*//
 700         unless /^\#(if|include|endif|ifdef|ifndef|define)\b/;
 701
 702       # Complain once per word, but possibly several times per line.
 703       while (/$prohibited/)
 704         {
 705           my $word = $1;
 706           warn_forbidden ("$ARGV[$#ARGV]:$.", $word, %forbidden);
 707           delete $prohibited{$word};
 708           # If we're done, exit.
 709           return
 710             if ! %prohibited;
 711           $prohibited = '\b(' . join ('|', keys %prohibited) . ')\b';
 712         }
 713     }
 714   warn_forbidden ("$output:$prohibited{$_}", $_, %forbidden)
 715     foreach (sort { $prohibited{$a} <=> $prohibited{$b} } keys %prohibited);
 716 }
 717
 718
 719 ## --------------------- ##
 720 ## Handling the traces.  ##
 721 ## --------------------- ##
 722
 723
 724 # $M4_MACRO
 725 # trace_format_to_m4 ($FORMAT)
 726 # ----------------------------
 727 # Convert a trace $FORMAT into a M4 trace processing macro's body.
 728 sub trace_format_to_m4 ($)
 729 {
 730   my ($format) = @_;
 731   my $underscore = $_;
 732   my %escape = (# File name.
 733                 'f' => '$1',
 734                 # Line number.
 735                 'l' => '$2',
 736                 # Depth.
 737                 'd' => '$3',
 738                 # Name (also available as $0).
 739                 'n' => '$4',
 740                 # Escaped dollar.
 741                 '$' => '$');
 742
 743   my $res = '';
 744   $_ = $format;
 745   while ($_)
 746     {
 747       # $n -> $(n + 4)
 748       if (s/^\$(\d+)//)
 749         {
 750           $res .= "\$" . ($1 + 4);
 751         }
 752       # $x, no separator given.
 753       elsif (s/^\$([fldn\$])//)
 754         {
 755           $res .= $escape{$1};
 756         }
 757       # $.x or ${sep}x.
 758       elsif (s/^\$\{([^}]*)\}([@*%])//
 759             || s/^\$(.?)([@*%])//)
 760         {
 761           # $@, list of quoted effective arguments.
 762           if ($2 eq '@')
 763             {
 764               $res .= ']at_at([' . ($1 ? $1 : ',') . '], $@)[';
 765             }
 766           # $*, list of unquoted effective arguments.
 767           elsif ($2 eq '*')
 768             {
 769               $res .= ']at_star([' . ($1 ? $1 : ',') . '], $@)[';
 770             }
 771           # $%, list of flattened unquoted effective arguments.
 772           elsif ($2 eq '%')
 773             {
 774               $res .= ']at_percent([' . ($1 ? $1 : ':') . '], $@)[';
 775             }
 776         }
 777       elsif (/^(\$.)/)
 778         {
 779           die "$me: invalid escape: $1\n";
 780         }
 781       else
 782         {
 783           s/^([^\$]+)//;
 784           $res .= $1;
 785         }
 786     }
 787
 788   $_ = $underscore;
 789   return '[[' . $res . ']]';
 790 }
 791
 792
 793 # handle_traces($REQ, $OUTPUT, %TRACE)
 794 # ------------------------------------
 795 # We use M4 itself to process the traces.  But to avoid name clashes when
 796 # processing the traces, the builtins are disabled, and moved into `at_'.
 797 # Actually, all the low level processing macros are in `at_' (and `_at_').
 798 # To avoid clashes between user macros and `at_' macros, the macros which
 799 # implement tracing are in `AT_'.
 800 #
 801 # Having $REQ is needed to neutralize the macros which have been traced,
 802 # but are not wanted now.
 803 sub handle_traces ($$%)
 804 {
 805   my ($req, $output, %trace) = @_;
 806
 807   verbose "formatting traces for `$output': ", join (', ', sort keys %trace);
 808
 809   # Processing the traces.
 810   my $trace_m4 = new Autom4te::XFile (">$tmp/traces.m4");
 811
 812   $_ = <<'EOF';
 813   divert(-1)
 814   changequote([, ])
 815   # _at_MODE(SEPARATOR, ELT1, ELT2...)
 816   # ----------------------------------
 817   # List the elements, separating then with SEPARATOR.
 818   # MODE can be:
 819   #  `at'       -- the elements are enclosed in brackets.
 820   #  `star'     -- the elements are listed as are.
 821   #  `percent'  -- the elements are `flattened': spaces are singled out,
 822   #                and no new line remains.
 823   define([_at_at],
 824   [at_ifelse([$#], [1], [],
 825              [$#], [2], [[[$2]]],
 826              [[[$2]][$1]$0([$1], at_shift(at_shift($@)))])])
 827
 828   define([_at_percent],
 829   [at_ifelse([$#], [1], [],
 830              [$#], [2], [at_flatten([$2])],
 831              [at_flatten([$2])[$1]$0([$1], at_shift(at_shift($@)))])])
 832
 833   define([_at_star],
 834   [at_ifelse([$#], [1], [],
 835              [$#], [2], [[$2]],
 836              [[$2][$1]$0([$1], at_shift(at_shift($@)))])])
 837
 838   # FLATTEN quotes its result.
 839   # Note that the second pattern is `newline, tab or space'.  Don't lose
 840   # the tab!
 841   define([at_flatten],
 842   [at_patsubst(at_patsubst(at_patsubst([[[$1]]], [\\\n]),
 843                            [[\n\t ]+], [ ]),
 844                [^ *\(.*\) *$], [[\1]])])
 845
 846   define([at_args],    [at_shift(at_shift(at_shift(at_shift(at_shift($@)))))])
 847   define([at_at],      [_$0([$1], at_args($@))])
 848   define([at_percent], [_$0([$1], at_args($@))])
 849   define([at_star],    [_$0([$1], at_args($@))])
 850
 851 EOF
 852   s/^  //mg;s/\\t/\t/mg;s/\\n/\n/mg;
 853   print $trace_m4 $_;
 854
 855   # If you trace `define', then on `define([m4_exit], defn([m4exit])' you
 856   # will produce
 857   #
 858   #    AT_define([m4sugar.m4], [115], [1], [define], [m4_exit], <m4exit>)
 859   #
 860   # Since `<m4exit>' is not quoted, the outer m4, when processing
 861   # `trace.m4' will exit prematurely.  Hence, move all the builtins to
 862   # the `at_' name space.
 863
 864   print $trace_m4 "# Copy the builtins.\n";
 865   map { print $trace_m4 "define([at_$_], defn([$_]))\n" } @m4_builtin;
 866   print $trace_m4 "\n";
 867
 868   print $trace_m4 "# Disable them.\n";
 869   map { print $trace_m4 "at_undefine([$_])\n" } @m4_builtin;
 870   print $trace_m4 "\n";
 871
 872
 873   # Neutralize traces: we don't want traces of cached requests (%REQUEST).
 874   print $trace_m4
 875    "## -------------------------------------- ##\n",
 876    "## By default neutralize all the traces.  ##\n",
 877    "## -------------------------------------- ##\n",
 878    "\n";
 879   print $trace_m4 "at_define([AT_$_], [at_dnl])\n"
 880     foreach (sort keys %{$req->macro});
 881   print $trace_m4 "\n";
 882
 883   # Implement traces for current requests (%TRACE).
 884   print $trace_m4
 885     "## ------------------------- ##\n",
 886     "## Trace processing macros.  ##\n",
 887     "## ------------------------- ##\n",
 888     "\n";
 889   foreach (sort keys %trace)
 890     {
 891       # Trace request can be embed \n.
 892       (my $comment = "Trace $_:$trace{$_}") =~ s/^/\# /;
 893       print $trace_m4 "$comment\n";
 894       print $trace_m4 "at_define([AT_$_],\n";
 895       print $trace_m4 trace_format_to_m4 ($trace{$_}) . ")\n\n";
 896     }
 897   print $trace_m4 "\n";
 898
 899   # Reenable output.
 900   print $trace_m4 "at_divert(0)at_dnl\n";
 901
 902   # Transform the traces from m4 into an m4 input file.
 903   # Typically, transform:
 904   #
 905   # | m4trace:configure.ac:3: -1- AC_SUBST([exec_prefix], [NONE])
 906   #
 907   # into
 908   #
 909   # | AT_AC_SUBST([configure.ac], [3], [1], [AC_SUBST], [exec_prefix], [NONE])
 910   #
 911   # Pay attention that the file name might include colons, if under DOS
 912   # for instance, so we don't use `[^:]+'.
 913   my $traces = new Autom4te::XFile ($tcache . $req->id);
 914   while ($_ = $traces->getline)
 915     {
 916       # Trace with arguments, as the example above.  We don't try
 917       # to match the trailing parenthesis as it might be on a
 918       # separate line.
 919       s{^m4trace:(.+):(\d+): -(\d+)- ([^(]+)\((.*)$}
 920        {AT_$4([$1], [$2], [$3], [$4], $5};
 921       # Traces without arguments, always on a single line.
 922       s{^m4trace:(.+):(\d+): -(\d+)- ([^)]*)\n$}
 923        {AT_$4([$1], [$2], [$3], [$4])\n};
 924       print $trace_m4 "$_";
 925     }
 926   $trace_m4->close;
 927
 928   my $in = new Autom4te::XFile ("$m4 $tmp/traces.m4 |");
 929   my $out = new Autom4te::XFile (">$output");
 930
 931   # FIXME: Hm... This is dubious: should we really transform the
 932   # quadrigraphs in traces?  It might break balanced [ ] etc. in the
 933   # output.
 934   while ($_ = $in->getline)
 935     {
 936       # It makes no sense to try to transform __oline__.
 937       s/\@<:\@/[/g;
 938       s/\@:>\@/]/g;
 939       s/\@\$\|\@/\$/g;
 940       s/\@%:\@/#/g;
 941       print $out $_;
 942     }
 943 }
 944
 945
 946 # $BOOL
 947 # up_to_date ($REQ)
 948 # -----------------
 949 # Are the cache files of $REQ up to date?
 950 # $REQ is `valid' if it corresponds to the request and exists, which
 951 # does not mean it is up to date.  It is up to date if, in addition,
 952 # its files are younger than its dependencies.
 953 sub up_to_date ($)
 954 {
 955   my ($req) = @_;
 956
 957   return 0
 958     if ! $req->valid;
 959
 960   my $tfile = $tcache . $req->id;
 961   my $ofile = $ocache . $req->id;
 962
 963   # We can't answer properly if the traces are not computed since we
 964   # need to know what other files were included.  Actually, if any of
 965   # the cache files is missing, we are not up to date.
 966   return 0
 967     if ! -f $tfile || ! -f $ofile;
 968
 969   # The youngest of the cache files must be older than the oldest of
 970   # the dependencies.
 971   my $tmtime = mtime ($tfile);
 972   my $omtime = mtime ($ofile);
 973   my ($file, $mtime) = ($tmtime < $omtime
 974                         ? ($ofile, $omtime) : ($tfile, $tmtime));
 975
 976   # We depend at least upon the arguments.
 977   my @dep = @ARGV;
 978
 979   # Files may include others.  We can use traces since we just checked
 980   # if they are available.
 981   handle_traces ($req, "$tmp/dependencies",
 982                  ('include'    => '$1',
 983                   'm4_include' => '$1'));
 984   my $deps = new Autom4te::XFile ("$tmp/dependencies");
 985   push @dep, map { chomp; find_file ($_, @include) } $deps->getlines;
 986
 987   # If $FILE is younger than one of its dependencies, it is outdated.
 988   return up_to_date_p ($file, @dep);
 989 }
 990
 991
 992 ## -------------- ##
 993 ## Main program.  ##
 994 ## -------------- ##
 995
 996 mktmpdir ('t4');
 997 load_configuration;
 998 parse_args;
 999
1000 # We need our cache directory.
1001 if (! -d "$cache")
1002   {
1003     mkdir "$cache", 0755
1004       or die "$me: cannot create $cache: $!\n";
1005   }
1006
1007 # Read the cache index if available and older than autom4te itself.
1008 # If autom4te is younger, then some structures such as Request, might
1009 # have changed, which would corrupt its processing.
1010 Request->load ($icache)
1011   if -f $icache && mtime ($icache) > mtime ($0);
1012
1013 # Add the new trace requests.
1014 my $req = Request->request ('input' => \@ARGV,
1015                             'path'  => \@include,
1016                             'macro' => [keys %trace, @preselect]);
1017
1018 # If $REQ's cache files are not up to date, declare it invalid.
1019 $req->valid (0)
1020   if ! up_to_date ($req);
1021
1022 # We now know whether we can trust the Request object.  Say it.
1023 if ($verbose)
1024   {
1025     print STDERR "$me: the trace request object is:\n";
1026     print STDERR $req->marshall;
1027   }
1028
1029 # We need to run M4 if (i) the users wants it (--force), (ii) $REQ is
1030 # invalid.
1031 handle_m4 ($req, keys %{$req->macro})
1032   if $force || ! $req->valid;
1033
1034 # Now output...
1035 if (%trace)
1036   {
1037     # Always produce traces, since even if the output is young enough,
1038     # there is no guarantee that the traces use the same *format*
1039     # (e.g., `-t FOO:foo' and `-t FOO:bar' are both using the same M4
1040     # traces, hence the M4 traces cache is usable, but its formating
1041     # will yield different results).
1042     handle_traces ($req, $output, %trace);
1043   }
1044 else
1045   {
1046     # Actual M4 expansion, only if $output is too old. STDOUT is
1047     # pretty old.
1048     handle_output ($req, $output)
1049       if mtime ($output) < mtime ($ocache . $req->id);
1050   }
1051
1052 # If all went fine, the cache is valid.
1053 $req->valid (1)
1054   if $exit_status == 0;
1055
1056 Request->save ($icache);
1057
1058 exit $exit_status;