lib/CPANPLUS/Error.pm

   1 package CPANPLUS::Error;
   2
   3 use strict;
   4
   5 use Log::Message private => 0;;
   6
   7 =pod
   8
   9 =head1 NAME
  10
  11 CPANPLUS::Error
  12
  13 =head1 SYNOPSIS
  14
  15     use CPANPLUS::Error qw[cp_msg cp_error];
  16
  17 =head1 DESCRIPTION
  18
  19 This module provides the error handling code for the CPANPLUS
  20 libraries, and is mainly intended for internal use.
  21
  22 =head1 FUNCTIONS
  23
  24 =head2 cp_msg("message string" [,VERBOSE])
  25
  26 Records a message on the stack, and prints it to C<STDOUT> (or actually
  27 C<$MSG_FH>, see the C<GLOBAL VARIABLES> section below), if the
  28 C<VERBOSE> option is true.
  29 The C<VERBOSE> option defaults to false.
  30
  31 =head2 msg()
  32
  33 An alias for C<cp_msg>.
  34
  35 =head2 cp_error("error string" [,VERBOSE])
  36
  37 Records an error on the stack, and prints it to C<STDERR> (or actually
  38 C<$ERROR_FH>, see the C<GLOBAL VARIABLES> sections below), if the
  39 C<VERBOSE> option is true.
  40 The C<VERBOSE> options defaults to true.
  41
  42 =head2 error()
  43
  44 An alias for C<cp_error>.
  45
  46 =head1 CLASS METHODS
  47
  48 =head2 CPANPLUS::Error->stack()
  49
  50 Retrieves all the items on the stack. Since C<CPANPLUS::Error> is
  51 implemented using C<Log::Message>, consult its manpage for the
  52 function C<retrieve> to see what is returned and how to use the items.
  53
  54 =head2 CPANPLUS::Error->stack_as_string([TRACE])
  55
  56 Returns the whole stack as a printable string. If the C<TRACE> option is
  57 true all items are returned with C<Carp::longmess> output, rather than
  58 just the message.
  59 C<TRACE> defaults to false.
  60
  61 =head2 CPANPLUS::Error->flush()
  62
  63 Removes all the items from the stack and returns them. Since
  64 C<CPANPLUS::Error> is  implemented using C<Log::Message>, consult its
  65 manpage for the function C<retrieve> to see what is returned and how
  66 to use the items.
  67
  68 =cut
  69
  70 BEGIN {
  71     use Exporter;
  72     use Params::Check   qw[check];
  73     use vars            qw[@EXPORT @ISA $ERROR_FH $MSG_FH];
  74
  75     @ISA        = 'Exporter';
  76     @EXPORT     = qw[cp_error cp_msg error msg];
  77
  78     my $log     = new Log::Message;
  79
  80     for my $func ( @EXPORT ) {
  81         no strict 'refs';
  82
  83         my $prefix  = 'cp_';
  84         my $name    = $func;
  85         $name       =~ s/^$prefix//g;
  86
  87         *$func = sub {
  88                         my $msg     = shift;
  89
  90                         ### no point storing non-messages
  91                         return unless defined $msg;
  92
  93                         $log->store(
  94                                 message => $msg,
  95                                 tag     => uc $name,
  96                                 level   => $prefix . $name,
  97                                 extra   => [@_]
  98                         );
  99                 };
 100     }
 101
 102     sub flush {
 103         return reverse $log->flush;
 104     }
 105
 106     sub stack {
 107         return $log->retrieve( chrono => 1 );
 108     }
 109
 110     sub stack_as_string {
 111         my $class = shift;
 112         my $trace = shift() ? 1 : 0;
 113
 114         return join $/, map {
 115                         '[' . $_->tag . '] [' . $_->when . '] ' .
 116                         ($trace ? $_->message . ' ' . $_->longmess
 117                                 : $_->message);
 118                     } __PACKAGE__->stack;
 119     }
 120 }
 121
 122 =head1 GLOBAL VARIABLES
 123
 124 =over 4
 125
 126 =item $ERROR_FH
 127
 128 This is the filehandle all the messages sent to C<error()> are being
 129 printed. This defaults to C<*STDERR>.
 130
 131 =item $MSG_FH
 132
 133 This is the filehandle all the messages sent to C<msg()> are being
 134 printed. This default to C<*STDOUT>.
 135
 136 =cut
 137 local $| = 1;
 138 $ERROR_FH   = \*STDERR;
 139 $MSG_FH     = \*STDOUT;
 140
 141 package Log::Message::Handlers;
 142 use Carp ();
 143
 144 {
 145
 146     sub cp_msg {
 147         my $self    = shift;
 148         my $verbose = shift;
 149
 150         ### so you don't want us to print the msg? ###
 151         return if defined $verbose && $verbose == 0;
 152
 153         my $old_fh = select $CPANPLUS::Error::MSG_FH;
 154
 155         print '['. $self->tag . '] ' . $self->message . "\n";
 156         select $old_fh;
 157
 158         return;
 159     }
 160
 161     sub cp_error {
 162         my $self    = shift;
 163         my $verbose = shift;
 164
 165         ### so you don't want us to print the error? ###
 166         return if defined $verbose && $verbose == 0;
 167
 168         my $old_fh = select $CPANPLUS::Error::ERROR_FH;
 169
 170         ### is only going to be 1 for now anyway ###
 171         ### C::I may not be loaded, so do a can() check first
 172         my $cb      = CPANPLUS::Internals->can('_return_all_objects')
 173                         ? (CPANPLUS::Internals->_return_all_objects)[0]
 174                         : undef;
 175
 176         ### maybe we didn't initialize an internals object (yet) ###
 177         my $debug   = $cb ? $cb->configure_object->get_conf('debug') : 0;
 178         my $msg     =  '['. $self->tag . '] ' . $self->message . "\n";
 179
 180         ### i'm getting this warning in the test suite:
 181         ### Ambiguous call resolved as CORE::warn(), qualify as such or
 182         ### use & at CPANPLUS/Error.pm line 57.
 183         ### no idea where it's coming from, since there's no 'sub warn'
 184         ### anywhere to be found, but i'll mark it explicitly nonetheless
 185         ### --kane
 186         print $debug ? Carp::shortmess($msg) : $msg . "\n";
 187
 188         select $old_fh;
 189
 190         return;
 191     }
 192 }
 193
 194 1;
 195
 196 # Local variables:
 197 # c-indentation-style: bsd
 198 # c-basic-offset: 4
 199 # indent-tabs-mode: nil
 200 # End:
 201 # vim: expandtab shiftwidth=4: