#========================================================================
#
# Badger::Prototype
#
# DESCRIPTION
#   Base class module for a protoype class that has a default instance
#   that can be created on demand.
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
#========================================================================

package Badger::Prototype;

use Badger::Class
    base      => 'Badger::Base',
    version   => 0.01,
    debug     => 0,
    constants => 'PKG REFS ONCE',
    words     => 'PROTOTYPE';

sub prototype {
    my $class = shift;
    return $class if ref $class;
    no strict   REFS;
    no warnings ONCE;
    
    if (@_ == 1 && ! defined $_[0]) {
        # if only a single undef argument is provided, then clear any 
        # prototype from $PROTOTYPE and return a reference to it.
        my $proto = ${$class.PKG.PROTOTYPE};
        undef ${$class.PKG.PROTOTYPE};
        return $proto;
    }
    elsif (@_) {
        # if any other arguments are provided then it forces us to create
        # a new prototype with the fresh configuration options.
        undef ${$class.PKG.PROTOTYPE};
    }
    
    # return the cached value (assuming we didn't just clear it) or create 
    # a new one (if we did, or if there wasn't a previous value)
    return ${$class.PKG.PROTOTYPE} ||= $class->new(@_);
}

sub has_prototype {
    my $self  = shift;
    my $class = ref $self || $self;
    no strict   REFS;
    no warnings ONCE;
    defined ${$class.PKG.PROTOTYPE};
}
    

1;

__END__

=head1 NAME

Badger::Prototype - base class for creating prototype classes

=head1 SYNOPSIS

    package Badger::Example;
    use base 'Badger::Prototype';
    
    sub greeting {
        my $self = shift;
        
        # get prototype object if called as a class method
        $self = $self->prototype() unless ref $self;
        
        # continue as normal, now $self is an object
        if (@_) {
            # set greeting if called with args
            return ($self->{ greeting } = shift);
        }
        else {
            # otherwise get greeting
            return $self->{ greeting };
        }
    }

=head1 DESCRIPTION

This module is a subclass of L<Badger::Base> that additionally provides
the L<prototype()> method.  It is used as a base class for modules that
have methods that can be called as either class or object methods.

    # object method
    my $object = Badger::Example->new();
    $object->greeting('Hello World');

    # class method
    Badger::Example->greeting('Hello World');

The L<prototype()> method returns a singleton object instance which can be 
used as a default object by methods that have been called as class methods. 

Here's an example of a C<greeting()> method that can be called with an argument 
to set a greeting message:

    $object->greeting('Hello World');

Or without any arguments to get the current message:

    print $object->greeting;            # Hello World

As well as being called as an object method, we want to be able to call it
as a class method:

    Badger::Example->greeting('Hello World');
    print Badger::Example->greeting();  # Hello World

Here's what the C<greeting()> method looks like.

    package Badger::Example;
    use base 'Badger::Prototype';
    
    sub greeting {
        my $self = shift;
        
        # get prototype object if called as a class method
        $self = $self->prototype() unless ref $self;
        
        # continue as normal, now $self is an object
        if (@_) {
            # set greeting if called with args
            return ($self->{ greeting } = shift);
        }
        else {
            # otherwise get greeting 
            return $self->{ greeting };
        }
    }

We use C<ref $self> to determine if C<greeting()> has been called as an object
method (C<$self> contains an object reference) or as a class method (C<$self>
contains the class name, in this case C<Badger::Example>). In the latter
case, we call L<prototype()> as a class method (remember, C<$self> contains
the C<Badger::Example> class name at this point) to return a prototype 
object instance which we then store back into C<$self>.

        # get prototype object if called as a class method
        $self = $self->prototype() unless ref $self;

For the rest of the method we can continue as if called as an object 
method because C<$self> now contains a C<Badger::Example> object
either way.

Note that the prototype object reference is stored in the C<$PROTOTYPE>
variable in the package of the calling object's class.  So if you call
prototype on a C<Badger::Example::One> object that is subclassed from 
C<Badger::Prototype> then the prototype object will be stored in the 
C<$Badger::Example::One::PROTOTYPE> package variable.

=head1 METHODS

=head2 prototype(@args)

Constructor method to create a prototype object and cache it in the
C<$PROTOTYPE> package variable for subsequent use.  This is usually 
called from inside methods that can operate as class or object methods, 
as shown in the earlier example.

    sub example {
        my $self = shift;
        
        # upgrade $self to an object when called as a class method
        $self = $self->prototype() unless ref $self;
        
        # ...code follows...
    }

If you prefer a more succint idiom and aren't too worried about calling the
L<prototype> method unneccessarily, then you can write it like this:

    sub greeting {
        my $self = shift->prototype;
        # ...code follows...
    }

If any arguments are passed to the C<prototype()> method then it
forces a new prototype object to be created, replacing any existing
one cached in the C<$PROTOTYPE> package variable.  The arguments are
forwarded to the C<new()> constructor method called to create the
object.

If a single undefined value is passed as an argument then any existing
prototype is released by setting the C<$PROTOTYPE> package variable to 
C<undef>.  The existing prototype is then returned, or undef if there was
no prototype defined.

=head2 has_prototype()

Returns true or false to indicate if a prototype is defined for a class.
It can be called as a class or object method.

=head1 AUTHOR

Andy Wardley L<http://wardley.org/>

=head1 COPYRIGHT

Copyright (C) 2006-2009 Andy Wardley.  All Rights Reserved.

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: