File: Class-Prototype.pm
#=====================================================================
1 package Class::Prototype;
#=====================================================================
2 use strict;
3 use warnings; # turn off when you're ready
4 use Carp;
#=====================================================================
# Class::Prototype DATA
#=====================================================================
5 my $VERSION = 0.03;
6 { # keep the methods at Class::Prototype access level
#=====================================================================
# FAMILY WIDE METHODS
#=====================================================================
7 sub new {
8 my ( $caller ) = shift;
9 my ( %arg ) = @_;
10 my $class = ref($caller) || $caller;
11 croak "Class::Prototype is a parent class only. You cannot " .
12 "create Class::Prototypes in it!"
13 if $caller eq 'Class::Prototype';
14 my $ego = bless {}, $class;
# class initialization and object data, see POD for info222
15 $ego->can('attributes')
16 or croak "$class has no attributes method defined! ",
17 "See the Class::Prototype perldoc for details.";
18 $ego->{__attributes} = $ego->attributes();
19 while ( my ( $attr, $val ) = each %{ $ego->{__attributes} } ) {
20 my ( $default, $access ) = @{$val};
21 my $type = ref $default || 'scalar';
22 $type = 'scalar' if $type eq 'Regexp';
23 my ( $method ) = $attr =~ /^_([a-zA-Z]\w*)$/;
24 croak "Bad attribute name, $attr, in attributes ",
25 "(must have an underscore prefix)!\n" unless $method;
26 my $value;
27 if ( $access eq 'readonly') { # only the default
28 $value = $default;
29 }
30 else # if an arg is given, use it, otherwise default
31 {
32 $value = defined $arg{$method} ?
33 $arg{$method} : $default;
34 }
# auto-install method unless the package already defines it
35 $ego->_install_method($method, $access, $type, $value)
36 unless $ego->can($method);
37 }
# Allow children to get in on building the object if they want to do
# more than simple attribute loading
38 $ego->can("new_hook") and $ego->new_hook(@_);
# object is built, methods made, defaults installed so...?
39 delete $ego->{__attributes};
40 return $ego;
41 }
#=====================================================================
42 sub _install_method {
43 my ( $ego, $method, $access, $type, $value ) = @_;
44 my $attr = "_$method";
45 no strict 'refs'; # can't typeglob subs correctly otherwise
46 no warnings; # pointless unitialized warnings
47 print
48 "Installing method: $method()\n",
49 " access: $access\n",
50 " value: ", defined $value ? $value : 'UNDEF',
51 "\n type: $type\n\n" if $ego->verbosity() > 4;
52 if ( $type eq 'scalar' ) {
# SCALARS ------------------------------------------------------------
# ---- attribute is write once or readonly, NOTE *if* CLAUSE AT END
53 *{"$class::$method"} = sub {
54 my($ego,$arg) = @_;
55 if ( defined $ego->{$attr} ) {
# complain if trying to set again
56 carp "You cannot reset $method() (to $arg), skipping!"
57 if defined $arg;
# it's already set, so get
58 return $ego->{$attr};
59 }
60 $ego->{$attr} = $arg;
61 }
62 if $access eq 'writeonce' or $access eq 'readonly';
# ---- attribute is normal, set if given value, get otherwise
63 *{"$class::$method"} = sub {
64 my($ego,$arg) = @_;
65 $ego->{$attr} = $arg if defined $arg;
66 return $ego->{$attr} unless defined $arg;
67 }
68 if $access eq 'write';
# SCALARS ends -------------------------------------------------------
69 }
70 elsif ( $type eq 'ARRAY' ) {
# ARRAYS -------------------------------------------------------------
# ---- regular arrays, shift or return all w/o arg, push w/
71 *{"$class::$method"} = sub {
72 my($ego) = shift;
73 my $args = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
74 unless ( @{$args} ) {
# scalar context: destructive while->next->element; list: get all
75 return wantarray ?
76 @{$ego->{$attr}} : shift(@{$ego->{$attr}});
77 }
78 push(@{$ego->{$attr}}, @{$args});
79 }
80 if $access eq 'write';
# ---- writeonce arrays, initialization is the value
81 *{"$class::$method"} = sub {
82 my($ego) = shift;
83 my $args = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
84 if ( ref $ego->{$attr} and @{$ego->{$attr}} ) {
# complain if trying to set again
85 carp "You cannot add values to $method(), skipping!"
86 if ref $args and @{$args};
# it's already set, so get
87 return wantarray ? @{$ego->{$attr}} : $ego->{$attr};
88 }
89 $ego->{$attr} = $args;
90 }
91 if $access eq 'writeonce';
92 if ( $access eq 'readonly' ) {
93 $ego->{$attr} = $value;
94 *{"$class::$method"} = sub {
95 my($ego) = shift;
96 carp "Disregarded arguments sent to readonly $method()!"
97 if @_;
98 return wantarray ? @{$ego->{$attr}} : $ego->{$attr};
99 };
100 return;
101 }
102 }
# ARRAYS ends -------------------------------------------------------
103 elsif ( $type eq 'HASH' ) {
# HASHES -------------------------------------------------------------
# ---- we want a "keys" method no matter the type ------------------
104 *{"$class::" . "keys_$method"} = sub {
105 my($ego) = shift;
106 return keys %{$ego->{$attr}};
107 };
# ---- regular hashes, set, get by key or return all w/o arg
108 *{"$class::$method"} = sub {
109 my($ego) = shift;
110 my $arg;
111 if ( ref $_[0] eq 'HASH' ) # hasref to set new values
112 {
113 $arg = $_[0];
114 }
115 elsif ( not @_ % 2 ) # plain list in pairs, turn to a hash(ref)
116 {
117 $arg = { @_ };
118 }
119 else # plain arg to get value
120 {
121 return $ego->{$attr}{$_[0]};
122 }
123 unless ( $arg ) {
# no args, so return the full hash
124 return wantarray ?
125 %{$ego->{$attr}} : $ego->{$attr};
126 }
127 while ( my ($key,$value) = each %{$arg} ) {
128 $ego->{$attr}{$key} = $value;
129 }
130 }
131 if $access eq 'write';
# AND!! a delete method to go with it
132 *{"$class::" . "delete_$method"} = sub {
133 my($ego) = shift;
134 my $keys = ref $_[0] eq 'ARRAY' ? $_[0] : @_;
135 for my $key ( @{$keys} ) {
136 delete $ego->{$attr}{$key};
137 }
138 }
139 if $access eq 'write';
# ---- writeonce hashes, initialization is the value -----------------
140 *{"$class::$method"} = sub {
141 my($ego) = shift;
142 my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};
143 print "calling $method with @{$args}\n";
144 if ( ref $ego->{$attr} and %{$ego->{$attr}} ) {
# complain if trying to set again
145 carp "You cannot add values to $method(), skipping!"
146 if ref $args and %{$args};
# it's already set, so get
147 return wantarray ? %{$ego->{$attr}} : $ego->{$attr};
148 }
149 $ego->{$attr} = $args;
150 }
151 if $access eq 'writeonce';
152 if ( $access eq 'readonly' ) {
153 $ego->{$attr} = $value;
154 *{"$class::$method"} = sub {
155 my($ego, @keys) = @_;
156 my @return_list;
157 if ( @keys ) {
158 push @return_list, $ego->{$attr}{$_} for @keys;
159 return wantarray ? @return_list : \@return_list;
160 }
161 return wantarray ? %{$ego->{$attr}} : $ego->{$attr};
162 };
163 return;
164 }
165 }
# HASHES ends -------------------------------------------------------
# if we have been unable to auto install a method 321
166 croak "Non-existent method, '$method,' called!\n"
167 unless $ego->can($method);
# unless $ego->can($method) at this point throw a croak
168 carp
169 "Setting $attr via $method->($value)\n" if $ego->verbosity() > 3;
170 $ego->$method($value);
171 }
#=====================================================================
172 sub show_attributes {
173 my ( $ego ) = @_;
174 return grep defined, map { /^_([a-zA-Z]\w*)$/ } keys %{$ego};
175 }
#=====================================================================
176 sub _standard_attributes {
177 my ( $ego ) = @_;
178 croak "Can't call _standard_attributes() post new()!"
179 unless $ego->{__attributes};
180 keys %{$ego->{__attributes}};
181 }
#=====================================================================
182 sub _default_for {
183 my ( $ego, $attr ) = @_;
184 croak "Can't call _default_for() post new()!"
185 unless $ego->{__attributes};
186 $ego->{__attributes}{$attr}[0];
187 }
#=====================================================================
188 sub _writeable {
189 my ( $ego, $attr ) = @_;
190 $ego->{__attributes}{$attr}[1] eq 'write';
191 }
#=====================================================================
192 sub verbosity {
193 my ( $ego, $verbosity ) = @_;
# 0 (off) through 5 (max, not implemented)
194 return $ego->{__VERBOSITY} unless defined $verbosity;
195 carp "Cannot set verbosity to '$verbosity'!\n"
196 and return
197 unless $verbosity =~ /^[0-5]$/;
198 $ego->{__VERBOSITY} = $verbosity;
199 }
#=====================================================================
200 sub serial {
201 shift if ref($_[0]);
202 return unless @_;
203 join(', ', @_[0..$#_-1]) .
204 (@_>2 ? ',':'' ) .
205 (@_>1 ? (' and ' . $_[-1]) : $_[-1]);
206 }
#=====================================================================
207 sub DESTROY { 1 }
#=====================================================================
208 sub dump {
# erase this i think
209 my ( $ego ) = shift;
210 while ( my ( $key, $value ) = each %{$ego} ) {
211 print "$key --> $value";
212 }
213 }
#=====================================================================
214 }#====================================================================
# Class::Prototype ENDS
#=====================================================================
215 1; # let's eval true, shall we?
#=====================================================================
216 =pod
217 =head1 NAME
218 B<Class::Prototype>
219 =head1 VERSION
220 0.03
221 =head1 ABSTRACT
222 Class::Prototype is an object oriented prototyping base class. It is
223 designed to throw together a module or family of modules quickly by
224 giving self-installed methods defined via the child class's
225 attributes() method. The types of methods which can be self-installed
226 cover 80-90% of what a typical OOP module does. Ie: making a hash
227 based object, installing attributes, and then getting, setting,
228 resetting, stacking, shifting those attributes.
229 Class::Prototype is not really intended for building production code.
230 The use of the code it generates is terse (set/get methods are one in
231 the same) and DWIM (do what I mean -- context determines behavior). As
232 such it will for some users "not do what I expected" and "not work the
233 way I prefer." Class::Prototype code is also generally slower than
234 what you might code up by hand b/c it's installing its own methods as
235 it goes. Class::Prototype is for putting up a scaffolding of prototype
236 code that will work immediately and will be phased completely out as
237 development progresses. Class::Prototype is for jumping in and writing
238 code that works.
239 =head1 SYNOPSIS
240 =head2 Define your new class--must contain attributes()
241 #------------------------------------------------------------
242 package Fish;
243 use base 'Class::Prototype';
244 #------------------------------------------------------------
245 # set some lexical class data
246 my @family = qw( Loricariidae Balistidae Gobiidae
247 Syngnathidae Megachasmidae );
248 my %sizes;
249 @sizes{@family} = qw( medium small small
250 tiny huge );
251 #------------------------------------------------------------
252 # set up the only method required to start coding,
253 # attributes(), which must be defined in this general format
254 sub attributes {
255 {# DEFAULT ACCESS
256 _favorite => [ undef, 'writeonce' ],
257 _current_fish => [ undef, 'write' ],
258 _family => [ \@family, 'readonly' ],
259 _size => [ \%sizes, 'readonly' ],
260 }
261 }
262 #------------------------------------------------------------
263 1; # save it in the @INC path as Fish.pm and we're ready!
264 =head2 Now use it in a script
265 use Fish; # <<-- your new class/module
266 #---------------------------------------------
267 my $fish_obj = Fish->new();
268 # set your favorite fish
269 $fish_obj->favorite("Kuhli Loach");
270 print "Fish Chart:\n";
271 for my $fish ( sort $fish_obj->family ) {
272 printf "%15s --> %s\n",
273 $fish, $fish_obj->size($fish);
274 # keep track of last fish seen here
275 $fish_obj->current_fish($fish);
276 }
277 print "The last fish family I saw was ",
278 $fish_obj->current_fish, ".\n";
279 # try to reset the "writeonce" favorite
280 $fish_obj->favorite("7 Gill Shark");
281 print "My favorite fish is still the ",
282 $fish_obj->favorite, ".\n";
283 And you should get:
284 Fish Chart:
285 Balistidae --> small
286 Gobiidae --> small
287 Loricariidae --> medium
288 Megachasmidae --> huge
289 Syngnathidae --> tiny
290 The last fish family I saw was Syngnathidae.
291 You cannot reset favorite() (to 7 Gill Shark), skipping! at fish line 22
292 My favorite fish is still the Kuhli Loach.
293 =head1 You give, you get
294 attributes() is just a wrapper for a hash reference which describes
295 your object's automated behavior. You can use scalars, arrays and
296 hashes in your object.
297 In your hash ref, you have keys (attributes) which point to 2 element
298 array ref of initialization information. Like so:
299 attribute => [ 'default value', 'access' ],
300 Access can be set to one of the following:
301 =over 5
302 =item * readonly (default/initialization value is only value)
303 =item * writeonce (default, new(key=>'value'), or first !undef write)
304 =item * write (open to change as often as desired)
305 =back
306 Default values can be scalars (undef is acceptable default for a
307 scalar, especially a "writeonce" scalar), array refs, hash refs. So,
308 another sample attributes() method with examples:
309 sub attributes {
310 return { # DEFAULT ACCESS
311 scalar_attr => [ 'default value', 'write' ],
312 scalar_attr2 => [ undef, 'writeonce' ],
313 array_attr => [ [], 'write' ],
314 array_attr2 => [ [ 1 .. 99 ], 'readonly' ],
315 hash_attr => [ { perl => 'rocks',
316 ruby => 'rolls',
317 java => 'hmm...' }, 'readonly' ],
318 hash_attr2 => [ {}, 'write' ]
319 };
320 }
321 =head2 What happens now? Methods are installed
322 Assuming the attribute name is "my_attr," regardless of the default
323 data type or access, the method my_attr() is installed for your object
324 and behaves in the following ways.
325 =over 2
326 =item * default is 'some string' access is 'readonly'
327 my_attr() has only one use. It is called to return the scalar "some
328 string." If given an argument, it will carp() about it and not do
329 anything with it.
330 =item * default is 'some string' access is 'writeonce'
331 my_attr() can set its value one time only. NB: this b<includes>
332 initialization. Therefore given the default of 'some string' it will
333 behave for the user like "readonly." See the next one for the way you
334 want to use this.
335 =item * default is B<undef> access is 'writeonce'
336 my_attr() is not set by the initialization (undef) so the user can set
337 it one time. After that, it's only get. It can be set in new() as
338 well.
339 my $obj = Subclass->new( my_attr => 'my only value' );
340 # or the equivalent
341 my $obj = Subclass->new();
342 $obj->my_attr('my only value');
343 =item * default is 'some string' access is 'write'
344 my_attr() is get/set. Calling it without an arg, like $obj->my_attr(),
345 gets: "some string." Calling it with an arg, like $obj->my_attr('new
346 string'), updates the contents so the next call without an argument
347 will get: "new string."
348 =item * default is ['array','ref'] access is 'readonly'
349 my_attr() is get only. In scalar context it returns the array ref, in
350 list context it dereferences it for you and returns the list. Carps if
351 given arguments.
352 =item * default is ['array','ref'] access is 'writeonce'
353 my_attr() can be passed an array or an array ref to store for future
354 gets once. After it is set, which can be in the call to new(), it
355 behaves as the 'readonly' version above.
356 =item * default is ['array','ref'] access is 'write'
357 my_attr() is get/set, or in this case, return all or shift/push.
358 my @array = $obj->my_attr(); # list context, gets the list
359 my $element = $obj->my_attr(); # scalar, shifts off an element
360 so this would harmless iterate on the array's data
361 for my $element ( $obj->my_attr ) {
362 print $element, "\n";
363 }
364 while this would empty the array one shift at a time:
365 while ( my $element = $obj->my_attr() ) {
366 print $element, "\n";
367 }
368 And adding elements to the list is easy:
369 $obj->my_attr(@elements_to_append);
370 =item * default is a hash ref, any access type
371 keys_my_attr() is installed to get the list of keys to use like so:
372 for my $key ( sort $obj->keys_my_attr ) {
373 print "$key -->> ", $obj->my_attr($key), "\n";
374 }
375 There is no each_my_attr() style function.
376 =item * default is { hash => 'ref' } access is 'readonly'
377 The attributes() hash ref value is the only one possible.
378 keys_my_attr() gets keys, my_attr($key) gets values.
379 =item * default is { hash => 'ref' } access is 'writeonce'
380 I think you get the idea.
381 =item * default is { hash => 'ref' } access is 'write'
382 my_attr( $key => $value ) to set
383 =back
384 =head1 METHODS
385 =head2 Correction, no methods
386 Class::Prototype is a parent class. You cannot create objects in it
387 and you should never directly use its methods.
388 This means you will never do this:
389 use Class::Prototype;
390 You'll always use a subclass of it. Because if you try to do something
391 like
392 my $obj = Class::Prototype->new();
393 You will get a croak along the lines of "Class::Prototype is a parent
394 class only. You cannot create Class::Prototypes in it!"
395 =head2 Subclass methods you start with
396 =over 3
397 =item * my $obj = SubClass->new()
398 Obviously, we need a new() method and one is ready for you. It
399 controls the installation of the object from the attributes() method
400 you need to have in your subclass.
401 If you are worried about being limited by being unable to write your
402 own new(), there is a way to get in on the object initialization. If
403 you have a method called new_hook() in your subclass,
404 =item * $obj->verbosity() or $obj->verbosity($verbosity)
405 Set/get. A verbosity system of 0-5 is set up and used through the
406 method verbosity(). 0 means no extra info, 5 would mean everything. It
407 can be reset on the fly if given a 0-5 value. Implement your own:
408 sub method1 {
409 my ( $self, @args ) = @_;
410 warn "method1() got ", join(', ', @args), ".\n"
411 if $self->verbosity >= 2;
412 #... do the rest of what you came to do
413 }
414 =item * $obj->show_attributes()
415 Returns an unsorted list of keys/attributes in your object but only
416 those keys that start with an underscore and a letter. This is the Class::Prototype
417 way of installing them. Eg, $self->{_touchiness}. If you add your own
418 attributes through hardcoded methods and you don't use this
419 convention, show_attributes() will not return them. So neither
420 $self->{__private_x_2} nor $self->{look_ma} would be found by
421 show_attributes().
422 =back
423 =head2 Initializing the object specially with new_hook()
424 new_hook() is run on the object immediately after it is bless'd and
425 before any methods are installed or default values are set. This means
426 you can define anything into your object you like before the automatic
427 installation runs.
428 Also note that if you have an attribute named xyz in your attributes()
429 but you also create an xyz() method in your subclass, the automatic
430 installation of xyz(), or its related methods, like keys_xyz() and
431 delete_xyz() for hash refs attributes, does not occur. Class::Prototype::new()
432 contains this:
433 # auto-install method unless the package already defines it
434 $ego->_install_method($method, $access, $type, $value)
435 unless $ego->can($method);
436 which does what you'd expect -- skips the method installation if you
437 already defined a method by the same name.
438 This is so that you can drop in methods as you go which will replace
439 the automated ones. You can also take them back out to restore the
440 automatic behavior as long as the attribute remains in your attributes()
441 method.
442 =head1 Setting and getting all in one
443 Any attribute which is defined as "write" is set/get and any attribute
444 defined as "writeonce" is set-once/get.
445 =head2 Subclass POD writer
446 IT SHOULD WRITE ITS OWN POD WITH A COMPANION SCRIPT, to show the
447 methods the child will have. And either put it to STDOUT or append it
448 to the .pm in question.
449 =head1 THANKS
450 Anyone who owns "Object Oriented Perl," Damian Conway, 1884777791,
451 already knows this module is heavily based on techniques therein.
452 Anyone who hasn't dropped Mr. Conway a line just to say, "Thank you
453 for your Perl work and advocacy," should.
454 =head1 COPYRIGHT
455 (c)2002-2003 Ashley Pond V, ashley@cpan.org, all rights reserved;
456 modify and redistribute under the same terms as Perl.
457 =cut