lib/WebPAC/Common.pm

package WebPAC::Common;
use Exporter 'import';
@EXPORT = qw/
        force_array
        dump
/;

use warnings;
use strict;

use Log::Log4perl qw/get_logger :levels/;
use Time::HiRes qw/time/;
use Data::Dump qw/dump/;
use File::Spec;
use Cwd qw/abs_path/;

use base qw/Class::Accessor/;
__PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );

=head1 NAME

WebPAC::Common - internal methods called from other WebPAC modules

=head1 VERSION

Version 0.05

=cut

our $VERSION = '0.05';

=head1 SYNOPSYS

This module defines common functions, and is used as base for other, more
specific modules.

my $o = WebPAC::Common->new({
        log_debug => 1,
        no_log => 1,
        debug => 1,
});

Options:

=over 20

=item log_debug

Generate additional debugging log on C<STDERR>

=item no_log

Disable all logging (useful for tests)

=item debug

Use debugging logger which dumps output only yo C<STDERR>

=back


=head1 FUNCTIONS

=head2 progress_bar

Draw progress bar on STDERR.

 $webpac->progress_bar($current, $max);

=cut

sub progress_bar {
        my $self = shift;

        my ($curr,$max) = @_;

        my $log = $self->_get_logger();

        $self->{last_pcnt_t} ||= time();

        $log->logconfess("no current value!") if (! $curr);
        $log->logconfess("no maximum value!") if (! $max);

        if ($curr > $max) {
                $max = $curr;
                $log->debug("overflow to $curr");
        }

        $self->{'last_pcnt'} ||= 1;
        $self->{'start_t'} ||= time();

        my $p = int($curr * 100 / $max) || 1;

        # reset on re-run
        if ($p < $self->{'last_pcnt'}) {
                $self->{'last_pcnt'} = $p;
                $self->{'start_t'} = time();
        }

        my $t = time();

        if ($p != $self->{'last_pcnt'} || ( $t - $self->{last_pcnt_t} ) > 2 ) {

                my $rate = ($curr / ($t - $self->{'start_t'} || 1));
                my $eta = ($max-$curr) / ($rate || 1);
                printf STDERR ("%5d [%-38s] %-5d %0.1f/s %s\r",$curr,"=" x ($p/3)."$p%>", $max, $rate, $self->fmt_time($eta));
                $self->{'last_pcnt'} = $p;
                $self->{'last_curr'} = $curr;
                $self->{last_pcnt_t} = $t;
        }
        print STDERR "\n" if ($p == 100);
}

=head2 fmt_time

Format time (in seconds) for display.

 print $webpac->fmt_time(time());

This method is called by L<progress_bar> to display remaining time.

=cut

sub fmt_time {
        my $self = shift;

        my $t = shift || 0;
        my $out = "";

        my ($ss,$mm,$hh) = gmtime($t);
        $out .= "${hh}h" if ($hh);
        $out .= sprintf("%02d:%02d", $mm,$ss);
        $out .= "  " if ($hh == 0);
        return $out;
}

=head2 fill_in

Fill in variable names by values

  print $webpac->fill_in( 'foo = $foo bar = $bar',
        foo => 42, bar => 11,
  );

=cut

sub fill_in {
        my $self = shift;

        my $format = shift || die "no format?";
        my $d = {@_};

        foreach my $n ( keys %$d ) {
                $format =~ s/\$\Q$n\E/$d->{$n}/gs;
        }

        die "unknown variables in '$format' input data = ", dump( $d ) if ( $format =~ m/\$\w+/ );

        return $format;
}

#
#
#

=head2 var_path

  my $path = $self->var_path('data_dir', 'data_file', ... );

=cut

my $abs_path;

sub var_path {
        my $self = shift;

        if ( ! $abs_path ) {
#               $abs_path = abs_path( $0 );
#               $abs_path =~ s!/WebPAC/Common\.pm!!;
                $abs_path = '/data/webpac2';
        }

        return File::Spec->catfile($abs_path, 'var', @_);
}

=head1 EXPORTED NETHODS

=head2 force_array

  my @array = force_array( $ref, sub {
        warn "reference is undefined!";
  });

=cut

sub force_array {
        my ( $what, $error ) = @_;
        my @result;
        if ( ref( $what ) eq 'ARRAY' ) {
                @result = @{ $what };
        } elsif ( defined $what ) {
                @result =  ( $what );
        } else {
                $error->() if ref($error) eq 'CODE';
        }
        return @result;
}


=head1 INTERNAL METHODS

Here is a quick list of internal methods, mostly useful to turn debugging
on them (see L<LOGGING> below for explanation).

=cut

=head2 _eval

Internal function to eval code without C<strict 'subs'>.

=cut

sub _eval {
        my $self = shift;

        my $code = shift || return;

        my $log = $self->_get_logger();

        no strict 'subs';
        my $ret = eval $code;
        if ($@) {
                $log->error("problem with eval code [$code]: $@");
        }

        $log->debug("eval: ",$code," [",$ret,"]");

        return $ret || undef;
}

=head2 _init_logger

This function will init C<Log::Log4perl> using provided configuration file.

  $webpac->_init_logger('/path/to/log.conf');

If no path to configuration file is given, dummy empty configuration
will be created. If any mode which inherits from this one is called
with C<debug> flag, it will turn logging to debug level.

This function will also read C<log_conf> value from current object and try
to read that as configuration file if it exists, if it doesn't it will
fallback to default C<conf/log.conf>.

You can disable all logging by adding C<no_log> to constructor of WebPAC
object. Object in C<Test::Exception> class will disable logging
automatically.

=cut

sub _init_logger {
        my $self = shift;
        my $file = shift;
        $file ||= $self->{'log_conf'};
        $file = 'conf/log.conf';
        my $name = (caller(2))[3] || caller;

        my $conf = q( );
        if ($self->no_log) {
                warn "# $name disabled logging\n" if $self->log_debug;
                $Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
        } elsif ($self->debug) {
                $conf = << '_log4perl_';

log4perl.rootLogger=INFO, SCREEN

log4perl.logger.WebPAC.=DEBUG

log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
log4perl.appender.SCREEN.layout=PatternLayout
log4perl.appender.SCREEN.layout.ConversionPattern=%d %p> %F{1}:%L %M - %m%n

_log4perl_
                warn "# $name is using debug logger\n" if $self->log_debug;
        } elsif ($name =~ m/Test::Exception/o) {
                warn "# disabled logging for Text::Exception\n" if $self->log_debug;
        } elsif (-e $file) {
                warn "# $name is using $file logger\n" if $self->log_debug;
                Log::Log4perl->init($file);
                return 1;
        } else {
                warn "# $name is using null logger\n" if $self->log_debug;
        }
        Log::Log4perl->init( \$conf );

        return 1;
}


=head2 _get_logger

Get C<Log::Log4perl> object with a twist: domains are defined for each
method

 my $log = $webpac->_get_logger();

=cut

my $_logger_seen;

sub _get_logger {
        my $self = shift;

        my $name = (caller(1))[3] || caller;

        # make name full
        my $f = '';
        if ( $self->log_debug ) {
                foreach ( 0 .. 5 ) {
                        my $s = (caller($_))[3];
                        $f .= "#### $_ >> $s\n" if ($s);
                }
        }

        $self->{'_logger_'} ||= $self->_init_logger;

        my $log = get_logger( $name );
        warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
        $_logger_seen->{$name}++;
        return $log;
}


=head2 _log

Quick cludge to make logging object available to scripts which
use webpac line this:

  my $log = _new WebPAC::Common()->_get_logger();

=cut

sub _new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        $self ? return $self : return undef;
}

=head1 LOGGING

Logging in WebPAC is performed by L<Log::Log4perl> with config file
C<log.conf>.

Methods defined above have different levels of logging, so
it's descriptions will be useful to turn (mostry B<debug> logging) on
or off to see why WabPAC isn't perforing as you expect it (it might even
be a bug!).

B<This is different from normal Log4perl behaviour>. To repeat, you can
also use method names, and not only classes (which are just few)
to filter logging.

=cut

1;
1	dpavlin	3	package WebPAC::Common;
2	dpavlin	924	use Exporter 'import';
3			@EXPORT = qw/
4			force_array
5	dpavlin	1068	dump
6	dpavlin	924	/;
7	dpavlin	3
8			use warnings;
9			use strict;
10
11	dpavlin	16	use Log::Log4perl qw/get_logger :levels/;
12			use Time::HiRes qw/time/;
13	dpavlin	856	use Data::Dump qw/dump/;
14	dpavlin	887	use File::Spec;
15	dpavlin	942	use Cwd qw/abs_path/;
16	dpavlin	3
17	dpavlin	887	use base qw/Class::Accessor/;
18			__PACKAGE__->mk_accessors( qw/log_debug no_log debug/ );
19	dpavlin	29
20	dpavlin	3	=head1 NAME
21
22			WebPAC::Common - internal methods called from other WebPAC modules
23
24			=head1 VERSION
25
26	dpavlin	887	Version 0.05
27	dpavlin	3
28			=cut
29
30	dpavlin	887	our $VERSION = '0.05';
31	dpavlin	3
32	dpavlin	6	=head1 SYNOPSYS
33	dpavlin	4
34	dpavlin	6	This module defines common functions, and is used as base for other, more
35			specific modules.
36
37	dpavlin	887	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	dpavlin	4	=head1 FUNCTIONS
63
64	dpavlin	9	=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	dpavlin	763	$self->{last_pcnt_t} \|\|= time();
80
81	dpavlin	9	$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	dpavlin	763	my $t = time();
101	dpavlin	9
102	dpavlin	763	if ($p != $self->{'last_pcnt'} \|\| ( $t - $self->{last_pcnt_t} ) > 2 ) {
103
104	dpavlin	9	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	dpavlin	763	$self->{last_pcnt_t} = $t;
110	dpavlin	9	}
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	dpavlin	856	=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	dpavlin	9	#
163			#
164			#
165
166	dpavlin	887	=head2 var_path
167
168			my $path = $self->var_path('data_dir', 'data_file', ... );
169
170			=cut
171
172	dpavlin	942	my $abs_path;
173
174	dpavlin	887	sub var_path {
175			my $self = shift;
176
177	dpavlin	942	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	dpavlin	887	}
185
186	dpavlin	924	=head1 EXPORTED NETHODS
187	dpavlin	887
188	dpavlin	924	=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	dpavlin	3	=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	dpavlin	6	If no path to configuration file is given, dummy empty configuration
248	dpavlin	10	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	dpavlin	6
251	dpavlin	29	This function will also read C<log_conf> value from current object and try
252	dpavlin	31	to read that as configuration file if it exists, if it doesn't it will
253			fallback to default C<conf/log.conf>.
254	dpavlin	29
255	dpavlin	31	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	dpavlin	3	=cut
260
261			sub _init_logger {
262			my $self = shift;
263			my $file = shift;
264	dpavlin	29	$file \|\|= $self->{'log_conf'};
265			$file = 'conf/log.conf';
266			my $name = (caller(2))[3] \|\| caller;
267	dpavlin	10
268	dpavlin	31	my $conf = q( );
269	dpavlin	887	if ($self->no_log) {
270			warn "# $name disabled logging\n" if $self->log_debug;
271	dpavlin	948	$Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK = 0;
272	dpavlin	887	} elsif ($self->debug) {
273	dpavlin	31	$conf = << '_log4perl_';
274
275	dpavlin	10	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	dpavlin	887	warn "# $name is using debug logger\n" if $self->log_debug;
285	dpavlin	73	} elsif ($name =~ m/Test::Exception/o) {
286	dpavlin	887	warn "# disabled logging for Text::Exception\n" if $self->log_debug;
287	dpavlin	73	} elsif (-e $file) {
288	dpavlin	887	warn "# $name is using $file logger\n" if $self->log_debug;
289	dpavlin	31	Log::Log4perl->init($file);
290	dpavlin	73	return 1;
291	dpavlin	31	} else {
292	dpavlin	887	warn "# $name is using null logger\n" if $self->log_debug;
293	dpavlin	3	}
294	dpavlin	31	Log::Log4perl->init( \$conf );
295
296			return 1;
297	dpavlin	3	}
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	dpavlin	632	my $_logger_seen;
310
311	dpavlin	3	sub _get_logger {
312			my $self = shift;
313
314	dpavlin	633	my $name = (caller(1))[3] \|\| caller;
315
316			# make name full
317			my $f = '';
318	dpavlin	887	if ( $self->log_debug ) {
319	dpavlin	633	foreach ( 0 .. 5 ) {
320			my $s = (caller($_))[3];
321			$f .= "#### $_ >> $s\n" if ($s);
322			}
323			}
324
325	dpavlin	29	$self->{'_logger_'} \|\|= $self->_init_logger;
326	dpavlin	3
327	dpavlin	363	my $log = get_logger( $name );
328	dpavlin	887	warn "# get_logger( $name ) level ", $log->level, "\n$f" if ($self->log_debug && !defined($_logger_seen->{$name}));
329	dpavlin	632	$_logger_seen->{$name}++;
330	dpavlin	363	return $log;
331	dpavlin	3	}
332
333
334	dpavlin	254	=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	dpavlin	594	my $class = shift;
345			my $self = {@_};
346	dpavlin	254	bless($self, $class);
347
348			$self ? return $self : return undef;
349			}
350
351	dpavlin	3	=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	dpavlin	632	=cut
366	dpavlin	3
367	dpavlin	632	1;