File Coverage

lib/Badger/Class/Vars.pm

Criterion	Covered	Total	%
statement	32	33	96.9
branch	27	34	79.4
condition	3	4	75.0
subroutine	5	5	100.0
pod	2	2	100.0
total	69	78	88.4

#========================================================================
#
# Badger::Class::Vars
#
# DESCRIPTION
#   Class mixin module for adding package variables to a class.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Class::Vars;

use Badger::Debug ':dump';
use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Base Badger::Exporter',
    import    => 'BCLASS',
    constants => 'DELIMITER SCALAR ARRAY HASH REFS PKG',
    utils     => 'is_object',
    messages  => {
        no_target => 'No target class specified to generate variables for',
        no_vars   => 'No vars specified to define',
        bad_vars  => 'Invalid vars specified: %s',
        bad_var   => 'Invalid variable name in vars: %s',
        bad_hash  => 'Invalid hash variable for %s in vars: %s',
        bad_sigil => 'Unrecognised sigil for symbol: %s',
    };


sub export {
    goto &vars if @_ > 2;
}


sub vars {
    my $class  = shift;
    my $target = shift || return $class->error_msg('no_target');
    my $vars   = @_ == 1 ? shift : { @_ };
    my ($symbol, $sigil, $name, $dest, $ref);

    # downgrade $target from a Badger::Class object to a package name
    $target = $target->name
        if is_object(BCLASS, $target);

    # split text string into lisy ref of variable names
    $vars = [ split(DELIMITER, $vars) ]
        unless ref $vars;

    # upgrade a list ref to a hash ref
    $vars = { map { $_ => undef } @$vars }
        if ref $vars eq ARRAY;

    $class->error_msg( bad_vars => $vars )
        unless ref $vars eq HASH;

    $class->error_msg('no_vars')
        unless %$vars;

    $class->debug("Defining vars for $target: ", $class->dump_data($vars))
        if DEBUG;

    # This is a slightly simplified (stricter) version of the equivalent
    # code in vars.pm with a little extra syntactic sugar supported.
    # Unfortunately it's not possible to delegate to vars.pm because
    # it will only export to its caller, and not to a third party package

    while (($symbol, $ref) = each %$vars) {
        no strict REFS;

        # only accept: $WORD @WORD %WORD WORD
        $symbol =~ /^([\$\@\%])?(\w+)$/
            || return $class->error_msg( bad_var => $symbol );
        ($sigil, $name) = ($1 || '$', $2);

        # expand destination to full package name ($Your::Module::WORD)
        $dest = $target.PKG.$name;

        $class->debug("var: $sigil$name => ", $ref || '\\'.$sigil.$dest, "\n")
            if DEBUG;

        if ($sigil eq '$') {
            *$dest = defined $ref
                ? (ref $ref eq SCALAR ? $ref : do { my $copy = $ref; \$copy })
                : \$$dest;
        }
        elsif ($sigil eq '@') {
            *$dest = defined $ref
                ? (ref $ref eq ARRAY ? $ref : [$ref])
                : \@$dest;
        }
        elsif ($sigil eq '%') {
            *$dest = defined $ref
                ? (ref $ref eq HASH
                     ? $ref
                     : return $class->error_msg( bad_hash => $symbol, $ref )
                  )
                : \%$dest;
        }
        else {
            # should never happen
            return $class->error_msg( bad_sigil => $symbol );
        }
    }
}

1;

__END__