channels.pm

autoconf是一个产生可以自动配置源代码包

=item C<channel_type ($name)>

Returns the type of channel C<$name> if it has been registered.
Returns the empty string otherwise.

=cut

sub channel_type ($)
{
  my ($name) = @_;
  return $channels{$name}{'type'} if exists_channel $name;
  return '';
}

# _format_sub_message ($LEADER, $MESSAGE)
# ---------------------------------------
# Split $MESSAGE at new lines and add $LEADER to each line.
sub _format_sub_message ($$)
{
  my ($leader, $message) = @_;
  return $leader . join ("\n" . $leader, split ("\n", $message)) . "\n";
}

# _format_message ($LOCATION, $MESSAGE, %OPTIONS)
# -----------------------------------------------
# Format the message.  Return a string ready to print.
sub _format_message ($$%)
{
  my ($location, $message, %opts) = @_;
  my $msg = '';
  if (ref $location)
    {
      # If $LOCATION is a reference, assume it's an instance of the
      # Autom4te::Location class and display contexts.
      my $loc = $location->get || $me;
      $msg = _format_sub_message ("$loc: ", $opts{'header'}
				  . $message . $opts{'footer'});
      for my $pair ($location->get_contexts)
	{
	  $msg .= _format_sub_message ($pair->[0] . ":   ", $pair->[1]);
	}
    }
  else
    {
      $location ||= $me;
      $msg = _format_sub_message ("$location: ", $opts{'header'}
				  . $message . $opts{'footer'});
    }
  return $msg;
}

# Store partial messages here. (See the 'partial' option.)
use vars qw ($partial);
$partial = '';

# _print_message ($LOCATION, $MESSAGE, %OPTIONS)
# ----------------------------------------------
# Format the message, check duplicates, and print it.
sub _print_message ($$%)
{
  my ($location, $message, %opts) = @_;

  return 0 if ($opts{'silent'});

  my $msg = _format_message ($location, $message, %opts);
  if ($opts{'partial'})
    {
      # Incomplete message.   Store, don't print.
      $partial .= $msg;
      return;
    }
  else
    {
      # Prefix with any partial message send so far.
      $msg = $partial . $msg;
      $partial = '';
    }

  # Check for duplicate message if requested.
  if ($opts{'uniq_part'} ne UP_NONE)
    {
      # Which part of the error should we match?
      my $to_filter;
      if ($opts{'uniq_part'} eq UP_TEXT)
	{
	  $to_filter = $message;
	}
      elsif ($opts{'uniq_part'} eq UP_LOC_TEXT)
	{
	  $to_filter = $msg;
	}
      else
	{
	  $to_filter = $opts{'uniq_part'};
	}

      # Do we want local or global uniqueness?
      my $dups;
      if ($opts{'uniq_scope'} == US_LOCAL)
	{
	  $dups = \%_local_duplicate_messages;
	}
      elsif ($opts{'uniq_scope'} == US_GLOBAL)
	{
	  $dups = \%_global_duplicate_messages;
	}
      else
	{
	  confess "unknown value for uniq_scope: " . $opts{'uniq_scope'};
	}

      # Update the hash of messages.
      if (exists $dups->{$to_filter})
	{
	  ++$dups->{$to_filter};
	  return 0;
	}
      else
	{
	  $dups->{$to_filter} = 0;
	}
    }
  my $file = $opts{'file'};
  print $file $msg;
  return 1;
}

=item C<msg ($channel, $location, $message, [%options])>

Emit a message on C<$channel>, overriding some options of the channel with
those specified in C<%options>.  Obviously C<$channel> must have been
registered with C<register_channel>.

C<$message> is the text of the message, and C<$location> is a location
associated to the message.

For instance to complain about some unused variable C<mumble>
declared at line 10 in F<foo.c>, one could do:

  msg 'unused', 'foo.c:10', "unused variable `mumble'";

If channel C<unused> is not silent (and if this message is not a duplicate),
the following would be output:

  foo.c:10: unused variable `mumble'

C<$location> can also be an instance of C<Autom4te::Location>.  In this
case, the stack of contexts will be displayed in addition.

If C<$message> contains newline characters, C<$location> is prepended
to each line.  For instance,

  msg 'error', 'somewhere', "1st line\n2nd line";

becomes

  somewhere: 1st line
  somewhere: 2nd line

If C<$location> is an empty string, it is replaced by the name of the
program.  Actually, if you don't use C<%options>, you can even
elide the empty C<$location>.  Thus

  msg 'fatal', '', 'fatal error';
  msg 'fatal', 'fatal error';

both print

  progname: fatal error

=cut


use vars qw (@backlog %buffering @chain);

# See buffer_messages() and flush_messages() below.
%buffering = ();	# The map of channel types to buffer.
@backlog = ();		# The buffer of messages.

sub msg ($$;$%)
{
  my ($channel, $location, $message, %options) = @_;

  if (! defined $message)
    {
      $message = $location;
      $location = '';
    }

  confess "unknown channel $channel" unless exists $channels{$channel};

  my %opts = %{$channels{$channel}};
  _merge_options (%opts, %options);

  if (exists $buffering{$opts{'type'}})
    {
      push @backlog, [$channel, $location->clone, $message, %options];
      return;
    }

  # Print the message if needed.
  if (_print_message ($location, $message, %opts))
    {
      # Adjust exit status.
      if ($opts{'type'} eq 'error'
	  || $opts{'type'} eq 'fatal'
	  || ($opts{'type'} eq 'warning' && $warnings_are_errors))
	{
	  my $es = $opts{'exit_code'};
	  $exit_code = $es if $es > $exit_code;
	}

      # Die on fatal messages.
      confess if $opts{'backtrace'};
      exit $exit_code if $opts{'type'} eq 'fatal';
    }
}


=item C<setup_channel ($channel, %options)>

Override the options of C<$channel> with those specified by C<%options>.

=cut

sub setup_channel ($%)
{
  my ($name, %opts) = @_;
  confess "channel $name doesn't exist" unless exists $channels{$name};
  _merge_options %{$channels{$name}}, %opts;
}

=item C<setup_channel_type ($type, %options)>

Override the options of any channel of type C<$type>
with those specified by C<%options>.

=cut

sub setup_channel_type ($%)
{
  my ($type, %opts) = @_;
  foreach my $channel (keys %channels)
    {
      setup_channel $channel, %opts
	if $channels{$channel}{'type'} eq $type;
    }
}

=item C<dup_channel_setup ()>, C<drop_channel_setup ()>

Sometimes it is necessary to make temporary modifications to channels.
For instance one may want to disable a warning while processing a
particular file, and then restore the initial setup.  These two
functions make it easy: C<dup_channel_setup ()> saves a copy of the
current configuration for later restoration by
C<drop_channel_setup ()>.

You can think of this as a stack of configurations whose first entry
is the active one.  C<dup_channel_setup ()> duplicates the first
entry, while C<drop_channel_setup ()> just deletes it.

=cut

use vars qw (@_saved_channels);
@_saved_channels = ();

sub dup_channel_setup ()
{
  my %channels_copy;
  foreach my $k1 (keys %channels)
    {
      $channels_copy{$k1} = {%{$channels{$k1}}};
    }
  push @_saved_channels, \%channels_copy;
}

sub drop_channel_setup ()
{
  my $saved = pop @_saved_channels;
  %channels = %$saved;
}

=item C<buffer_messages (@types)>, C<flush_messages ()>

By default, when C<msg> is called, messages are processed immediately.

Sometimes it is necessary to delay the output of messages.
For instance you might want to make diagnostics before
channels have been completely configured.

After C<buffer_messages(@types)> has been called, messages sent with
C<msg> to a channel whose type is listed in C<@types> will be stored in a
list for later processing.

This backlog of messages is processed when C<flush_messages> is
called, with the current channel options (not the options in effect,
at the time of C<msg>).  So for instance, if some channel was silenced
in the meantime, messages to this channel will not be printed.

C<flush_messages> cancels the effect of C<buffer_messages>.  Following
calls to C<msg> are processed immediately as usual.

=cut

sub buffer_messages (@)
{
  foreach my $type (@_)
    {
      $buffering{$type} = 1;
    }
}

sub flush_messages ()
{
  %buffering = ();
  foreach my $args (@backlog)
    {
      &msg (@$args);
    }
  @backlog = ();
}

=back

=head1 SEE ALSO

L<Autom4te::Location>

=head1 HISTORY

Written by Alexandre Duret-Lutz E<lt>F<[e-mail]>E<gt>.

=cut

1;

### Setup "GNU" style for perl-mode and cperl-mode.
## Local Variables:
## perl-indent-level: 2
## perl-continued-statement-offset: 2
## perl-continued-brace-offset: 0
## perl-brace-offset: 0
## perl-brace-imaginary-offset: 0
## perl-label-offset: -2
## cperl-indent-level: 2
## cperl-brace-offset: 0
## cperl-continued-brace-offset: 0
## cperl-label-offset: -2
## cperl-extra-newline-before-brace: t
## cperl-merge-trailing-else: nil
## cperl-continued-statement-offset: 2
## End: