1package KinoSearch1::Util::Class;
2use strict;
3use warnings;
4use KinoSearch1::Util::ToolSet;
5
6use KinoSearch1::Util::VerifyArgs qw( verify_args kerror );
7
8sub new {
9    my $class = shift;    # leave the rest of @_ intact.
10
11    # find a defaults hash and verify args
12    $class = ref($class) || $class;
13    my $defaults;
14    {
15        no strict 'refs';
16        $defaults = \%{ $class . '::instance_vars' };
17    }
18    if ( !verify_args( $defaults, @_ ) ) {
19        # if a user-based subclass, find KinoSearch1 parent class and verify.
20        my $kinoclass = _traverse_at_isa($class);
21        confess kerror() unless $kinoclass;
22        {
23            no strict 'refs';
24            $defaults = \%{ $kinoclass . '::instance_vars' };
25        }
26        confess kerror() unless verify_args( $defaults, @_ );
27    }
28
29    # merge var => val pairs into new object, call customizable init routine
30    my $self = bless { %$defaults, @_ }, $class;
31    $self->init_instance;
32
33    return $self;
34}
35
36# Walk @ISA until a parent class starting with 'KinoSearch1::' is found.
37sub _traverse_at_isa {
38    my $orig = shift;
39    {
40        no strict 'refs';
41        my $at_isa = \@{ $orig . '::ISA' };
42        for my $parent (@$at_isa) {
43            return $parent if $parent =~ /^KinoSearch1::/;
44            my $grand_parent = _traverse_at_isa($parent);
45            return $grand_parent if $grand_parent;
46        }
47    };
48    return '';
49}
50
51sub init_instance { }
52
53sub init_instance_vars {
54    my $package = shift;
55
56    no strict 'refs';
57    no warnings 'once';
58    my $first_isa = ${ $package . '::ISA' }[0];
59    %{ $package . '::instance_vars' }
60        = ( %{ $first_isa . '::instance_vars' }, @_ );
61}
62
63sub ready_get_set {
64    ready_get(@_);
65    ready_set(@_);
66}
67
68sub ready_get {
69    my $package = shift;
70    no strict 'refs';
71    for my $member (@_) {
72        *{ $package . "::get_$member" } = sub { return $_[0]->{$member} };
73    }
74}
75
76sub ready_set {
77    my $package = shift;
78    no strict 'refs';
79    for my $member (@_) {
80        *{ $package . "::set_$member" } = sub { $_[0]->{$member} = $_[1] };
81    }
82}
83
84=for Rationale:
85KinoSearch1 is not thread-safe.  Among other things, the C-struct-based classes
86cause segfaults or bus errors when their data gets double-freed by DESTROY.
87Therefore, CLONE dies with a user-friendly error message before that happens.
88
89=cut
90
91sub CLONE {
92    my $package = shift;
93    die(      "CLONE invoked by package '$package', indicating that threads "
94            . "or Win32 fork were initiated, but KinoSearch1 is not thread-safe"
95    );
96}
97
98sub abstract_death {
99    my ( undef, $filename, $line, $methodname ) = caller(1);
100    die "ERROR: $methodname', called at $filename line $line, is an "
101        . "abstract method and must be defined in a subclass";
102}
103
104sub unimplemented_death {
105    my ( undef, $filename, $line, $methodname ) = caller(1);
106    die "ERROR: $methodname, called at $filename line $line, is "
107        . "intentionally unimplemented in KinoSearch1, though it is part "
108        . "of Lucene";
109}
110
111sub todo_death {
112    my ( undef, $filename, $line, $methodname ) = caller(1);
113    die "ERROR: $methodname, called at $filename line $line, is not "
114        . "implemented yet in KinoSearch1, but is on the todo list";
115}
116
1171;
118
119__END__
120
121==begin devdocs
122
123==head1 NAME
124
125KinoSearch1::Util::Class - class building utility
126
127==head1 SYNOPSIS
128
129    package KinoSearch1::SomePackage::SomeClass;
130    use base qw( KinoSearch1::Util::Class );
131
132    BEGIN {
133        __PACKAGE__->init_instance_vars(
134            # constructor params / members
135            foo => undef,
136            bar => {},
137
138            # members
139            baz => {},
140        );
141    }
142
143==head1 DESCRIPTION
144
145KinoSearch1::Util::Class is a class-building utility a la
146L<Class::Accessor|Class::Accessor>, L<Class::Meta|Class::Meta>, etc.  It
147provides four main services:
148
149==over
150
151==item 1
152
153A mechanism for inheriting instance variable declarations.
154
155==item 2
156
157A constructor with basic argument checking.
158
159==item 3
160
161Manufacturing of get_xxxx and set_xxxx methods.
162
163==item 4
164
165Convenience methods which help in defining abstract classes.
166
167==back
168
169==head1 VARIABLES
170
171==head2 %instance_vars
172
173The %instance_vars hash, which is always a package global, serves as a
174template for the creation of a hash-based object.  It is built up from all the
175%instance_vars hashes in the module's parent classes, using
176init_instance_vars().
177
178Key-value pairs in an %instance_vars hash are labeled as "constructor params"
179and/or "members".  Items which are labeled as constructor params can be used
180as arguments to new().
181
182    BEGIN {
183        __PACKAGE__->init_instance_vars(
184            # constructor params / members
185            foo => undef,
186            bar => 10,
187            # members
188            baz => '',
189        );
190    }
191
192    # ok: specifies foo, uses default for bar, derives baz
193    my $object = __PACKAGE__->new( foo => $foo );
194
195    # not ok: baz isn't a constructor param
196    my $object = __PACKAGE__->new( baz => $baz );
197
198    # ok if a parent class defines boffo as a constructor param
199    my $object = __PACKAGE__->new(
200        foo   => $foo,
201        boffo => $boffo,
202    );
203
204%instance_vars may only contain scalar values, as the defaults are merged
205into the object using a shallow copy.
206
207init_instance_vars() must be called from within a BEGIN block and before any
208C<use> directives load a child class -- if children are born before their
209parents, inheritance gets screwed up.
210
211==head1 METHODS
212
213==head2 new
214
215A generic constructor with basic argument checking.  new() expects hash-style
216labeled parameters; the label names must be present in the %instance_vars
217hash, or it will croak().
218
219After verifying the labeled parameters, new() merges %instance_vars and @_
220into a new object.  It then calls $self->init_instance() before returning the
221blessed reference.
222
223==head2 init_instance
224
225    $self->init_instance();
226
227Perform customized initialization routine.  By default, this is a no-op.
228
229==head2 init_instance_vars
230
231    BEGIN {
232        __PACKAGE__->init_instance_vars(
233            a_safe_variable_name_that_wont_clash => 1,
234            freep_warble                         => undef,
235        );
236    }
237
238Package method only.  Creates a package global %instance_vars hash in the
239passed in package which consists of the passed in arguments plus all the
240key-value pairs in the parent class's %instance_vars hash.
241
242==head2 ready_get_set ready_get ready_set
243
244    # create get_foo(), set_foo(), get_bar(), set_bar() in __PACKAGE__
245    BEGIN { __PACKAGE__->ready_get_set(qw( foo bar )) };
246
247Mass manufacture getters and setters.  The setters do not return a meaningful
248value.
249
250==head2 abstract_death unimplemented_death todo_death
251
252    sub an_abstract_method      { shift->abstract_death }
253    sub an_unimplemented_method { shift->unimplemented_death }
254    sub maybe_someday           { shift->todo_death }
255
256These are just different ways to die(), and are of little interest until your
257particular application comes face to face with one of them.
258
259abstract_death indicates that a method must be defined in a subclass.
260
261unimplemented_death indicates a feature/function that will probably not be
262implemented.  Typically, this would appear for a sub that a developer
263intimately familiar with Lucene would expect to find.
264
265todo_death indicates a feature that might get implemented someday.
266
267==head1 COPYRIGHT
268
269Copyright 2005-2010 Marvin Humphrey
270
271==head1 LICENSE, DISCLAIMER, BUGS, etc.
272
273See L<KinoSearch1> version 1.01.
274
275==end devdocs
276==cut
277
278