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