Channels.pm (automake-1.16.2.tar.xz) | : | Channels.pm (automake-1.16.3.tar.xz) | ||
---|---|---|---|---|
skipping to change at line 71 | skipping to change at line 71 | |||
This perl module provides support functions for handling diagnostic | This perl module provides support functions for handling diagnostic | |||
channels in programs. Channels can be registered to convey fatal, | channels in programs. Channels can be registered to convey fatal, | |||
error, warning, or debug messages. Each channel has various options | error, warning, or debug messages. Each channel has various options | |||
(e.g. is the channel silent, should duplicate messages be removed, | (e.g. is the channel silent, should duplicate messages be removed, | |||
etc.) that can also be overridden on a per-message basis. | etc.) that can also be overridden on a per-message basis. | |||
=cut | =cut | |||
use 5.006; | use 5.006; | |||
use strict; | use strict; | |||
use Exporter; | use warnings FATAL => 'all'; | |||
use Carp; | use Carp; | |||
use Exporter; | ||||
use File::Basename; | use File::Basename; | |||
use vars qw (@ISA @EXPORT %channels $me); | our @ISA = qw (Exporter); | |||
our @EXPORT = qw ($exit_code $warnings_are_errors | ||||
&reset_local_duplicates &reset_global_duplicates | ||||
®ister_channel &msg &exists_channel &channel_type | ||||
&setup_channel &setup_channel_type | ||||
&dup_channel_setup &drop_channel_setup | ||||
&buffer_messages &flush_messages | ||||
&setup_channel_queue &pop_channel_queue | ||||
US_GLOBAL US_LOCAL | ||||
UP_NONE UP_TEXT UP_LOC_TEXT); | ||||
@ISA = qw (Exporter); | our %channels; | |||
@EXPORT = qw ($exit_code $warnings_are_errors | our $me = basename $0; | |||
&reset_local_duplicates &reset_global_duplicates | ||||
®ister_channel &msg &exists_channel &channel_type | ||||
&setup_channel &setup_channel_type | ||||
&dup_channel_setup &drop_channel_setup | ||||
&buffer_messages &flush_messages | ||||
&setup_channel_queue &pop_channel_queue | ||||
US_GLOBAL US_LOCAL | ||||
UP_NONE UP_TEXT UP_LOC_TEXT); | ||||
$me = basename $0; | ||||
=head2 Global Variables | =head2 Global Variables | |||
=over 4 | =over 4 | |||
=item C<$exit_code> | =item C<$exit_code> | |||
The greatest exit code seen so far. C<$exit_code> is updated from | The greatest exit code seen so far. C<$exit_code> is updated from | |||
the C<exit_code> options of C<fatal> and C<error> channels. | the C<exit_code> options of C<fatal> and C<error> channels. | |||
=cut | =cut | |||
use vars qw ($exit_code); | our $exit_code = 0; | |||
$exit_code = 0; | ||||
=item C<$warnings_are_errors> | =item C<$warnings_are_errors> | |||
Set this variable to 1 if warning messages should be treated as | Set this variable to 1 if warning messages should be treated as | |||
errors (i.e. if they should update C<$exit_code>). | errors (i.e. if they should update C<$exit_code>). | |||
=cut | =cut | |||
use vars qw ($warnings_are_errors); | our $warnings_are_errors = 0; | |||
$warnings_are_errors = 0; | ||||
=back | =back | |||
=head2 Constants | =head2 Constants | |||
=over 4 | =over 4 | |||
=item C<UP_NONE>, C<UP_TEXT>, C<UP_LOC_TEXT> | =item C<UP_NONE>, C<UP_TEXT>, C<UP_LOC_TEXT> | |||
Possible values for the C<uniq_part> options. This selects the part | Possible values for the C<uniq_part> options. This selects the part | |||
skipping to change at line 262 | skipping to change at line 261 | |||
msg 'channel', 'foo:1', '... A previously defined here'; | msg 'channel', 'foo:1', '... A previously defined here'; | |||
Note that because the stack of C<partial> messages is printed with the | Note that because the stack of C<partial> messages is printed with the | |||
first non-C<partial> message, most options of C<partial> messages will | first non-C<partial> message, most options of C<partial> messages will | |||
be ignored. | be ignored. | |||
=back | =back | |||
=cut | =cut | |||
use vars qw (%_default_options %_global_duplicate_messages | ||||
%_local_duplicate_messages); | ||||
# Default options for a channel. | # Default options for a channel. | |||
%_default_options = | our %_default_options = | |||
( | ( | |||
type => 'warning', | type => 'warning', | |||
exit_code => 1, | exit_code => 1, | |||
file => \*STDERR, | file => \*STDERR, | |||
silent => 0, | silent => 0, | |||
ordered => 1, | ordered => 1, | |||
queue => 0, | queue => 0, | |||
queue_key => undef, | queue_key => undef, | |||
uniq_scope => US_LOCAL, | uniq_scope => US_LOCAL, | |||
uniq_part => UP_LOC_TEXT, | uniq_part => UP_LOC_TEXT, | |||
header => '', | header => '', | |||
footer => '', | footer => '', | |||
backtrace => 0, | backtrace => 0, | |||
partial => 0, | partial => 0, | |||
); | ); | |||
# Filled with output messages as keys, to detect duplicates. | # Filled with output messages as keys, to detect duplicates. | |||
# The value associated with each key is the number of occurrences | # The value associated with each key is the number of occurrences | |||
# filtered out. | # filtered out. | |||
%_local_duplicate_messages = (); | our %_local_duplicate_messages = (); | |||
%_global_duplicate_messages = (); | our %_global_duplicate_messages = (); | |||
sub _reset_duplicates (\%) | sub _reset_duplicates (\%) | |||
{ | { | |||
my ($ref) = @_; | my ($ref) = @_; | |||
my $dup = 0; | my $dup = 0; | |||
foreach my $k (keys %$ref) | foreach my $k (keys %$ref) | |||
{ | { | |||
$dup += $ref->{$k}; | $dup += $ref->{$k}; | |||
} | } | |||
%$ref = (); | %$ref = (); | |||
skipping to change at line 405 | skipping to change at line 401 | |||
# _format_sub_message ($LEADER, $MESSAGE) | # _format_sub_message ($LEADER, $MESSAGE) | |||
# --------------------------------------- | # --------------------------------------- | |||
# Split $MESSAGE at new lines and add $LEADER to each line. | # Split $MESSAGE at new lines and add $LEADER to each line. | |||
sub _format_sub_message ($$) | sub _format_sub_message ($$) | |||
{ | { | |||
my ($leader, $message) = @_; | my ($leader, $message) = @_; | |||
return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n"; | return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n"; | |||
} | } | |||
# Store partial messages here. (See the 'partial' option.) | # Store partial messages here. (See the 'partial' option.) | |||
use vars qw ($partial); | our $partial = ''; | |||
$partial = ''; | ||||
# _format_message ($LOCATION, $MESSAGE, %OPTIONS) | # _format_message ($LOCATION, $MESSAGE, %OPTIONS) | |||
# ----------------------------------------------- | # ----------------------------------------------- | |||
# Format the message. Return a string ready to print. | # Format the message. Return a string ready to print. | |||
sub _format_message ($$%) | sub _format_message ($$%) | |||
{ | { | |||
my ($location, $message, %opts) = @_; | my ($location, $message, %opts) = @_; | |||
my $msg = ($partial eq '' ? $opts{'header'} : '') . $message | my $msg = ($partial eq '' ? $opts{'header'} : '') . $message | |||
. ($opts{'partial'} ? '' : $opts{'footer'}); | . ($opts{'partial'} ? '' : $opts{'footer'}); | |||
if (ref $location) | if (ref $location) | |||
skipping to change at line 619 | skipping to change at line 614 | |||
msg 'fatal', '', 'fatal error'; | msg 'fatal', '', 'fatal error'; | |||
msg 'fatal', 'fatal error'; | msg 'fatal', 'fatal error'; | |||
both print | both print | |||
progname: fatal error | progname: fatal error | |||
=cut | =cut | |||
use vars qw (@backlog %buffering); | ||||
# See buffer_messages() and flush_messages() below. | # See buffer_messages() and flush_messages() below. | |||
%buffering = (); # The map of channel types to buffer. | our %buffering = (); # The map of channel types to buffer. | |||
@backlog = (); # The buffer of messages. | our @backlog = (); # The buffer of messages. | |||
sub msg ($$;$%) | sub msg ($$;$%) | |||
{ | { | |||
my ($channel, $location, $message, %options) = @_; | my ($channel, $location, $message, %options) = @_; | |||
if (! defined $message) | if (! defined $message) | |||
{ | { | |||
$message = $location; | $message = $location; | |||
$location = ''; | $location = ''; | |||
} | } | |||
skipping to change at line 714 | skipping to change at line 707 | |||
functions make it easy: C<dup_channel_setup ()> saves a copy of the | functions make it easy: C<dup_channel_setup ()> saves a copy of the | |||
current configuration for later restoration by | current configuration for later restoration by | |||
C<drop_channel_setup ()>. | C<drop_channel_setup ()>. | |||
You can think of this as a stack of configurations whose first entry | You can think of this as a stack of configurations whose first entry | |||
is the active one. C<dup_channel_setup ()> duplicates the first | is the active one. C<dup_channel_setup ()> duplicates the first | |||
entry, while C<drop_channel_setup ()> just deletes it. | entry, while C<drop_channel_setup ()> just deletes it. | |||
=cut | =cut | |||
use vars qw (@_saved_channels @_saved_werrors); | our @_saved_channels = (); | |||
@_saved_channels = (); | our @_saved_werrors = (); | |||
@_saved_werrors = (); | ||||
sub dup_channel_setup () | sub dup_channel_setup () | |||
{ | { | |||
my %channels_copy; | my %channels_copy; | |||
foreach my $k1 (keys %channels) | foreach my $k1 (keys %channels) | |||
{ | { | |||
$channels_copy{$k1} = {%{$channels{$k1}}}; | $channels_copy{$k1} = {%{$channels{$k1}}}; | |||
} | } | |||
push @_saved_channels, \%channels_copy; | push @_saved_channels, \%channels_copy; | |||
push @_saved_werrors, $warnings_are_errors; | push @_saved_werrors, $warnings_are_errors; | |||
End of changes. 13 change blocks. | ||||
33 lines changed or deleted | 25 lines changed or added |