File Coverage

blib/lib/TAP/Object.pm
Criterion Covered Total %
statement 30 35 85.7
branch 6 8 75.0
condition n/a
subroutine 9 10 90.0
pod 2 2 100.0
total 47 55 85.4


line stmt bran cond sub pod time code
1             package TAP::Object;
2              
3 51     51   14215 use strict;
  51         63  
  51         1266  
4 51     51   167 use warnings;
  51         61  
  51         15611  
5              
6             =head1 NAME
7              
8             TAP::Object - Base class that provides common functionality to all C modules
9              
10             =head1 VERSION
11              
12             Version 3.38
13              
14             =cut
15              
16             our $VERSION = '3.38';
17              
18             =head1 SYNOPSIS
19              
20             package TAP::Whatever;
21              
22             use strict;
23              
24             use base 'TAP::Object';
25              
26             # new() implementation by TAP::Object
27             sub _initialize {
28             my ( $self, @args) = @_;
29             # initialize your object
30             return $self;
31             }
32              
33             # ... later ...
34             my $obj = TAP::Whatever->new(@args);
35              
36             =head1 DESCRIPTION
37              
38             C provides a default constructor and exception model for all
39             C classes. Exceptions are raised using L.
40              
41             =head1 METHODS
42              
43             =head2 Class Methods
44              
45             =head3 C
46              
47             Create a new object. Any arguments passed to C will be passed on to the
48             L method. Returns a new object.
49              
50             =cut
51              
52             sub new {
53 3477     3477 1 432106 my $class = shift;
54 3477         6334 my $self = bless {}, $class;
55 3477         14195 return $self->_initialize(@_);
56             }
57              
58             =head2 Instance Methods
59              
60             =head3 C<_initialize>
61              
62             Initializes a new object. This method is a stub by default, you should override
63             it as appropriate.
64              
65             I L expects you to return C<$self> or raise an exception. See
66             L, and L.
67              
68             =cut
69              
70             sub _initialize {
71 95     95   357 return $_[0];
72             }
73              
74             =head3 C<_croak>
75              
76             Raise an exception using C from L, eg:
77              
78             $self->_croak( 'why me?', 'aaarrgh!' );
79              
80             May also be called as a I method.
81              
82             $class->_croak( 'this works too' );
83              
84             =cut
85              
86             sub _croak {
87 22     22   927 my $proto = shift;
88 22         138 require Carp;
89 22         3481 Carp::croak(@_);
90 0         0 return;
91             }
92              
93             =head3 C<_confess>
94              
95             Raise an exception using C from L, eg:
96              
97             $self->_confess( 'why me?', 'aaarrgh!' );
98              
99             May also be called as a I method.
100              
101             $class->_confess( 'this works too' );
102              
103             =cut
104              
105             sub _confess {
106 0     0   0 my $proto = shift;
107 0         0 require Carp;
108 0         0 Carp::confess(@_);
109 0         0 return;
110             }
111              
112             =head3 C<_construct>
113              
114             Create a new instance of the specified class.
115              
116             =cut
117              
118             sub _construct {
119 358     358   787 my ( $self, $class, @args ) = @_;
120              
121 358 50       2210 $self->_croak("Bad module name $class")
122             unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
123              
124 358 100       2764 unless ( $class->can('new') ) {
125 47         57 local $@;
126 47         2971 eval "require $class";
127 47 50       482 $self->_croak("Can't load $class: $@") if $@;
128             }
129              
130 358         1171 return $class->new(@args);
131             }
132              
133             =head3 C
134              
135             Create simple getter/setters.
136              
137             __PACKAGE__->mk_methods(@method_names);
138              
139             =cut
140              
141             sub mk_methods {
142 62     62 1 274 my ( $class, @methods ) = @_;
143 62         151 for my $method_name (@methods) {
144 1099         1266 my $method = "${class}::$method_name";
145 51     51   1175 no strict 'refs';
  51         65  
  51         4001  
146             *$method = sub {
147 20807     20807   827677 my $self = shift;
148 20807 100       37438 $self->{$method_name} = shift if @_;
149 20807         63088 return $self->{$method_name};
150 1099         129705 };
151             }
152             }
153              
154             1;
155