/[webpac2]/trunk/lib/WebPAC/Common.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/WebPAC/Common.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1068 - (show annotations)
Tue Nov 27 23:45:28 2007 UTC (16 years, 4 months ago) by dpavlin
File size: 7069 byte(s)
 r1670@llin:  dpavlin | 2007-11-28 00:13:29 +0100
 - WebPAC::Output::Excel

1 package WebPAC::Common;
2 use Exporter 'import';
3 @EXPORT = qw/
4 force_array
5 dump
6 /;
7
8 use warnings;
9 use strict;
10
11 use Log::Log4perl qw/get_logger :levels/;
12 use Time::HiRes qw/time/;
13 use Data::Dump qw/dump/;
14 use File::Spec;
15 use Cwd qw/abs_path/;
16
17 use base qw/Class::Accessor/;
18 __PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
19
20 =head1 NAME
21
22 WebPAC::Common - internal methods called from other WebPAC modules
23
24 =head1 VERSION
25
26 Version 0.05
27
28 =cut
29
30 our $VERSION = '0.05';
31
32 =head1 SYNOPSYS
33
34 This module defines common functions, and is used as base for other, more
35 specific modules.
36
37 my $o = WebPAC::Common->new({
38 log_debug => 1,
39 no_log => 1,
40 debug => 1,
41 });
42
43 Options:
44
45 =over 20
46
47 =item log_debug
48
49 Generate additional debugging log on C<STDERR>
50
51 =item no_log
52
53 Disable all logging (useful for tests)
54
55 =item debug
56
57 Use debugging logger which dumps output only yo C<STDERR>
58
59 =back
60
61
62 =head1 FUNCTIONS
63
64 =head2 progress_bar
65
66 Draw progress bar on STDERR.
67
68 $webpac->progress_bar($current, $max);
69
70 =cut
71
72 sub progress_bar {
73 my $self = shift;
74
75 my ($curr,$max) = @_;
76
77 my $log = $self->_get_logger();
78
79 $self->{last_pcnt_t} ||= time();
80
81 $log->logconfess("no current value!") if (! $curr);
82 $log->logconfess("no maximum value!") if (! $max);
83
84 if ($curr > $max) {
85 $max = $curr;
86 $log->debug("overflow to $curr");
87 }
88
89 $self->{'last_pcnt'} ||= 1;
90 $self->{'start_t'} ||= time();
91
92 my $p = int($curr * 100 / $max) || 1;
93
94 # reset on re-run
95 if ($p < $self->{'last_pcnt'}) {
96 $self->{'last_pcnt'} = $p;
97 $self->{'start_t'} = time();
98 }
99
100 my $t = time();
101
102 if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {
103
104 my $rate = ($curr / ($t - $self->{'start_t'} || 1));
105 my $eta = ($max-$curr) / ($rate || 1);
106 printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
107 $self->{'last_pcnt'} = $p;
108 $self->{'last_curr'} = $curr;
109 $self->{last_pcnt_t} = $t;
110 }
111 print STDERR "\n" if ($p == 100);
112 }
113
114 =head2 fmt_time
115
116 Format time (in seconds) for display.
117
118 print $webpac->fmt_time(time());
119
120 This method is called by L<progress_bar> to display remaining time.
121
122 =cut
123
124 sub fmt_time {
125 my $self = shift;
126
127 my $t = shift || 0;
128 my $out = "";
129
130 my ($ss,$mm,$hh) = gmtime($t);
131 $out .= "${hh}h" if ($hh);
132 $out .= sprintf("%02d:%02d", $mm,$ss);
133 $out .= " " if ($hh == 0);
134 return $out;
135 }
136
137 =head2 fill_in
138
139 Fill in variable names by values
140
141 print $webpac->fill_in( 'foo = $foo bar = $bar',
142 foo => 42, bar => 11,
143 );
144
145 =cut
146
147 sub fill_in {
148 my $self = shift;
149
150 my $format = shift || die "no format?";
151 my $d = {@_};
152
153 foreach my $n ( keys %$d ) {
154 $format =~ s/\$\Q$n\E/$d->{$n}/gs;
155 }
156
157 die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );
158
159 return $format;
160 }
161
162 #
163 #
164 #
165
166 =head2 var_path
167
168 my $path = $self->var_path('data_dir', 'data_file', ... );
169
170 =cut
171
172 my $abs_path;
173
174 sub var_path {
175 my $self = shift;
176
177 if ( ! $abs_path ) {
178 # $abs_path = abs_path( $0 );
179 # $abs_path =~ s!/WebPAC/Common\.pm!!;
180 $abs_path = '/data/webpac2';
181 }
182
183 return File::Spec->catfile($abs_path, 'var', @_);
184 }
185
186 =head1 EXPORTED NETHODS
187
188 =head2 force_array
189
190 my @array = force_array( $ref, sub {
191 warn "reference is undefined!";
192 });
193
194 =cut
195
196 sub force_array {
197 my ( $what, $error ) = @_;
198 my @result;
199 if ( ref( $what ) eq 'ARRAY' ) {
200 @result = @{ $what };
201 } elsif ( defined $what ) {
202 @result = ( $what );
203 } else {
204 $error->() if ref($error) eq 'CODE';
205 }
206 return @result;
207 }
208
209
210 =head1 INTERNAL METHODS
211
212 Here is a quick list of internal methods, mostly useful to turn debugging
213 on them (see L<LOGGING> below for explanation).
214
215 =cut
216
217 =head2 _eval
218
219 Internal function to eval code without C<strict 'subs'>.
220
221 =cut
222
223 sub _eval {
224 my $self = shift;
225
226 my $code = shift || return;
227
228 my $log = $self->_get_logger();
229
230 no strict 'subs';
231 my $ret = eval $code;
232 if ($@) {
233 $log->error("problem with eval code [$code]: $@");
234 }
235
236 $log->debug("eval: ",$code," [",$ret,"]");
237
238 return $ret || undef;
239 }
240
241 =head2 _init_logger
242
243 This function will init C<Log::Log4perl> using provided configuration file.
244
245 $webpac->_init_logger('/path/to/log.conf');
246
247 If no path to configuration file is given, dummy empty configuration
248 will be created. If any mode which inherits from this one is called
249 with C<debug> flag, it will turn logging to debug level.
250
251 This function will also read C<log_conf> value from current object and try
252 to read that as configuration file if it exists, if it doesn't it will
253 fallback to default C<conf/log.conf>.
254
255 You can disable all logging by adding C<no_log> to constructor of WebPAC
256 object. Object in C<Test::Exception> class will disable logging
257 automatically.
258
259 =cut
260
261 sub _init_logger {
262 my $self = shift;
263 my $file = shift;
264 $file ||= $self->{'log_conf'};
265 $file = 'conf/log.conf';
266 my $name = (caller(2))[3] || caller;
267
268 my $conf = q( );
269 if ($self->no_log) {
270 warn "# $name disabled logging\n" if $self->log_debug;
271 $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
272 } elsif ($self->debug) {
273 $conf = << '_log4perl_';
274
275 log4perl.rootLogger=INFO, SCREEN
276
277 log4perl.logger.WebPAC.=DEBUG
278
279 log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
280 log4perl.appender.SCREEN.layout=PatternLayout
281 log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n
282
283 _log4perl_
284 warn "# $name is using debug logger\n" if $self->log_debug;
285 } elsif ($name =~ m/Test::Exception/o) {
286 warn "# disabled logging for Text::Exception\n" if $self->log_debug;
287 } elsif (-e $file) {
288 warn "# $name is using $file logger\n" if $self->log_debug;
289 Log::Log4perl->init($file);
290 return 1;
291 } else {
292 warn "# $name is using null logger\n" if $self->log_debug;
293 }
294 Log::Log4perl->init( \$conf );
295
296 return 1;
297 }
298
299
300 =head2 _get_logger
301
302 Get C<Log::Log4perl> object with a twist: domains are defined for each
303 method
304
305 my $log = $webpac->_get_logger();
306
307 =cut
308
309 my $_logger_seen;
310
311 sub _get_logger {
312 my $self = shift;
313
314 my $name = (caller(1))[3] || caller;
315
316 # make name full
317 my $f = '';
318 if ( $self->log_debug ) {
319 foreach ( 0 .. 5 ) {
320 my $s = (caller($_))[3];
321 $f .= "#### $_ >> $s\n" if ($s);
322 }
323 }
324
325 $self->{'_logger_'} ||= $self->_init_logger;
326
327 my $log = get_logger( $name );
328 warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
329 $_logger_seen->{$name}++;
330 return $log;
331 }
332
333
334 =head2 _log
335
336 Quick cludge to make logging object available to scripts which
337 use webpac line this:
338
339 my $log = _new WebPAC::Common()->_get_logger();
340
341 =cut
342
343 sub _new {
344 my $class = shift;
345 my $self = {@_};
346 bless($self, $class);
347
348 $self ? return $self : return undef;
349 }
350
351 =head1 LOGGING
352
353 Logging in WebPAC is performed by L<Log::Log4perl> with config file
354 C<log.conf>.
355
356 Methods defined above have different levels of logging, so
357 it's descriptions will be useful to turn (mostry B<debug> logging) on
358 or off to see why WabPAC isn't perforing as you expect it (it might even
359 be a bug!).
360
361 B<This is different from normal Log4perl behaviour>. To repeat, you can
362 also use method names, and not only classes (which are just few)
363 to filter logging.
364
365 =cut
366
367 1;

  ViewVC Help
Powered by ViewVC 1.1.26