[Summary view] [Print] [Text view]

   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: