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