File Coverage

blib/lib/Collection/Utl/Base.pm
Criterion Covered Total %
statement 62 71 87.3
branch 28 36 77.7
condition n/a
subroutine 22 25 88.0
pod 0 2 0.0
total 112 134 83.5


line stmt bran cond sub pod time code
1             package Collection::Utl::Base;
2              
3             #$Id$
4              
5             =head1 NAME
6              
7             Collection::Utl::Base - abstract class.
8              
9             =head1 SYNOPSIS
10              
11             use Collection::Utl::Base;
12             @Collection::ISA = qw(Collection::Utl::Base);
13              
14             =head1 DESCRIPTION
15              
16             Abstract class.
17              
18             =head1 METHODS
19              
20             =cut
21              
22              
23 5     5   31 use strict;
  5         13  
  5         194  
24 5     5   37 use warnings;
  5         10  
  5         140  
25 5     5   23 use strict;
  5         9  
  5         142  
26 5     5   24 use Carp;
  5         6  
  5         666  
27 5     5   33 use Data::Dumper;
  5         8  
  5         562  
28             require Exporter;
29             @Collection::Utl::Base::ISA = qw(Exporter);
30             @Collection::Utl::Base::EXPORT = qw(attributes);
31             $Collection::Utl::Base::VERSION = '0.01';
32              
33             sub attributes {
34 17     17 0 64 my ($pkg) = caller;
35 5     5   30 no strict;
  5         49  
  5         2090  
36 17         665 croak "Error: attributes() invoked multiple times"
37 17 50       57 if scalar @{"${pkg}::__ATTRIBUTES__"};
38              
39 17         35 @{"${pkg}::__ATTRIBUTES__"} = @_;
  17         72  
40 17         31 my $code = "";
41 17         40 foreach my $attr (@_) {
42 47 50       458 if ( UNIVERSAL::can( $pkg, "$attr" ) ) {
43 0         0 next;
44             }
45 47         113 $code .= _define_accessor( $pkg, $attr );
46             }
47 17 0   0   2400 eval $code;
  0 100   27   0  
  0 0   0   0  
  27 50   1   46  
  27 50   1   157  
  0 100   32   0  
  0 100   26   0  
  1 100   90   4  
  1 100   11   6  
  1 100   8   1  
  1 100   10   6  
  32 100   115   49  
  32 100   10   185  
  26 100   11   43  
  26         120  
  90         141  
  90         360  
  11         19  
  11         63  
  8         15  
  8         57  
  10         17  
  10         56  
  115         173  
  115         9921  
  10         16  
  10         43  
  11         18  
  11         72  
48             }
49              
50             sub _define_accessor {
51 47     47   71 my ( $pkg, $attr ) = @_;
52 47         133 my $code = qq{
53             package $pkg;
54             sub $attr { # Accessor ...
55             my \$self=shift;
56             \@_ ? \$self->{ Var }->{ $attr } = shift : \$self->{ Var }->{ $attr };
57             }
58             };
59 47         144 $code;
60             }
61              
62             sub _deprecated {
63 0     0   0 my $self = shift;
64 0         0 my $new_method = shift;
65 0         0 my ( $old_method, $called_from_str, $called_from_method ) =
66             ( ( caller(1) )[3], ( caller(1) )[2], ( caller(2) )[3] );
67 0         0 print STDERR
68             "called deprecated method $old_method from $called_from_method at line $called_from_str. Use method $new_method instead."
69             ;
70             }
71              
72             sub new {
73 17     17 0 31450 my $class = shift;
74 17 100       78 my $self = ( $#_ == 0 ) ? {} : {@_};
75 17         24 my $stat;
76 17         40 bless( $self, $class );
77 17 100       102 return ( $stat = $self->_init(@_) ) ? $self : $stat;
78             }
79              
80             sub _init {
81 4     4   7 my $self = shift;
82 4         11 return 1;
83             }
84              
85              
86             # Preloaded methods go here.
87              
88             1;
89             __END__