lib/Autom4te/Channels.pm

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