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