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 53     53   193244 use strict;
  53         128  
  53         1558  
4 53     53   321 use warnings;
  53         127  
  53         22535  
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.40_01
13              
14             =cut
15              
16             our $VERSION = '3.40_01';
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 3518     3518 1 981093 my $class = shift;
54 3518         11658 my $self = bless {}, $class;
55 3518         22866 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   604 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   2026 my $proto = shift;
88 22         209 require Carp;
89 22         5045 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 368     368   1665 my ( $self, $class, @args ) = @_;
120              
121 368 50       4047 $self->_croak("Bad module name $class")
122             unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;
123              
124 368 100       4861 unless ( $class->can('new') ) {
125 50         140 local $@;
126 50         3839 eval "require $class";
127 50 50       590 $self->_croak("Can't load $class: $@") if $@;
128             }
129              
130 368         2209 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 64     64 1 462 my ( $class, @methods ) = @_;
143 64         287 for my $method_name (@methods) {
144 1133         3003 my $method = "${class}::$method_name";
145 53     53   449 no strict 'refs';
  53         147  
  53         7008  
146             *$method = sub {
147 21029     21029   1525808 my $self = shift;
148 21029 100       67411 $self->{$method_name} = shift if @_;
149 21029         132716 return $self->{$method_name};
150 1133         177528 };
151             }
152             }
153              
154             1;
155