lib/Automake/Channels.pm

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