File Coverage

blib/lib/Log/Agent/Tag/Callback.pm
Criterion Covered Total %
statement 26 30 86.6
branch 4 8 50.0
condition 1 3 33.3
subroutine 5 5 100.0
pod 1 3 33.3
total 37 49 75.5


line stmt bran cond sub pod time code
1             ###########################################################################
2             #
3             # Callback.pm
4             #
5             # Copyright (C) 1999 Raphael Manfredi.
6             # Copyright (C) 2002-2015 Mark Rogaski, mrogaski@cpan.org;
7             # all rights reserved.
8             #
9             # See the README file included with the
10             # distribution for license information.
11             #
12             ##########################################################################
13              
14 1     1   550 use strict;
  1         2  
  1         43  
15              
16             ########################################################################
17             package Log::Agent::Tag::Callback;
18              
19             require Log::Agent::Tag;
20 1     1   5 use vars qw(@ISA);
  1         1  
  1         332  
21             @ISA = qw(Log::Agent::Tag);
22              
23             #
24             # ->make
25             #
26             # Creation routine.
27             #
28             # Calling arguments: a hash table list.
29             #
30             # The keyed argument list may contain:
31             # -POSTFIX whether to postfix log message or prefix it.
32             # -SEPARATOR separator string to use between tag and message
33             # -NAME tag's name (optional)
34             # -CALLBACK Callback object
35             #
36             # Attributes:
37             # callback the Callback object
38             #
39             sub make {
40 2     2 0 48 my $self = bless {}, shift;
41 2         5 my (%args) = @_;
42 2         4 my ($name, $postfix, $separator, $callback);
43              
44 2         8 my %set = (
45             -name => \$name,
46             -callback => \$callback,
47             -postfix => \$postfix,
48             -separator => \$separator,
49             );
50              
51 2         9 while (my ($arg, $val) = each %args) {
52 3         4 my $vset = $set{lc($arg)};
53 3 50       7 next unless ref $vset;
54 3         12 $$vset = $val;
55             }
56              
57 2 50       5 unless (defined $callback) {
58 0         0 require Carp;
59 0         0 Carp::croak("Argument -callback is mandatory");
60             }
61              
62 2 50 33     17 unless (ref $callback && $callback->isa("Callback")) {
63 0         0 require Carp;
64 0         0 Carp::croak("Argument -callback needs a Callback object");
65             }
66              
67 2         9 $self->_init($name, $postfix, $separator);
68 2         3 $self->{callback} = $callback;
69              
70 2         8 return $self;
71             }
72              
73             #
74             # Attribute access
75             #
76              
77 3     3 0 11 sub callback { $_[0]->{callback} }
78              
79             #
80             # Defined routines
81             #
82              
83             #
84             # ->string -- defined
85             #
86             # Build tag string by invoking callback.
87             #
88             sub string {
89 3     3 1 5 my $self = shift;
90              
91             #
92             # Avoid recursion, which could happen if another logxxx() call is made
93             # whilst within the callback.
94             #
95             # Assumes mono-threaded application.
96             #
97              
98 3 50       8 return sprintf 'callback "%s" busy', $self->name if $self->{busy};
99              
100 3         5 $self->{busy} = 1;
101 3         7 my $string = $self->callback->call();
102 3         58 $self->{busy} = 0;
103              
104 3         7 return $string;
105             }
106              
107             1; # for "require"
108             __END__