view release on metacpan or  search on metacpan

lib/Badger/Class.pm  view on Meta::CPAN

    ${ $package.PKG.LOADED } ||= 1;     # add $BADGER_LOADED to mark our scent
    $class->SUPER::export($package, @args);
}


sub _export_hook {
    my ($class, $target, $key, $symbols) = @_;

    croak sprintf(NO_VALUE, $key)
        unless @$symbols;

    class($target, $class)->$key(shift @$symbols);
}


sub _export_fail {
    my ($class, $target, $key, $symbols, $import) = @_;

    # look for any additional export hooks defined in $HOOKS, e.g.
    # by a subclass or poked in via the hooks() method
    my $hook = class($class)->hash_value( HOOKS => $key ) || return;

    croak sprintf(NO_VALUE, $key)
        unless @$symbols;

    # We use the two-argument call to class() which tells it that we want
    # a $class metaclass object rather than the default of Badger::Class.
    # This is because subclasses may be calling this method so $class isn't
    # always going to be Badger::Class
    class($target, $class)->$hook(shift @$symbols);
}


sub _debug_hook {
    my ($class, $target, $key, $debug) = @_;
    $debug = { default => $debug }
        unless ref $debug eq HASH;
    _autoload($class->DEBUGGER)->export($target, %$debug);
}

sub _dumps_hook {
    my ($class, $target, $key, $dumps) = @_;
    _autoload($class->DEBUGGER)->export($target, dumps => $dumps);
}



#-----------------------------------------------------------------------
# Define a lexical scope to enclose class lookup tables
#-----------------------------------------------------------------------

# Badger::Class and each of its subclasses have their own metaclass
# table mapping class names to objects.
my $METACLASSES = { };

{
    # class/package name - define this up-front so we can use it below
    sub CLASS {
        # first argument is object or class name, otherwise return caller
        @_ ? (ref $_[0] || $_[0])
           : (caller())[0];
    }

    # Sorry if this messes with your head.  We want class() and classes()
    # methods that create Badger::Class objects.  However, we also want
    # Badger::Class to be subclassable (e.g. Badger::Factory::Class), where
    # class() and classes() return the subclass objects instead of the usual
    # Badger::Class.  So we have an UBER() class method whose job it is to
    # create the class() and classes() methods for the relevant metaclass

    sub UBER {
        # $pkg is the metaclass name, e.g. Badger::Class, but can also be
        # subclasses, e.g. Badger::Factory::Class
        my $pkg = shift || __PACKAGE__;

        # $CLASSES is a lookup table mapping package names to Badger::Class
        # objects.  We need a new lookup table for each subclass of
        # Badger::Class, so we reuse/create such a table in $METACLASSES,
        # indexed by the metaclass name, e.g. Badger::Class, etc.
        my $CLASSES = $METACLASSES->{ $pkg } ||= { };

        # We want to keep the class() subroutine as fast as possible as it
        # gets called often.  It's a tiny bit faster to declare a variable
        # outside the closure and reuse it, rather than defining a new
        # variable each time the closure is called.  Ho hum.
        my $class;

        # The class() subroutine is used to fetch/create a Badger::Class
        # object for a package name.  The first argument is the class name,
        # or the caller's package if undefined and we look it up in $CLASSES.
        # If we get a second argument then we're being asked to lookup an
        # entry for a subclass of Badger::Class, e.g. Badger::Factory::Class,
        # so we first lookup the correct $METACLASS table.
        my $class_sub = sub {
            $class = @_ ? shift : (caller())[0];
            $class = ref $class || $class;
            return @_
                ? $METACLASSES->{ $_[0] }->{ $class } ||= $_[0]->new($class)
                : $CLASSES->{ $class } ||= $pkg->new($class);
        };

        # The classes() method returns a list of Badger::Class objects for
        # each class in the inheritance chain, starting with the object
        # itself, followed by each base class, their base classes, and so on.
        # As with class(), we use a generator to create a closure for the
        # subroutine to allow the the class object name to be parameterised.
        my $classes_sub = sub {
            $class = shift || (caller())[0];
            $class_sub->($class)->heritage;
        };

        no strict REFS;
        no warnings 'redefine';
        *{ $pkg.PKG.'CLASS'     } = \&CLASS;
        *{ $pkg.PKG.'class'     } = $class_sub;
        *{ $pkg.PKG.'bclass'    } = $class_sub;         # plan B
        *{ $pkg.PKG.'classes'   } = $classes_sub;
        *{ $pkg.PKG.'_autoload' } = \&_autoload;

        $pkg->export_any('CLASS', 'class', 'bclass', 'classes');
    }

    # call the UBER method to generate class() and classes() for this module
    __PACKAGE__->UBER;
}



#-----------------------------------------------------------------------
# generate additional delegate methods listed in $DELEGATES
#-----------------------------------------------------------------------

class(CLASS)->methods(
    map {
        my $info = $DELEGATES->{ $_ };
        my ($module, $method) = @$info;
        $_ => sub {
            my $self = shift;
            _autoload($self->$module)->$method($self->{ name }, @_);
            return $self;
        };
    }
    keys %$DELEGATES
);


#-----------------------------------------------------------------------
# constructor method
#-----------------------------------------------------------------------

sub new {
    my ($class, $package) = @_;
    $package = ref $package || $package;
    no strict 'refs';
    bless {
        name    => $package,
        symbols => \%{"${package}::"},
    }, $class;
}

sub id {
    my $self = shift;
    return @_
        ? $self->{ id } = shift
        : $self->{ id } ||= do {
            my $pkg  = $self->{ name };
            my $base = $self->base_id;          # base to remove, e.g. Badger
            if ($base eq $pkg) {

lib/Badger/Class.pm  view on Meta::CPAN

        :  ${ $self->{name}.PKG.$name };
}

sub var_default {
    my ($self, $name, $default) = @_;
    no strict   REFS;
    no warnings ONCE;

    return ${ $self->{name}.PKG.$name }
        ||= $default;
}

sub any_var {
    my $self = shift;
    my $name = shift;
    no strict REFS;

    # remove any leading '$'
    $name =~ s/^\$//;

    foreach my $pkg ($self->heritage) {
        _debug("looking for $name in $pkg\n") if DEBUG;
        return ${ $pkg.PKG.$name } if defined ${ $pkg.PKG.$name };
    }

    return undef;
}

sub any_var_in {
    my $self  = shift;
    my $names = @_ == 1 ? shift : [@_];
    my ($pkg, $name);
    no strict REFS;

    $names = [ split DELIMITER, $names ]
        unless ref $names eq ARRAY;

    # remove any leading '$'
    $names = [ map { s/^\$//; $_ } @$names ];

    foreach $pkg ($self->heritage) {
        foreach $name (@$names) {
            _debug("looking for $name in $pkg\n") if DEBUG;
            return ${ $pkg.PKG.$name } if defined ${ $pkg.PKG.$name };
        }
    }

    return undef;
}

sub all_vars {
    my ($self, $name) = @_;
    my $pkg  = $self->{ name };
    my ($value, @values);
    no strict   REFS;
    no warnings ONCE;

    # remove any leading '$'
    $name =~ s/^\$//;

#    _debug("all_vars() caller: ", join(', ', caller()), "\n");

    foreach my $pkg ($self->heritage) {
        _debug("looking for $name in ", $pkg || "UNDEF", "\n") if DEBUG;
        push(@values, $value)
            if defined ($value = ${ $pkg.PKG.$name });
        _debug("got: $value\n") if DEBUG && $value;
    }

    return wantarray ? @values : \@values;

}

sub list_vars {
    my $self = shift;               # must remove these from @_ here
    my $name = shift;
    my $vars = $self->all_vars($name);
    my (@merged, $list);

    # remove any leading '$'
    $name =~ s/^\$//;

    foreach $list (@_, @$vars) {    # use whatever is left in @_ here
        next unless defined $list;
        if (ref $list eq ARRAY) {
            next unless @$list;
            push(@merged, @$list);
        }
        else {
            push(@merged, $list);
        }
    }

#    return \@merged;

    # NOTE TO SELF: this causes problems when doing something like
    # foo( something_that_calls_list_vars() ) because list_vars assumed
    # list context when we actually want a scalar ref.  Must find where
    # this is and fix it.
    return wantarray ? @merged : \@merged;

}

sub hash_vars {
    my $self = shift;               # must remove these from @_ here
    my $name = shift;
    my $vars = $self->all_vars($name);
    my (%merged, $hash);

    # remove any leading '$'
    $name =~ s/^\$//;

    # reverse the package vars so we get base classes first, followed by subclass,
    # then we add any additional arguments on as well in the order specified
    foreach $hash ( reverse(@$vars), @_ ) {
        next unless defined $hash;
        unless (ref $hash eq HASH) {
            warn "Ignoring $name configuration option (not a hash ref): $hash\n";
            next;
        }
        @merged{ keys %$hash } = values %$hash;
    }

    return \%merged;
}

sub hash_value {
    my ($self, $name, $item, $default) = @_;

    # remove any leading '$'
    $name =~ s/^\$//;

#    _debug("hash_value() caller: ", join(', ', caller()), "\n");

    foreach my $hash ($self->all_vars($name)) {
        next unless ref $hash eq HASH;
        return $hash->{ $item }
            if defined $hash->{ $item };
    }

    return $default;
}


#-----------------------------------------------------------------------
# Methods to return immediate parent classes and all ancestor classes.
#-----------------------------------------------------------------------

sub parents {
    my $self    = shift;
    my $class   = ref $self || $self;
    my $pkg     = $self->{ name };
    my $parents = $self->{ parents } ||= do {
        no strict REFS;

        # make sure the module is loaded before we go looking at its @ISA
        _autoload($pkg);
        [
            map { class($_) }               # parents are immediate
            @{ $pkg.PKG.ISA }               # superclasses defined in @ISA
        ];
    };

    return wantarray
        ? @$parents
        :  $parents;
}

sub heritage {
    my $self     = shift;
    my $heritage = $self->{ heritage } ||= do {
        my @pending = ($self);
        my (%seen, $item, @order);
        while (@pending) {
            next unless defined ($item = pop @pending);
            unshift(@order, $item);
            push(@pending, reverse @{ $item->parents });
        }
        [ reverse grep { ! $seen{$_}++ } @order ];
    };
    return wantarray
        ? @$heritage
        :  $heritage;
}


#-----------------------------------------------------------------------
# class configuration methods - also available as import hooks
#-----------------------------------------------------------------------

sub base {
    my $self  = shift;
    my $bases = @_ == 1 ? shift : [ @_ ];