1 # Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
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)
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.
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
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 ###############################################################
23 package Autom4te
::Channels
;
27 Autom4te::Channels - support functions for error and warning management
31 use Autom4te::Channels;
33 # Register a channel to output warnings about unused variables.
34 register_channel 'unused', type => 'warning';
36 # Register a channel for system errors.
37 register_channel 'system', type => 'error', exit_code => 4;
39 # Output a message on channel 'unused'.
40 msg 'unused', "$file:$line", "unused variable `$var'";
42 # Make the 'unused' channel silent.
43 setup_channel 'unused', silent => 1;
45 # Turn on all channels of type 'warning'.
46 setup_channel_type 'warning', silent => 0;
48 # Treat all warnings as errors.
49 $warnings_are_errors = 1;
51 # Exit with the greatest exit code encountered so far.
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.
70 use vars qw
(@ISA @EXPORT %channels $me);
73 @EXPORT = qw
($exit_code $warnings_are_errors
74 &reset_local_duplicates
&reset_global_duplicates
75 ®ister_channel
&msg
&exists_channel
&channel_type
76 &setup_channel
&setup_channel_type
77 &dup_channel_setup
&drop_channel_setup
78 &buffer_messages
&flush_messages
80 UP_NONE UP_TEXT UP_LOC_TEXT
);
84 =head2 Global Variables
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.
95 use vars qw
($exit_code);
98 =item C<$warnings_are_errors>
100 Set this variable to 1 if warning messages should be treated as
101 errors (i.e. if they should update C<$exit_code>).
105 use vars qw
($warnings_are_errors);
106 $warnings_are_errors = 0;
114 =item C<UP_NONE>, C<UP_TEXT>, C<UP_LOC_TEXT>
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
126 use constant UP_NONE
=> 0;
127 use constant UP_TEXT
=> 1;
128 use constant UP_LOC_TEXT
=> 2;
130 =item C<US_LOCAL>, C<US_GLOBAL>
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.)
141 # possible values for uniq_scope
142 use constant US_LOCAL
=> 0;
143 use constant US_GLOBAL
=> 1;
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:
155 =item C<type =E<gt> 'warning'>
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.
163 =item C<exit_code =E<gt> 1>
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.
169 =item C<file =E<gt> \*STDERR>
171 The file where the error should be output.
173 =item C<silent =E<gt> 0>
175 Whether the channel should be silent. Use this do disable a
176 category of warning, for instance.
178 =item C<uniq_part =E<gt> UP_LOC_TEXT>
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>
184 C<uniq_part> can also be set to an arbitrary string that will be used
185 instead of the message when considering duplicates.
187 =item C<uniq_scope =E<gt> US_LOCAL>
189 The scope of duplicate filtering. See the documentation for the
190 C<US_LOCAL>, and C<US_GLOBAL> constants above.
192 =item C<header =E<gt> ''>
194 A string to prepend to each message emitted through this channel.
196 =item C<footer =E<gt> ''>
198 A string to append to each message emitted through this channel.
200 =item C<backtrace =E<gt> 0>
202 Die with a stack backtrace after displaying the message.
204 =item C<partial =E<gt> 0>
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.
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
215 For instance the following messages
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';
224 foo:2: redefinition of A ...
225 foo:1: ... A previously defined here
226 foo:3: redefinition of A ...
228 where the duplicate "I<... A previously defined here>" has been
231 Linking these messages using C<partial> as follows will prevent the
232 fourth message to disappear.
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';
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
247 use vars qw
(%_default_options %_global_duplicate_messages
248 %_local_duplicate_messages);
250 # Default options for a channel.
257 uniq_scope
=> US_LOCAL
,
258 uniq_part
=> UP_LOC_TEXT
,
265 # Filled with output messages as keys, to detect duplicates.
266 # The value associated with each key is the number of occurrences
268 %_local_duplicate_messages = ();
269 %_global_duplicate_messages = ();
271 sub _reset_duplicates
(\
%)
275 foreach my $k (keys %$ref)
288 =item C<reset_local_duplicates ()>
290 Reset local duplicate messages (see C<US_LOCAL>), and
291 return the number of messages that have been filtered out.
295 sub reset_local_duplicates
()
297 return _reset_duplicates
%_local_duplicate_messages;
300 =item C<reset_global_duplicates ()>
302 Reset local duplicate messages (see C<US_GLOBAL>), and
303 return the number of messages that have been filtered out.
307 sub reset_global_duplicates
()
309 return _reset_duplicates
%_global_duplicate_messages;
312 sub _merge_options
(\
%%)
314 my ($hash, %options) = @_;
317 foreach (keys %options)
319 if (exists $hash->{$_})
321 $hash->{$_} = $options{$_}
325 confess
"unknown option `$_'";
330 =item C<register_channel ($name, [%options])>
332 Declare channel C<$name>, and override the default options
333 with those listed in C<%options>.
337 sub register_channel
($;%)
339 my ($name, %options) = @_;
340 my %channel_opts = %_default_options;
341 _merge_options
%channel_opts, %options;
342 $channels{$name} = \
%channel_opts;
345 =item C<exists_channel ($name)>
347 Returns true iff channel C<$name> has been registered.
351 sub exists_channel
($)
354 return exists $channels{$name};
357 =item C<channel_type ($name)>
359 Returns the type of channel C<$name> if it has been registered.
360 Returns the empty string otherwise.
367 return $channels{$name}{'type'} if exists_channel
$name;
371 # _format_sub_message ($LEADER, $MESSAGE)
372 # ---------------------------------------
373 # Split $MESSAGE at new lines and add $LEADER to each line.
374 sub _format_sub_message
($$)
376 my ($leader, $message) = @_;
377 return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n";
380 # _format_message ($LOCATION, $MESSAGE, %OPTIONS)
381 # -----------------------------------------------
382 # Format the message. Return a string ready to print.
383 sub _format_message
($$%)
385 my ($location, $message, %opts) = @_;
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)
396 $msg .= _format_sub_message
($pair->[0] . ": ", $pair->[1]);
402 $msg = _format_sub_message
("$location: ", $opts{'header'}
403 . $message . $opts{'footer'});
408 # Store partial messages here. (See the 'partial' option.)
409 use vars qw
($partial);
412 # _print_message ($LOCATION, $MESSAGE, %OPTIONS)
413 # ----------------------------------------------
414 # Format the message, check duplicates, and print it.
415 sub _print_message
($$%)
417 my ($location, $message, %opts) = @_;
419 return 0 if ($opts{'silent'});
421 my $msg = _format_message
($location, $message, %opts);
422 if ($opts{'partial'})
424 # Incomplete message. Store, don't print.
430 # Prefix with any partial message send so far.
431 $msg = $partial . $msg;
435 # Check for duplicate message if requested.
436 if ($opts{'uniq_part'} ne UP_NONE
)
438 # Which part of the error should we match?
440 if ($opts{'uniq_part'} eq UP_TEXT
)
442 $to_filter = $message;
444 elsif ($opts{'uniq_part'} eq UP_LOC_TEXT
)
450 $to_filter = $opts{'uniq_part'};
453 # Do we want local or global uniqueness?
455 if ($opts{'uniq_scope'} == US_LOCAL
)
457 $dups = \
%_local_duplicate_messages;
459 elsif ($opts{'uniq_scope'} == US_GLOBAL
)
461 $dups = \
%_global_duplicate_messages;
465 confess
"unknown value for uniq_scope: " . $opts{'uniq_scope'};
468 # Update the hash of messages.
469 if (exists $dups->{$to_filter})
471 ++$dups->{$to_filter};
476 $dups->{$to_filter} = 0;
479 my $file = $opts{'file'};
484 =item C<msg ($channel, $location, $message, [%options])>
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>.
490 C<$message> is the text of the message, and C<$location> is a location
491 associated to the message.
493 For instance to complain about some unused variable C<mumble>
494 declared at line 10 in F<foo.c>, one could do:
496 msg 'unused', 'foo.c:10', "unused variable `mumble'";
498 If channel C<unused> is not silent (and if this message is not a duplicate),
499 the following would be output:
501 foo.c:10: unused variable `mumble'
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.
506 If C<$message> contains newline characters, C<$location> is prepended
507 to each line. For instance,
509 msg 'error', 'somewhere', "1st line\n2nd line";
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
520 msg 'fatal', '', 'fatal error';
521 msg 'fatal', 'fatal error';
525 progname: fatal error
530 use vars qw
(@backlog %buffering @chain);
532 # See buffer_messages() and flush_messages() below.
533 %buffering = (); # The map of channel types to buffer.
534 @backlog = (); # The buffer of messages.
538 my ($channel, $location, $message, %options) = @_;
540 if (! defined $message)
542 $message = $location;
546 confess
"unknown channel $channel" unless exists $channels{$channel};
548 my %opts = %{$channels{$channel}};
549 _merge_options
(%opts, %options);
551 if (exists $buffering{$opts{'type'}})
553 push @backlog, [$channel, $location->clone, $message, %options];
557 # Print the message if needed.
558 if (_print_message
($location, $message, %opts))
560 # Adjust exit status.
561 if ($opts{'type'} eq 'error'
562 || $opts{'type'} eq 'fatal'
563 || ($opts{'type'} eq 'warning' && $warnings_are_errors))
565 my $es = $opts{'exit_code'};
566 $exit_code = $es if $es > $exit_code;
569 # Die on fatal messages.
570 confess
if $opts{'backtrace'};
571 exit $exit_code if $opts{'type'} eq 'fatal';
576 =item C<setup_channel ($channel, %options)>
578 Override the options of C<$channel> with those specified by C<%options>.
582 sub setup_channel
($%)
584 my ($name, %opts) = @_;
585 confess
"channel $name doesn't exist" unless exists $channels{$name};
586 _merge_options
%{$channels{$name}}, %opts;
589 =item C<setup_channel_type ($type, %options)>
591 Override the options of any channel of type C<$type>
592 with those specified by C<%options>.
596 sub setup_channel_type
($%)
598 my ($type, %opts) = @_;
599 foreach my $channel (keys %channels)
601 setup_channel
$channel, %opts
602 if $channels{$channel}{'type'} eq $type;
606 =item C<dup_channel_setup ()>, C<drop_channel_setup ()>
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 ()>.
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.
621 use vars qw
(@_saved_channels);
622 @_saved_channels = ();
624 sub dup_channel_setup
()
627 foreach my $k1 (keys %channels)
629 $channels_copy{$k1} = {%{$channels{$k1}}};
631 push @_saved_channels, \
%channels_copy;
634 sub drop_channel_setup
()
636 my $saved = pop @_saved_channels;
640 =item C<buffer_messages (@types)>, C<flush_messages ()>
642 By default, when C<msg> is called, messages are processed immediately.
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.
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.
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.
657 C<flush_messages> cancels the effect of C<buffer_messages>. Following
658 calls to C<msg> are processed immediately as usual.
662 sub buffer_messages
(@
)
664 foreach my $type (@_)
666 $buffering{$type} = 1;
670 sub flush_messages
()
673 foreach my $args (@backlog)
684 L<Autom4te::Location>
688 Written by Alexandre Duret-Lutz E<lt>F<adl@gnu.org>E<gt>.
694 ### Setup "GNU" style for perl-mode and cperl-mode.
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