summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/TAP/Object.pm
blob: e9da17f4ff1d66750800ded8f29ac78f5679cd8e (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
package TAP::Object;

use strict;
use warnings;

=head1 NAME

TAP::Object - Base class that provides common functionality to all C<TAP::*> modules

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 SYNOPSIS

    package TAP::Whatever;

    use strict;

    use base 'TAP::Object';

    # new() implementation by TAP::Object
    sub _initialize {
        my ( $self, @args) = @_;
        # initialize your object
        return $self;
    }

    # ... later ...
    my $obj = TAP::Whatever->new(@args);

=head1 DESCRIPTION

C<TAP::Object> provides a default constructor and exception model for all
C<TAP::*> classes.  Exceptions are raised using L<Carp>.

=head1 METHODS

=head2 Class Methods

=head3 C<new>

Create a new object.  Any arguments passed to C<new> will be passed on to the
L</_initialize> method.  Returns a new object.

=cut

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self->_initialize(@_);
}

=head2 Instance Methods

=head3 C<_initialize>

Initializes a new object.  This method is a stub by default, you should override
it as appropriate.

I<Note:> L</new> expects you to return C<$self> or raise an exception.  See
L</_croak>, and L<Carp>.

=cut

sub _initialize {
    return $_[0];
}

=head3 C<_croak>

Raise an exception using C<croak> from L<Carp>, eg:

    $self->_croak( 'why me?', 'aaarrgh!' );

May also be called as a I<class> method.

    $class->_croak( 'this works too' );

=cut

sub _croak {
    my $proto = shift;
    require Carp;
    Carp::croak(@_);
    return;
}

=head3 C<_confess>

Raise an exception using C<confess> from L<Carp>, eg:

    $self->_confess( 'why me?', 'aaarrgh!' );

May also be called as a I<class> method.

    $class->_confess( 'this works too' );

=cut

sub _confess {
    my $proto = shift;
    require Carp;
    Carp::confess(@_);
    return;
}

=head3 C<_construct>

Create a new instance of the specified class.

=cut

sub _construct {
    my ( $self, $class, @args ) = @_;

    $self->_croak("Bad module name $class")
      unless $class =~ /^ \w+ (?: :: \w+ ) *$/x;

    unless ( $class->can('new') ) {
        local $@;
        eval "require $class";
        $self->_croak("Can't load $class: $@") if $@;
    }

    return $class->new(@args);
}

=head3 C<mk_methods>

Create simple getter/setters.

 __PACKAGE__->mk_methods(@method_names);

=cut

sub mk_methods {
    my ( $class, @methods ) = @_;
    for my $method_name (@methods) {
        my $method = "${class}::$method_name";
        no strict 'refs';
        *$method = sub {
            my $self = shift;
            $self->{$method_name} = shift if @_;
            return $self->{$method_name};
        };
    }
}

1;