Commit | Line | Data |
---|---|---|
6aaee015 RGS |
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: |