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