share/autoconf/Autom4te/Channels.pm

   1 # Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
   2
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2, or (at your option)
   6 # any later version.
   7
   8 # This program is distributed in the hope that it will be useful,
   9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 # GNU General Public License for more details.
  12
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program; if not, write to the Free Software
  15 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16 # 02110-1301, USA.
  17
  18 ###############################################################
  19 # The main copy of this file is in Automake's CVS repository. #
  20 # Updates should be sent to automake-patches@gnu.org.         #
  21 ###############################################################
  22
  23 package Autom4te::Channels;
  24
  25 =head1 NAME
  26
  27 Autom4te::Channels - support functions for error and warning management
  28
  29 =head1 SYNOPSIS
  30
  31   use Autom4te::Channels;
  32
  33   # Register a channel to output warnings about unused variables.
  34   register_channel 'unused', type => 'warning';
  35
  36   # Register a channel for system errors.
  37   register_channel 'system', type => 'error', exit_code => 4;
  38
  39   # Output a message on channel 'unused'.
  40   msg 'unused', "$file:$line", "unused variable `$var'";
  41
  42   # Make the 'unused' channel silent.
  43   setup_channel 'unused', silent => 1;
  44
  45   # Turn on all channels of type 'warning'.
  46   setup_channel_type 'warning', silent => 0;
  47
  48   # Treat all warnings as errors.
  49   $warnings_are_errors = 1;
  50
  51   # Exit with the greatest exit code encountered so far.
  52   exit $exit_code;
  53
  54 =head1 DESCRIPTION
  55
  56 This perl module provides support functions for handling diagnostic
  57 channels in programs.  Channels can be registered to convey fatal,
  58 error, warning, or debug messages.  Each channel has various options
  59 (e.g. is the channel silent, should duplicate messages be removed,
  60 etc.) that can also be overridden on a per-message basis.
  61
  62 =cut
  63
  64 use 5.005;
  65 use strict;
  66 use Exporter;
  67 use Carp;
  68 use File::Basename;
  69
  70 use vars qw (@ISA @EXPORT %channels $me);
  71
  72 @ISA = qw (Exporter);
  73 @EXPORT = qw ($exit_code $warnings_are_errors
  74               &reset_local_duplicates &reset_global_duplicates
  75               &register_channel &msg &exists_channel &channel_type
  76               &setup_channel &setup_channel_type
  77               &dup_channel_setup &drop_channel_setup
  78               &buffer_messages &flush_messages
  79               US_GLOBAL US_LOCAL
  80               UP_NONE UP_TEXT UP_LOC_TEXT);
  81
  82 $me = basename $0;
  83
  84 =head2 Global Variables
  85
  86 =over 4
  87
  88 =item C<$exit_code>
  89
  90 The greatest exit code seen so far. C<$exit_code> is updated from
  91 the C<exit_code> options of C<fatal> and C<error> channels.
  92
  93 =cut
  94
  95 use vars qw ($exit_code);
  96 $exit_code = 0;
  97
  98 =item C<$warnings_are_errors>
  99
 100 Set this variable to 1 if warning messages should be treated as
 101 errors (i.e. if they should update C<$exit_code>).
 102
 103 =cut
 104
 105 use vars qw ($warnings_are_errors);
 106 $warnings_are_errors = 0;
 107
 108 =back
 109
 110 =head2 Constants
 111
 112 =over 4
 113
 114 =item C<UP_NONE>, C<UP_TEXT>, C<UP_LOC_TEXT>
 115
 116 Possible values for the C<uniq_part> options.  This selects the part
 117 of the message that should be considered when filtering out duplicates.
 118 If C<UP_LOC_TEXT> is used, the location and the explanation message
 119 are used for filtering.  If C<UP_TEXT> is used, only the explanation
 120 message is used (so the same message will be filtered out if it appears
 121 at different locations).  C<UP_NONE> means that duplicate messages
 122 should be output.
 123
 124 =cut
 125
 126 use constant UP_NONE => 0;
 127 use constant UP_TEXT => 1;
 128 use constant UP_LOC_TEXT => 2;
 129
 130 =item C<US_LOCAL>, C<US_GLOBAL>
 131
 132 Possible values for the C<uniq_scope> options.
 133 Use C<US_GLOBAL> for error messages that should be printed only
 134 once during the execution of the program, C<US_LOCAL> for message that
 135 should be printed only once per file.  (Actually, C<Channels> does not
 136 do this now when files are changed, it relies on you calling
 137 C<reset_local_duplicates> when this happens.)
 138
 139 =cut
 140
 141 # possible values for uniq_scope
 142 use constant US_LOCAL => 0;
 143 use constant US_GLOBAL => 1;
 144
 145 =back
 146
 147 =head2 Options
 148
 149 Channels accept the options described below.  These options can be
 150 passed as a hash to the C<register_channel>, C<setup_channel>, and C<msg>
 151 functions.  The possible keys, with their default value are:
 152
 153 =over
 154
 155 =item C<type =E<gt> 'warning'>
 156
 157 The type of the channel.  One of C<'debug'>, C<'warning'>, C<'error'>, or
 158 C<'fatal'>.  Fatal messages abort the program when they are output.
 159 Error messages update the exit status.  Debug and warning messages are
 160 harmless, except that warnings can be treated as errors of
 161 C<$warnings_are_errors> is set.
 162
 163 =item C<exit_code =E<gt> 1>
 164
 165 The value to update C<$exit_code> with when a fatal or error message
 166 is emitted.  C<$exit_code> is also updated for warnings output
 167 when @<$warnings_are_errors> is set.
 168
 169 =item C<file =E<gt> \*STDERR>
 170
 171 The file where the error should be output.
 172
 173 =item C<silent =E<gt> 0>
 174
 175 Whether the channel should be silent.  Use this do disable a
 176 category of warning, for instance.
 177
 178 =item C<uniq_part =E<gt> UP_LOC_TEXT>
 179
 180 The part of the message subject to duplicate filtering.  See the
 181 documentation for the C<UP_NONE>, C<UP_TEXT>, and C<UP_LOC_TEXT>
 182 constants above.
 183
 184 C<uniq_part> can also be set to an arbitrary string that will be used
 185 instead of the message when considering duplicates.
 186
 187 =item C<uniq_scope =E<gt> US_LOCAL>
 188
 189 The scope of duplicate filtering.  See the documentation for the
 190 C<US_LOCAL>, and C<US_GLOBAL> constants above.
 191
 192 =item C<header =E<gt> ''>
 193
 194 A string to prepend to each message emitted through this channel.
 195
 196 =item C<footer =E<gt> ''>
 197
 198 A string to append to each message emitted through this channel.
 199
 200 =item C<backtrace =E<gt> 0>
 201
 202 Die with a stack backtrace after displaying the message.
 203
 204 =item C<partial =E<gt> 0>
 205
 206 When set, indicates a partial message that should
 207 be output along with the next message with C<partial> unset.
 208 Several partial messages can be stacked this way.
 209
 210 Duplicate filtering will apply to the I<global> message resulting from
 211 all I<partial> messages, using the options from the last (non-partial)
 212 message.  Linking associated messages is the main reason to use this
 213 option.
 214
 215 For instance the following messages
 216
 217   msg 'channel', 'foo:2', 'redefinition of A ...';
 218   msg 'channel', 'foo:1', '... A previously defined here';
 219   msg 'channel', 'foo:3', 'redefinition of A ...';
 220   msg 'channel', 'foo:1', '... A previously defined here';
 221
 222 will result in
 223
 224  foo:2: redefinition of A ...
 225  foo:1: ... A previously defined here
 226  foo:3: redefinition of A ...
 227
 228 where the duplicate "I<... A previously defined here>" has been
 229 filtered out.
 230
 231 Linking these messages using C<partial> as follows will prevent the
 232 fourth message to disappear.
 233
 234   msg 'channel', 'foo:2', 'redefinition of A ...', partial => 1;
 235   msg 'channel', 'foo:1', '... A previously defined here';
 236   msg 'channel', 'foo:3', 'redefinition of A ...', partial => 1;
 237   msg 'channel', 'foo:1', '... A previously defined here';
 238
 239 Note that because the stack of C<partial> messages is printed with the
 240 first non-C<partial> message, most options of C<partial> messages will
 241 be ignored.
 242
 243 =back
 244
 245 =cut
 246
 247 use vars qw (%_default_options %_global_duplicate_messages
 248              %_local_duplicate_messages);
 249
 250 # Default options for a channel.
 251 %_default_options =
 252   (
 253    type => 'warning',
 254    exit_code => 1,
 255    file => \*STDERR,
 256    silent => 0,
 257    uniq_scope => US_LOCAL,
 258    uniq_part => UP_LOC_TEXT,
 259    header => '',
 260    footer => '',
 261    backtrace => 0,
 262    partial => 0,
 263    );
 264
 265 # Filled with output messages as keys, to detect duplicates.
 266 # The value associated with each key is the number of occurrences
 267 # filtered out.
 268 %_local_duplicate_messages = ();
 269 %_global_duplicate_messages = ();
 270
 271 sub _reset_duplicates (\%)
 272 {
 273   my ($ref) = @_;
 274   my $dup = 0;
 275   foreach my $k (keys %$ref)
 276     {
 277       $dup += $ref->{$k};
 278     }
 279   %$ref = ();
 280   return $dup;
 281 }
 282
 283
 284 =head2 Functions
 285
 286 =over 4
 287
 288 =item C<reset_local_duplicates ()>
 289
 290 Reset local duplicate messages (see C<US_LOCAL>), and
 291 return the number of messages that have been filtered out.
 292
 293 =cut
 294
 295 sub reset_local_duplicates ()
 296 {
 297   return _reset_duplicates %_local_duplicate_messages;
 298 }
 299
 300 =item C<reset_global_duplicates ()>
 301
 302 Reset local duplicate messages (see C<US_GLOBAL>), and
 303 return the number of messages that have been filtered out.
 304
 305 =cut
 306
 307 sub reset_global_duplicates ()
 308 {
 309   return _reset_duplicates %_global_duplicate_messages;
 310 }
 311
 312 sub _merge_options (\%%)
 313 {
 314   my ($hash, %options) = @_;
 315   local $_;
 316
 317   foreach (keys %options)
 318     {
 319       if (exists $hash->{$_})
 320         {
 321           $hash->{$_} = $options{$_}
 322         }
 323       else
 324         {
 325           confess "unknown option `$_'";
 326         }
 327     }
 328 }
 329
 330 =item C<register_channel ($name, [%options])>
 331
 332 Declare channel C<$name>, and override the default options
 333 with those listed in C<%options>.
 334
 335 =cut
 336
 337 sub register_channel ($;%)
 338 {
 339   my ($name, %options) = @_;
 340   my %channel_opts = %_default_options;
 341   _merge_options %channel_opts, %options;
 342   $channels{$name} = \%channel_opts;
 343 }
 344
 345 =item C<exists_channel ($name)>
 346
 347 Returns true iff channel C<$name> has been registered.
 348
 349 =cut
 350
 351 sub exists_channel ($)
 352 {
 353   my ($name) = @_;
 354   return exists $channels{$name};
 355 }
 356
 357 =item C<channel_type ($name)>
 358
 359 Returns the type of channel C<$name> if it has been registered.
 360 Returns the empty string otherwise.
 361
 362 =cut
 363
 364 sub channel_type ($)
 365 {
 366   my ($name) = @_;
 367   return $channels{$name}{'type'} if exists_channel $name;
 368   return '';
 369 }
 370
 371 # _format_sub_message ($LEADER, $MESSAGE)
 372 # ---------------------------------------
 373 # Split $MESSAGE at new lines and add $LEADER to each line.
 374 sub _format_sub_message ($$)
 375 {
 376   my ($leader, $message) = @_;
 377   return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n";
 378 }
 379
 380 # _format_message ($LOCATION, $MESSAGE, %OPTIONS)
 381 # -----------------------------------------------
 382 # Format the message.  Return a string ready to print.
 383 sub _format_message ($$%)
 384 {
 385   my ($location, $message, %opts) = @_;
 386   my $msg = '';
 387   if (ref $location)
 388     {
 389       # If $LOCATION is a reference, assume it's an instance of the
 390       # Autom4te::Location class and display contexts.
 391       my $loc = $location->get || $me;
 392       $msg = _format_sub_message ("$loc: ", $opts{'header'}
 393                                   . $message . $opts{'footer'});
 394       for my $pair ($location->get_contexts)
 395         {
 396           $msg .= _format_sub_message ($pair->[0] . ":   ", $pair->[1]);
 397         }
 398     }
 399   else
 400     {
 401       $location ||= $me;
 402       $msg = _format_sub_message ("$location: ", $opts{'header'}
 403                                   . $message . $opts{'footer'});
 404     }
 405   return $msg;
 406 }
 407
 408 # Store partial messages here. (See the 'partial' option.)
 409 use vars qw ($partial);
 410 $partial = '';
 411
 412 # _print_message ($LOCATION, $MESSAGE, %OPTIONS)
 413 # ----------------------------------------------
 414 # Format the message, check duplicates, and print it.
 415 sub _print_message ($$%)
 416 {
 417   my ($location, $message, %opts) = @_;
 418
 419   return 0 if ($opts{'silent'});
 420
 421   my $msg = _format_message ($location, $message, %opts);
 422   if ($opts{'partial'})
 423     {
 424       # Incomplete message.   Store, don't print.
 425       $partial .= $msg;
 426       return;
 427     }
 428   else
 429     {
 430       # Prefix with any partial message send so far.
 431       $msg = $partial . $msg;
 432       $partial = '';
 433     }
 434
 435   # Check for duplicate message if requested.
 436   if ($opts{'uniq_part'} ne UP_NONE)
 437     {
 438       # Which part of the error should we match?
 439       my $to_filter;
 440       if ($opts{'uniq_part'} eq UP_TEXT)
 441         {
 442           $to_filter = $message;
 443         }
 444       elsif ($opts{'uniq_part'} eq UP_LOC_TEXT)
 445         {
 446           $to_filter = $msg;
 447         }
 448       else
 449         {
 450           $to_filter = $opts{'uniq_part'};
 451         }
 452
 453       # Do we want local or global uniqueness?
 454       my $dups;
 455       if ($opts{'uniq_scope'} == US_LOCAL)
 456         {
 457           $dups = \%_local_duplicate_messages;
 458         }
 459       elsif ($opts{'uniq_scope'} == US_GLOBAL)
 460         {
 461           $dups = \%_global_duplicate_messages;
 462         }
 463       else
 464         {
 465           confess "unknown value for uniq_scope: " . $opts{'uniq_scope'};
 466         }
 467
 468       # Update the hash of messages.
 469       if (exists $dups->{$to_filter})
 470         {
 471           ++$dups->{$to_filter};
 472           return 0;
 473         }
 474       else
 475         {
 476           $dups->{$to_filter} = 0;
 477         }
 478     }
 479   my $file = $opts{'file'};
 480   print $file $msg;
 481   return 1;
 482 }
 483
 484 =item C<msg ($channel, $location, $message, [%options])>
 485
 486 Emit a message on C<$channel>, overriding some options of the channel with
 487 those specified in C<%options>.  Obviously C<$channel> must have been
 488 registered with C<register_channel>.
 489
 490 C<$message> is the text of the message, and C<$location> is a location
 491 associated to the message.
 492
 493 For instance to complain about some unused variable C<mumble>
 494 declared at line 10 in F<foo.c>, one could do:
 495
 496   msg 'unused', 'foo.c:10', "unused variable `mumble'";
 497
 498 If channel C<unused> is not silent (and if this message is not a duplicate),
 499 the following would be output:
 500
 501   foo.c:10: unused variable `mumble'
 502
 503 C<$location> can also be an instance of C<Autom4te::Location>.  In this
 504 case, the stack of contexts will be displayed in addition.
 505
 506 If C<$message> contains newline characters, C<$location> is prepended
 507 to each line.  For instance,
 508
 509   msg 'error', 'somewhere', "1st line\n2nd line";
 510
 511 becomes
 512
 513   somewhere: 1st line
 514   somewhere: 2nd line
 515
 516 If C<$location> is an empty string, it is replaced by the name of the
 517 program.  Actually, if you don't use C<%options>, you can even
 518 elide the empty C<$location>.  Thus
 519
 520   msg 'fatal', '', 'fatal error';
 521   msg 'fatal', 'fatal error';
 522
 523 both print
 524
 525   progname: fatal error
 526
 527 =cut
 528
 529
 530 use vars qw (@backlog %buffering @chain);
 531
 532 # See buffer_messages() and flush_messages() below.
 533 %buffering = ();        # The map of channel types to buffer.
 534 @backlog = ();          # The buffer of messages.
 535
 536 sub msg ($$;$%)
 537 {
 538   my ($channel, $location, $message, %options) = @_;
 539
 540   if (! defined $message)
 541     {
 542       $message = $location;
 543       $location = '';
 544     }
 545
 546   confess "unknown channel $channel" unless exists $channels{$channel};
 547
 548   my %opts = %{$channels{$channel}};
 549   _merge_options (%opts, %options);
 550
 551   if (exists $buffering{$opts{'type'}})
 552     {
 553       push @backlog, [$channel, $location->clone, $message, %options];
 554       return;
 555     }
 556
 557   # Print the message if needed.
 558   if (_print_message ($location, $message, %opts))
 559     {
 560       # Adjust exit status.
 561       if ($opts{'type'} eq 'error'
 562           || $opts{'type'} eq 'fatal'
 563           || ($opts{'type'} eq 'warning' && $warnings_are_errors))
 564         {
 565           my $es = $opts{'exit_code'};
 566           $exit_code = $es if $es > $exit_code;
 567         }
 568
 569       # Die on fatal messages.
 570       confess if $opts{'backtrace'};
 571       exit $exit_code if $opts{'type'} eq 'fatal';
 572     }
 573 }
 574
 575
 576 =item C<setup_channel ($channel, %options)>
 577
 578 Override the options of C<$channel> with those specified by C<%options>.
 579
 580 =cut
 581
 582 sub setup_channel ($%)
 583 {
 584   my ($name, %opts) = @_;
 585   confess "channel $name doesn't exist" unless exists $channels{$name};
 586   _merge_options %{$channels{$name}}, %opts;
 587 }
 588
 589 =item C<setup_channel_type ($type, %options)>
 590
 591 Override the options of any channel of type C<$type>
 592 with those specified by C<%options>.
 593
 594 =cut
 595
 596 sub setup_channel_type ($%)
 597 {
 598   my ($type, %opts) = @_;
 599   foreach my $channel (keys %channels)
 600     {
 601       setup_channel $channel, %opts
 602         if $channels{$channel}{'type'} eq $type;
 603     }
 604 }
 605
 606 =item C<dup_channel_setup ()>, C<drop_channel_setup ()>
 607
 608 Sometimes it is necessary to make temporary modifications to channels.
 609 For instance one may want to disable a warning while processing a
 610 particular file, and then restore the initial setup.  These two
 611 functions make it easy: C<dup_channel_setup ()> saves a copy of the
 612 current configuration for later restoration by
 613 C<drop_channel_setup ()>.
 614
 615 You can think of this as a stack of configurations whose first entry
 616 is the active one.  C<dup_channel_setup ()> duplicates the first
 617 entry, while C<drop_channel_setup ()> just deletes it.
 618
 619 =cut
 620
 621 use vars qw (@_saved_channels);
 622 @_saved_channels = ();
 623
 624 sub dup_channel_setup ()
 625 {
 626   my %channels_copy;
 627   foreach my $k1 (keys %channels)
 628     {
 629       $channels_copy{$k1} = {%{$channels{$k1}}};
 630     }
 631   push @_saved_channels, \%channels_copy;
 632 }
 633
 634 sub drop_channel_setup ()
 635 {
 636   my $saved = pop @_saved_channels;
 637   %channels = %$saved;
 638 }
 639
 640 =item C<buffer_messages (@types)>, C<flush_messages ()>
 641
 642 By default, when C<msg> is called, messages are processed immediately.
 643
 644 Sometimes it is necessary to delay the output of messages.
 645 For instance you might want to make diagnostics before
 646 channels have been completely configured.
 647
 648 After C<buffer_messages(@types)> has been called, messages sent with
 649 C<msg> to a channel whose type is listed in C<@types> will be stored in a
 650 list for later processing.
 651
 652 This backlog of messages is processed when C<flush_messages> is
 653 called, with the current channel options (not the options in effect,
 654 at the time of C<msg>).  So for instance, if some channel was silenced
 655 in the meantime, messages to this channel will not be printed.
 656
 657 C<flush_messages> cancels the effect of C<buffer_messages>.  Following
 658 calls to C<msg> are processed immediately as usual.
 659
 660 =cut
 661
 662 sub buffer_messages (@)
 663 {
 664   foreach my $type (@_)
 665     {
 666       $buffering{$type} = 1;
 667     }
 668 }
 669
 670 sub flush_messages ()
 671 {
 672   %buffering = ();
 673   foreach my $args (@backlog)
 674     {
 675       &msg (@$args);
 676     }
 677   @backlog = ();
 678 }
 679
 680 =back
 681
 682 =head1 SEE ALSO
 683
 684 L<Autom4te::Location>
 685
 686 =head1 HISTORY
 687
 688 Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt>.
 689
 690 =cut
 691
 692 1;
 693
 694 ### Setup "GNU" style for perl-mode and cperl-mode.
 695 ## Local Variables:
 696 ## perl-indent-level: 2
 697 ## perl-continued-statement-offset: 2
 698 ## perl-continued-brace-offset: 0
 699 ## perl-brace-offset: 0
 700 ## perl-brace-imaginary-offset: 0
 701 ## perl-label-offset: -2
 702 ## cperl-indent-level: 2
 703 ## cperl-brace-offset: 0
 704 ## cperl-continued-brace-offset: 0
 705 ## cperl-label-offset: -2
 706 ## cperl-extra-newline-before-brace: t
 707 ## cperl-merge-trailing-else: nil
 708 ## cperl-continued-statement-offset: 2
 709 ## End: