This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Updated Object-Accessor to CPAN version 0.44
[perl5.git] / cpan / Object-Accessor / lib / Object / Accessor.pm
1 package Object::Accessor;
2
3 use strict;
4 use Carp            qw[carp croak];
5 use vars            qw[$FATAL $DEBUG $AUTOLOAD $VERSION];
6 use Params::Check   qw[allow];
7
8 ### some objects might have overload enabled, we'll need to
9 ### disable string overloading for callbacks
10 require overload;
11
12 $VERSION    = '0.44';
13 $FATAL      = 0;
14 $DEBUG      = 0;
15
16 use constant VALUE => 0;    # array index in the hash value
17 use constant ALLOW => 1;    # array index in the hash value
18 use constant ALIAS => 2;    # array index in the hash value
19
20 =head1 NAME
21
22 Object::Accessor - interface to create per object accessors
23
24 =head1 SYNOPSIS
25
26     ### using the object
27     $obj = Object::Accessor->new;        # create object
28     $obj = Object::Accessor->new(@list); # create object with accessors
29     $obj = Object::Accessor->new(\%h);   # create object with accessors
30                                          # and their allow handlers
31
32     $bool   = $obj->mk_accessors('foo'); # create accessors
33     $bool   = $obj->mk_accessors(        # create accessors with input
34                {foo => ALLOW_HANDLER} ); # validation
35
36     $bool   = $obj->mk_aliases(          # create an alias to an existing
37                 alias_name => 'method'); # method name
38
39     $clone  = $obj->mk_clone;            # create a clone of original
40                                          # object without data
41     $bool   = $obj->mk_flush;            # clean out all data
42
43     @list   = $obj->ls_accessors;        # retrieves a list of all
44                                          # accessors for this object
45
46     $bar    = $obj->foo('bar');          # set 'foo' to 'bar'
47     $bar    = $obj->foo();               # retrieve 'bar' again
48
49     $sub    = $obj->can('foo');          # retrieve coderef for
50                                          # 'foo' accessor
51     $bar    = $sub->('bar');             # set 'foo' via coderef
52     $bar    = $sub->();                  # retrieve 'bar' by coderef
53
54     ### using the object as base class
55     package My::Class;
56     use base 'Object::Accessor';
57
58     $obj    = My::Class->new;               # create base object
59     $bool   = $obj->mk_accessors('foo');    # create accessors, etc...
60
61     ### make all attempted access to non-existent accessors fatal
62     ### (defaults to false)
63     $Object::Accessor::FATAL = 1;
64
65     ### enable debugging
66     $Object::Accessor::DEBUG = 1;
67
68     ### advanced usage -- callbacks
69     {   my $obj = Object::Accessor->new('foo');
70         $obj->register_callback( sub { ... } );
71
72         $obj->foo( 1 ); # these calls invoke the callback you registered
73         $obj->foo()     # which allows you to change the get/set
74                         # behaviour and what is returned to the caller.
75     }
76
77     ### advanced usage -- lvalue attributes
78     {   my $obj = Object::Accessor::Lvalue->new('foo');
79         print $obj->foo = 1;            # will print 1
80     }
81
82     ### advanced usage -- scoped attribute values
83     {   my $obj = Object::Accessor->new('foo');
84
85         $obj->foo( 1 );
86         print $obj->foo;                # will print 1
87
88         ### bind the scope of the value of attribute 'foo'
89         ### to the scope of '$x' -- when $x goes out of
90         ### scope, 'foo's previous value will be restored
91         {   $obj->foo( 2 => \my $x );
92             print $obj->foo, ' ', $x;   # will print '2 2'
93         }
94         print $obj->foo;                # will print 1
95     }
96
97
98 =head1 DESCRIPTION
99
100 C<Object::Accessor> provides an interface to create per object
101 accessors (as opposed to per C<Class> accessors, as, for example,
102 C<Class::Accessor> provides).
103
104 You can choose to either subclass this module, and thus using its
105 accessors on your own module, or to store an C<Object::Accessor>
106 object inside your own object, and access the accessors from there.
107 See the C<SYNOPSIS> for examples.
108
109 =head1 METHODS
110
111 =head2 $object = Object::Accessor->new( [ARGS] );
112
113 Creates a new (and empty) C<Object::Accessor> object. This method is
114 inheritable.
115
116 Any arguments given to C<new> are passed straight to C<mk_accessors>.
117
118 If you want to be able to assign to your accessors as if they
119 were C<lvalue>s, you should create your object in the
120 C<Object::Accessor::Lvalue> namespace instead. See the section
121 on C<LVALUE ACCESSORS> below.
122
123 =cut
124
125 sub new {
126     my $class   = shift;
127     my $obj     = bless {}, $class;
128
129     $obj->mk_accessors( @_ ) if @_;
130
131     return $obj;
132 }
133
134 =head2 $bool = $object->mk_accessors( @ACCESSORS | \%ACCESSOR_MAP );
135
136 Creates a list of accessors for this object (and C<NOT> for other ones
137 in the same class!).
138 Will not clobber existing data, so if an accessor already exists,
139 requesting to create again is effectively a C<no-op>.
140
141 When providing a C<hashref> as argument, rather than a normal list,
142 you can specify a list of key/value pairs of accessors and their
143 respective input validators. The validators can be anything that
144 C<Params::Check>'s C<allow> function accepts. Please see its manpage
145 for details.
146
147 For example:
148
149     $object->mk_accessors( {
150         foo     => qr/^\d+$/,       # digits only
151         bar     => [0,1],           # booleans
152         zot     => \&my_sub         # a custom verification sub
153     } );
154
155 Returns true on success, false on failure.
156
157 Accessors that are called on an object, that do not exist return
158 C<undef> by default, but you can make this a fatal error by setting the
159 global variable C<$FATAL> to true. See the section on C<GLOBAL
160 VARIABLES> for details.
161
162 Note that you can bind the values of attributes to a scope. This allows
163 you to C<temporarily> change a value of an attribute, and have it's
164 original value restored up on the end of it's bound variable's scope;
165
166 For example, in this snippet of code, the attribute C<foo> will
167 temporarily be set to C<2>, until the end of the scope of C<$x>, at
168 which point the original value of C<1> will be restored.
169
170     my $obj = Object::Accessor->new;
171
172     $obj->mk_accessors('foo');
173     $obj->foo( 1 );
174     print $obj->foo;                # will print 1
175
176     ### bind the scope of the value of attribute 'foo'
177     ### to the scope of '$x' -- when $x goes out of
178     ### scope, 'foo' previous value will be restored
179     {   $obj->foo( 2 => \my $x );
180         print $obj->foo, ' ', $x;   # will print '2 2'
181     }
182     print $obj->foo;                # will print 1
183
184
185 Note that all accessors are read/write for everyone. See the C<TODO>
186 section for details.
187
188 =cut
189
190 sub mk_accessors {
191     my $self    = $_[0];
192     my $is_hash = UNIVERSAL::isa( $_[1], 'HASH' );
193
194     ### first argument is a hashref, which means key/val pairs
195     ### as keys + allow handlers
196     for my $acc ( $is_hash ? keys %{$_[1]} : @_[1..$#_] ) {
197
198         ### already created apparently
199         if( exists $self->{$acc} ) {
200             __PACKAGE__->___debug( "Accessor '$acc' already exists");
201             next;
202         }
203
204         __PACKAGE__->___debug( "Creating accessor '$acc'");
205
206         ### explicitly vivify it, so that exists works in ls_accessors()
207         $self->{$acc}->[VALUE] = undef;
208
209         ### set the allow handler only if one was specified
210         $self->{$acc}->[ALLOW] = $_[1]->{$acc} if $is_hash;
211     }
212
213     return 1;
214 }
215
216 =head2 @list = $self->ls_accessors;
217
218 Returns a list of accessors that are supported by the current object.
219 The corresponding coderefs can be retrieved by passing this list one
220 by one to the C<can> method.
221
222 =cut
223
224 sub ls_accessors {
225     ### metainformation is stored in the stringified
226     ### key of the object, so skip that when listing accessors
227     return sort grep { $_ ne "$_[0]" } keys %{$_[0]};
228 }
229
230 =head2 $ref = $self->ls_allow(KEY)
231
232 Returns the allow handler for the given key, which can be used with
233 C<Params::Check>'s C<allow()> handler. If there was no allow handler
234 specified, an allow handler that always returns true will be returned.
235
236 =cut
237
238 sub ls_allow {
239     my $self = shift;
240     my $key  = shift or return;
241     return exists $self->{$key}->[ALLOW]
242                 ? $self->{$key}->[ALLOW]
243                 : sub { 1 };
244 }
245
246 =head2 $bool = $self->mk_aliases( alias => method, [alias2 => method2, ...] );
247
248 Creates an alias for a given method name. For all intents and purposes,
249 these two accessors are now identical for this object. This is akin to
250 doing the following on the symbol table level:
251
252   *alias = *method
253
254 This allows you to do the following:
255
256   $self->mk_accessors('foo');
257   $self->mk_aliases( bar => 'foo' );
258
259   $self->bar( 42 );
260   print $self->foo;     # will print 42
261
262 =cut
263
264 sub mk_aliases {
265     my $self    = shift;
266     my %aliases = @_;
267
268     while( my($alias, $method) = each %aliases ) {
269
270         ### already created apparently
271         if( exists $self->{$alias} ) {
272             __PACKAGE__->___debug( "Accessor '$alias' already exists");
273             next;
274         }
275
276         $self->___alias( $alias => $method );
277     }
278
279     return 1;
280 }
281
282 =head2 $clone = $self->mk_clone;
283
284 Makes a clone of the current object, which will have the exact same
285 accessors as the current object, but without the data stored in them.
286
287 =cut
288
289 ### XXX this creates an object WITH allow handlers at all times.
290 ### even if the original didnt
291 sub mk_clone {
292     my $self    = $_[0];
293     my $class   = ref $self;
294
295     my $clone   = $class->new;
296
297     ### split out accessors with and without allow handlers, so we
298     ### don't install dummy allow handers (which makes O::A::lvalue
299     ### warn for example)
300     my %hash; my @list;
301     for my $acc ( $self->ls_accessors ) {
302         my $allow = $self->{$acc}->[ALLOW];
303         $allow ? $hash{$acc} = $allow : push @list, $acc;
304
305         ### is this an alias?
306         if( my $org = $self->{ $acc }->[ ALIAS ] ) {
307             $clone->___alias( $acc => $org );
308         }
309     }
310
311     ### copy the accessors from $self to $clone
312     $clone->mk_accessors( \%hash ) if %hash;
313     $clone->mk_accessors( @list  ) if @list;
314
315     ### copy callbacks
316     #$clone->{"$clone"} = $self->{"$self"} if $self->{"$self"};
317     $clone->___callback( $self->___callback );
318
319     return $clone;
320 }
321
322 =head2 $bool = $self->mk_flush;
323
324 Flushes all the data from the current object; all accessors will be
325 set back to their default state of C<undef>.
326
327 Returns true on success and false on failure.
328
329 =cut
330
331 sub mk_flush {
332     my $self = $_[0];
333
334     # set each accessor's data to undef
335     $self->{$_}->[VALUE] = undef for $self->ls_accessors;
336
337     return 1;
338 }
339
340 =head2 $bool = $self->mk_verify;
341
342 Checks if all values in the current object are in accordance with their
343 own allow handler. Specifically useful to check if an empty initialised
344 object has been filled with values satisfying their own allow criteria.
345
346 =cut
347
348 sub mk_verify {
349     my $self = $_[0];
350
351     my $fail;
352     for my $name ( $self->ls_accessors ) {
353         unless( allow( $self->$name, $self->ls_allow( $name ) ) ) {
354             my $val = defined $self->$name ? $self->$name : '<undef>';
355
356             __PACKAGE__->___error("'$name' ($val) is invalid");
357             $fail++;
358         }
359     }
360
361     return if $fail;
362     return 1;
363 }
364
365 =head2 $bool = $self->register_callback( sub { ... } );
366
367 This method allows you to register a callback, that is invoked
368 every time an accessor is called. This allows you to munge input
369 data, access external data stores, etc.
370
371 You are free to return whatever you wish. On a C<set> call, the
372 data is even stored in the object.
373
374 Below is an example of the use of a callback.
375
376     $object->some_method( "some_value" );
377
378     my $callback = sub {
379         my $self    = shift; # the object
380         my $meth    = shift; # "some_method"
381         my $val     = shift; # ["some_value"]
382                              # could be undef -- check 'exists';
383                              # if scalar @$val is empty, it was a 'get'
384
385         # your code here
386
387         return $new_val;     # the value you want to be set/returned
388     }
389
390 To access the values stored in the object, circumventing the
391 callback structure, you should use the C<___get> and C<___set> methods
392 documented further down.
393
394 =cut
395
396 sub register_callback {
397     my $self    = shift;
398     my $sub     = shift or return;
399
400     ### use the memory address as key, it's not used EVER as an
401     ### accessor --kane
402     $self->___callback( $sub );
403
404     return 1;
405 }
406
407
408 =head2 $bool = $self->can( METHOD_NAME )
409
410 This method overrides C<UNIVERAL::can> in order to provide coderefs to
411 accessors which are loaded on demand. It will behave just like
412 C<UNIVERSAL::can> where it can -- returning a class method if it exists,
413 or a closure pointing to a valid accessor of this particular object.
414
415 You can use it as follows:
416
417     $sub = $object->can('some_accessor');   # retrieve the coderef
418     $sub->('foo');                          # 'some_accessor' now set
419                                             # to 'foo' for $object
420     $foo = $sub->();                        # retrieve the contents
421                                             # of 'some_accessor'
422
423 See the C<SYNOPSIS> for more examples.
424
425 =cut
426
427 ### custom 'can' as UNIVERSAL::can ignores autoload
428 sub can {
429     my($self, $method) = @_;
430
431     ### it's one of our regular methods
432     my $code = $self->UNIVERSAL::can($method);
433     if( $code ) {
434         carp( "Can '$method' -- provided by package" ) if $DEBUG;
435         return $code;
436     }
437
438     ### it's an accessor we provide;
439     if( UNIVERSAL::isa( $self, 'HASH' ) and exists $self->{$method} ) {
440         carp( "Can '$method' -- provided by object" ) if $DEBUG;
441         return sub { $self->$method(@_); }
442     }
443
444     ### we don't support it
445     carp( "Cannot '$method'" ) if $DEBUG;
446     return;
447 }
448
449 ### don't autoload this
450 sub DESTROY { 1 };
451
452 ### use autoload so we can have per-object accessors,
453 ### not per class, as that is incorrect
454 sub AUTOLOAD {
455     my $self    = shift;
456     my($method) = ($AUTOLOAD =~ /([^:']+$)/);
457
458     my $val = $self->___autoload( $method, @_ ) or return;
459
460     return $val->[0];
461 }
462
463 sub ___autoload {
464     my $self    = shift;
465     my $method  = shift;
466     my $assign  = scalar @_;    # is this an assignment?
467
468     ### a method on our object
469     if( UNIVERSAL::isa( $self, 'HASH' ) ) {
470         if ( not exists $self->{$method} ) {
471             __PACKAGE__->___error("No such accessor '$method'", 1);
472             return;
473         }
474
475     ### a method on something else, die with a descriptive error;
476     } else {
477         local $FATAL = 1;
478         __PACKAGE__->___error(
479                 "You called '$AUTOLOAD' on '$self' which was interpreted by ".
480                 __PACKAGE__ . " as an object call. Did you mean to include ".
481                 "'$method' from somewhere else?", 1 );
482     }
483
484     ### is this is an alias, redispatch to the original method
485     if( my $original = $self->{ $method }->[ALIAS] ) {
486         return $self->___autoload( $original, @_ );
487     }
488
489     ### assign?
490     my $val = $assign ? shift(@_) : $self->___get( $method );
491
492     if( $assign ) {
493
494         ### any binding?
495         if( $_[0] ) {
496             if( ref $_[0] and UNIVERSAL::isa( $_[0], 'SCALAR' ) ) {
497
498                 ### tie the reference, so we get an object and
499                 ### we can use it's going out of scope to restore
500                 ### the old value
501                 my $cur = $self->{$method}->[VALUE];
502
503                 tie ${$_[0]}, __PACKAGE__ . '::TIE',
504                         sub { $self->$method( $cur ) };
505
506                 ${$_[0]} = $val;
507
508             } else {
509                 __PACKAGE__->___error(
510                     "Can not bind '$method' to anything but a SCALAR", 1
511                 );
512             }
513         }
514
515         ### need to check the value?
516         if( defined $self->{$method}->[ALLOW] ) {
517
518             ### double assignment due to 'used only once' warnings
519             local $Params::Check::VERBOSE = 0;
520             local $Params::Check::VERBOSE = 0;
521
522             allow( $val, $self->{$method}->[ALLOW] ) or (
523                 __PACKAGE__->___error(
524                     "'$val' is an invalid value for '$method'", 1),
525                 return
526             );
527         }
528     }
529
530     ### callbacks?
531     if( my $sub = $self->___callback ) {
532         $val = eval { $sub->( $self, $method, ($assign ? [$val] : []) ) };
533
534         ### register the error
535         $self->___error( $@, 1 ), return if $@;
536     }
537
538     ### now we can actually assign it
539     if( $assign ) {
540         $self->___set( $method, $val ) or return;
541     }
542
543     return [$val];
544 }
545
546 =head2 $val = $self->___get( METHOD_NAME );
547
548 Method to directly access the value of the given accessor in the
549 object. It circumvents all calls to allow checks, callbacks, etc.
550
551 Use only if you C<Know What You Are Doing>! General usage for
552 this functionality would be in your own custom callbacks.
553
554 =cut
555
556 ### XXX O::A::lvalue is mirroring this behaviour! if this
557 ### changes, lvalue's autoload must be changed as well
558 sub ___get {
559     my $self    = shift;
560     my $method  = shift or return;
561     return $self->{$method}->[VALUE];
562 }
563
564 =head2 $bool = $self->___set( METHOD_NAME => VALUE );
565
566 Method to directly set the value of the given accessor in the
567 object. It circumvents all calls to allow checks, callbacks, etc.
568
569 Use only if you C<Know What You Are Doing>! General usage for
570 this functionality would be in your own custom callbacks.
571
572 =cut
573
574 sub ___set {
575     my $self    = shift;
576     my $method  = shift or return;
577
578     ### you didn't give us a value to set!
579     @_ or return;
580     my $val     = shift;
581
582     ### if there's more arguments than $self, then
583     ### replace the method called by the accessor.
584     ### XXX implement rw vs ro accessors!
585     $self->{$method}->[VALUE] = $val;
586
587     return 1;
588 }
589
590 =head2 $bool = $self->___alias( ALIAS => METHOD );
591
592 Method to directly alias one accessor to another for
593 this object. It circumvents all sanity checks, etc.
594
595 Use only if you C<Know What You Are Doing>!
596
597 =cut
598
599 sub ___alias {
600     my $self    = shift;
601     my $alias   = shift or return;
602     my $method  = shift or return;
603
604     $self->{ $alias }->[ALIAS] = $method;
605
606     return 1;
607 }
608
609 sub ___debug {
610     return unless $DEBUG;
611
612     my $self = shift;
613     my $msg  = shift;
614
615     local $Carp::CarpLevel += 1;
616
617     carp($msg);
618 }
619
620 sub ___error {
621     my $self = shift;
622     my $msg  = shift;
623     my $lvl  = shift || 0;
624     local $Carp::CarpLevel += ($lvl + 1);
625     $FATAL ? croak($msg) : carp($msg);
626 }
627
628 ### objects might be overloaded.. if so, we can't trust what "$self"
629 ### will return, which might get *really* painful.. so check for that
630 ### and get their unoverloaded stringval if needed.
631 sub ___callback {
632     my $self = shift;
633     my $sub  = shift;
634
635     my $mem  = overload::Overloaded( $self )
636                 ? overload::StrVal( $self )
637                 : "$self";
638
639     $self->{$mem} = $sub if $sub;
640
641     return $self->{$mem};
642 }
643
644 =head1 LVALUE ACCESSORS
645
646 C<Object::Accessor> supports C<lvalue> attributes as well. To enable
647 these, you should create your objects in the designated namespace,
648 C<Object::Accessor::Lvalue>. For example:
649
650     my $obj = Object::Accessor::Lvalue->new('foo');
651     $obj->foo += 1;
652     print $obj->foo;
653
654 will actually print C<1> and work as expected. Since this is an
655 optional feature, that's not desirable in all cases, we require
656 you to explicitly use the C<Object::Accessor::Lvalue> class.
657
658 Doing the same on the standard C<Object>>Accessor> class would
659 generate the following code & errors:
660
661     my $obj = Object::Accessor->new('foo');
662     $obj->foo += 1;
663
664     Can't modify non-lvalue subroutine call
665
666 Note that C<lvalue> support on C<AUTOLOAD> routines is a
667 C<perl 5.8.x> feature. See perldoc L<perl58delta> for details.
668
669 =head2 CAVEATS
670
671 =over 4
672
673 =item * Allow handlers
674
675 Due to the nature of C<lvalue subs>, we never get access to the
676 value you are assigning, so we can not check it against your allow
677 handler. Allow handlers are therefor unsupported under C<lvalue>
678 conditions.
679
680 See C<perldoc perlsub> for details.
681
682 =item * Callbacks
683
684 Due to the nature of C<lvalue subs>, we never get access to the
685 value you are assigning, so we can not check provide this value
686 to your callback. Furthermore, we can not distinguish between
687 a C<get> and a C<set> call. Callbacks are therefor unsupported
688 under C<lvalue> conditions.
689
690 See C<perldoc perlsub> for details.
691
692
693 =cut
694
695 {   package Object::Accessor::Lvalue;
696     use base 'Object::Accessor';
697     use strict;
698     use vars qw[$AUTOLOAD];
699
700     ### constants needed to access values from the objects
701     *VALUE = *Object::Accessor::VALUE;
702     *ALLOW = *Object::Accessor::ALLOW;
703
704     ### largely copied from O::A::Autoload
705     sub AUTOLOAD : lvalue {
706         my $self    = shift;
707         my($method) = ($AUTOLOAD =~ /([^:']+$)/);
708
709         $self->___autoload( $method, @_ ) or return;
710
711         ### *dont* add return to it, or it won't be stored
712         ### see perldoc perlsub on lvalue subs
713         ### XXX can't use $self->___get( ... ), as we MUST have
714         ### the container that's used for the lvalue assign as
715         ### the last statement... :(
716         $self->{$method}->[ VALUE() ];
717     }
718
719     sub mk_accessors {
720         my $self    = shift;
721         my $is_hash = UNIVERSAL::isa( $_[0], 'HASH' );
722
723         $self->___error(
724             "Allow handlers are not supported for '". __PACKAGE__ ."' objects"
725         ) if $is_hash;
726
727         return $self->SUPER::mk_accessors( @_ );
728     }
729
730     sub register_callback {
731         my $self = shift;
732         $self->___error(
733             "Callbacks are not supported for '". __PACKAGE__ ."' objects"
734         );
735         return;
736     }
737 }
738
739
740 ### standard tie class for bound attributes
741 {   package Object::Accessor::TIE;
742     use Tie::Scalar;
743     use base 'Tie::StdScalar';
744
745     my %local = ();
746
747     sub TIESCALAR {
748         my $class   = shift;
749         my $sub     = shift;
750         my $ref     = undef;
751         my $obj     =  bless \$ref, $class;
752
753         ### store the restore sub
754         $local{ $obj } = $sub;
755         return $obj;
756     }
757
758     sub DESTROY {
759         my $tied    = shift;
760         my $sub     = delete $local{ $tied };
761
762         ### run the restore sub to set the old value back
763         return $sub->();
764     }
765 }
766
767 =back
768
769 =head1 GLOBAL VARIABLES
770
771 =head2 $Object::Accessor::FATAL
772
773 Set this variable to true to make all attempted access to non-existent
774 accessors be fatal.
775 This defaults to C<false>.
776
777 =head2 $Object::Accessor::DEBUG
778
779 Set this variable to enable debugging output.
780 This defaults to C<false>.
781
782 =head1 TODO
783
784 =head2 Create read-only accessors
785
786 Currently all accessors are read/write for everyone. Perhaps a future
787 release should make it possible to have read-only accessors as well.
788
789 =head1 CAVEATS
790
791 If you use codereferences for your allow handlers, you will not be able
792 to freeze the data structures using C<Storable>.
793
794 Due to a bug in storable (until at least version 2.15), C<qr//> compiled
795 regexes also don't de-serialize properly. Although this bug has been
796 reported, you should be aware of this issue when serializing your objects.
797
798 You can track the bug here:
799
800     http://rt.cpan.org/Ticket/Display.html?id=1827
801
802 =head1 BUG REPORTS
803
804 Please report bugs or other issues to E<lt>bug-object-accessor@rt.cpan.orgE<gt>.
805
806 =head1 AUTHOR
807
808 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
809
810 =head1 COPYRIGHT
811
812 This library is free software; you may redistribute and/or modify it
813 under the same terms as Perl itself.
814
815 =cut
816
817 1;