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