File Coverage

lib/CPANPLUS/Error.pm

Criterion	Covered	Total	%
statement	60	61	98.3
branch	14	18	77.7
condition	5	6	83.3
subroutine	15	15	100.0
pod	3	5	60.0
total	97	105	92.3

package CPANPLUS::Error;

use strict;
use vars qw[$VERSION];
$VERSION = "0.9916";

use Log::Message private => 0;;

=pod

=head1 NAME

CPANPLUS::Error - error handling for CPANPLUS

=head1 SYNOPSIS

    use CPANPLUS::Error qw[cp_msg cp_error];

=head1 DESCRIPTION

This module provides the error handling code for the CPANPLUS
libraries, and is mainly intended for internal use.

=head1 FUNCTIONS

=head2 cp_msg("message string" [,VERBOSE])

Records a message on the stack, and prints it to C (or actually
C<$MSG_FH>, see the C section below), if the
C option is true.
The C option defaults to false.

=head2 msg()

An alias for C.

=head2 cp_error("error string" [,VERBOSE])

Records an error on the stack, and prints it to C (or actually
C<$ERROR_FH>, see the C sections below), if the
C option is true.
The C options defaults to true.

=head2 error()

An alias for C.

=head1 CLASS METHODS

=head2 CPANPLUS::Error->stack()

Retrieves all the items on the stack. Since C is
implemented using C, consult its manpage for the
function C to see what is returned and how to use the items.

=head2 CPANPLUS::Error->stack_as_string([TRACE])

Returns the whole stack as a printable string. If the C option is
true all items are returned with C output, rather than
just the message.
C defaults to false.

=head2 CPANPLUS::Error->flush()

Removes all the items from the stack and returns them. Since
C is  implemented using C, consult its
manpage for the function C to see what is returned and how
to use the items.

=cut

BEGIN {
    use Exporter;
    use Params::Check   qw[check];
    use vars            qw[@EXPORT @ISA $ERROR_FH $MSG_FH];

    @ISA        = 'Exporter';
    @EXPORT     = qw[cp_error cp_msg error msg];

    my $log     = new Log::Message;

    for my $func ( @EXPORT ) {
        no strict 'refs';

        my $prefix  = 'cp_';
        my $name    = $func;
        $name       =~ s/^$prefix//g;

        *$func = sub {
                        my $msg     = shift;

                        ### no point storing non-messages
                        return unless defined $msg;

                        $log->store(
                                message => $msg,
                                tag     => uc $name,
                                level   => $prefix . $name,
                                extra   => [@_]
                        );
                };
    }

    sub flush {
        my @foo = $log->flush;
        return unless @foo;
        return reverse @foo;
    }

    sub stack {
        return $log->retrieve( chrono => 1 );
    }

    sub stack_as_string {
        my $class = shift;
        my $trace = shift() ? 1 : 0;

        return join $/, map {
                        '[' . $_->tag . '] [' . $_->when . '] ' .
                        ($trace ? $_->message . ' ' . $_->longmess
                                : $_->message);
                    } __PACKAGE__->stack;
    }
}

=head1 GLOBAL VARIABLES

=over 4

=item $ERROR_FH

This is the filehandle all the messages sent to C are being
printed. This defaults to C<*STDERR>.

=item $MSG_FH

This is the filehandle all the messages sent to C are being
printed. This default to C<*STDOUT>.

=back

=cut

local $| = 1;
$ERROR_FH   = \*STDERR;
$MSG_FH     = \*STDOUT;

package # Hide from Pause
  Log::Message::Handlers;
use Carp ();

{

    sub cp_msg {
        my $self    = shift;
        my $verbose = shift;

        ### so you don't want us to print the msg? ###
        return if defined $verbose && $verbose == 0;

        my $old_fh = select $CPANPLUS::Error::MSG_FH;

        print '['. $self->tag . '] ' . $self->message . "\n";
        select $old_fh;

        return;
    }

    sub cp_error {
        my $self    = shift;
        my $verbose = shift;

        ### so you don't want us to print the error? ###
        return if defined $verbose && $verbose == 0;

        my $old_fh = select $CPANPLUS::Error::ERROR_FH;

        ### is only going to be 1 for now anyway ###
        ### C::I may not be loaded, so do a can() check first
        my $cb      = CPANPLUS::Internals->can('_return_all_objects')
                        ? (CPANPLUS::Internals->_return_all_objects)[0]
                        : undef;

        ### maybe we didn't initialize an internals object (yet) ###
        my $debug   = $cb ? $cb->configure_object->get_conf('debug') : 0;
        my $msg     =  '['. $self->tag . '] ' . $self->message . "\n";

        ### i'm getting this warning in the test suite:
        ### Ambiguous call resolved as CORE::warn(), qualify as such or
        ### use & at CPANPLUS/Error.pm line 57.
        ### no idea where it's coming from, since there's no 'sub warn'
        ### anywhere to be found, but i'll mark it explicitly nonetheless
        ### --kane
        print $debug ? Carp::shortmess($msg) : $msg . "\n";

        select $old_fh;

        return;
    }
}

1;

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: