The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#========================================================================
#
# Badger::Class::Defaults
#
# DESCRIPTION
#   Mixin module implementing functionality for defining defaults for
#   a class and initialising an object from them.
#
# AUTHOR
#   Andy Wardley   <abw@wardley.org>
#
#========================================================================

package Badger::Class::Defaults;

use Carp;
use Badger::Debug ':dump';
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Exporter',
    import    => 'class CLASS',
    words     => 'DEFAULTS',
    constants => 'PKG REFS HASH',
    constant  => {
        INIT_METHOD => 'init_defaults',
    };

sub export {
    my $class    = shift;
    my $target   = shift;
    my $defaults = @_ == 1 ? shift : { @_ };
    my ($key, $uckey);

    croak("Invalid defaults specified: $defaults")
        unless ref $defaults eq HASH;

    no strict REFS;
    
    foreach $key (keys %$defaults) {
        $uckey = uc $key;
        
        # if the package variable is already defined, we use that value
        # otherwise, create a new pacakge variable with the default value.
        if (defined ${ $target.PKG.$uckey }) {
            # alias ${...} into *{...} to make variable visible
            *{ $target.PKG.$uckey } = \${ $target.PKG.$uckey };
        }
        else {
            my $value = $defaults->{ $key };
            *{ $target.PKG.$uckey } = \$value
        }
    }
    *{ $target.PKG.DEFAULTS } = \$defaults
        unless defined ${ $target.PKG.DEFAULTS };

    # calling can() allows a subclass to redefine init_default() 
    *{ $target.PKG.INIT_METHOD } = $class->can(INIT_METHOD);
}

sub init_defaults {
    my ($self, $config) = @_;
    my $class = class($self);

    $self->debug("init_defaults(", CLASS->dump_data_inline($config), ')') if DEBUG;
    
    # Set values from $config or use the default values in package variables
    # created by the 'defaults' class hook.  We use the keys in $DEFAULTS to
    # tell us what to look for, but look for values in package variables
    # rather than using those in the $DEFAULTS hash.  This is to allow a
    # user to pre-defined the package vars to some value other than the
    # default.  It also make inheritance work (i.e. a subclass can define
    # a different $CACHE, for example)
    my $defaults = $class->hash_vars(DEFAULTS);
    CLASS->debug('$DEFAULTS: ', CLASS->dump_data_inline($defaults)) if DEBUG;
    
    foreach my $key (keys %$defaults) {
        $self->{ $key } =
            defined $config->{ $key }
                  ? $config->{ $key }
                  : $class->any_var(uc $key);
        $self->{ $key } = $defaults->{ $key }
            unless defined $self->{ $key };
        CLASS->debug("default: $key => $self->{ $key }\n") if DEBUG;
    }
    
    return $self;
}
    
1;

=head1 NAME

Badger::Class::Default - class mixin for creating parameter defaults

=head1 SYNOPSIS

    package My::Module;
    
    use Badger::Class
        base => 'Badger::Base';
    
    use Badger::Class::Defaults
        username => 'testuser',
        password => 'testpass';
        
    sub init {
        my ($self, $config) = @_;
        $self->init_defaults($config);
        return $self;
    }

=head1 DESCRIPTION

This class mixin module allows you to define default values for configuration
parameters.

It is still experimental and subject to change.

=head1 METHODS

=head2 init_defaults($config)

This method is mixed into classes that use it.  It creates a composite
hash of all C<$DEFAULTS> defined in package variables and updates the 
C<$self> object using values provided explicitly in the C<$config> hash,
or falling back on the C<$DEFAULTS>

See L<Badger::Class> for further details.

=head1 AUTHOR

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

=head1 COPYRIGHT

Copyright (C) 2008 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: