File Coverage

lib/Badger/Class.pm

Criterion	Covered	Total	%
statement	436	468	93.1
branch	105	170	61.7
condition	42	75	56.0
subroutine	97	110	88.1
pod	48	48	100.0
total	728	871	83.5

#========================================================================
#
# Badger::Class
#
# DESCRIPTION
#   Module implementing metaclass functionality for composing classes
#   (equivalent to C) and other class-related actions.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Class;

use strict;
use warnings;
use Carp;
use base 'Badger::Exporter';
use constant {
    base_id    => 'Badger',
    BCLASS     => 'Badger::Class',
    FILESYSTEM => 'Badger::Filesystem',
    CONSTANTS  => 'Badger::Constants',
    EXPORTER   => 'Badger::Exporter',
    MIXIN      => 'Badger::Mixin',
    CODECS     => 'Badger::Codecs',
    UTILS      => 'Badger::Utils',
    DEBUGGER   => 'Badger::Debug',
    CONFIG     => 'Badger::Class::Config',
    METHODS    => 'Badger::Class::Methods',
    VARS       => 'Badger::Class::Vars',
    MESSAGES   => 'MESSAGES',
    VERSION    => 'VERSION',
    MIXINS     => 'MIXINS',
    THROWS     => 'THROWS',
    ISA        => 'ISA',
    NO_VALUE   => "You didn't specify a value for the '%s' option",
};
use Badger::Constants
    'DELIMITER SCALAR ARRAY HASH CODE PKG REFS ONCE TRUE FALSE LOADED';
use overload
    '""'     => 'name',
    fallback => 1;

our $VERSION   = 0.01;
our $DEBUG     = 0 unless defined $DEBUG;
our $LOADED    = { };

BEGIN {
    # generate a compile time constant from $DEBUG
    *DEBUG = sub() { $DEBUG };
}

#-----------------------------------------------------------------------
# Methods that we delegate to other modules.  The module name is
# determined by calling the constant method (first argument on RHS
# which is auto-quoted by '=>', e.g. 'METHODS', 'ALIASES') against
# $self, allowing for sub-classes of Badger::Class to define different
# modules for this task.  The second argument on the RHS is the method.
# The methods are generated a little further on in this module.
#-----------------------------------------------------------------------

our $DELEGATES = {
    # note the first argument on RHS is quto-quoted by =>
    accessors    => [ METHODS    => 'accessors'      ],
    codec        => [ CODECS     => 'export_codec'   ],
    codecs       => [ CODECS     => 'export_codecs'  ],
    config       => [ CONFIG     => 'export'         ],
    constants    => [ CONSTANTS  => 'export'         ],
    filesystem   => [ FILESYSTEM => 'export'         ],
    hash_methods => [ METHODS    => 'hash'           ],
    mutators     => [ METHODS    => 'mutators'       ],
    slots        => [ METHODS    => 'slots'          ],
    init_method  => [ METHODS    => 'initialiser'    ],
    auto_can     => [ METHODS    => 'auto_can'       ],
    utils        => [ UTILS      => 'export'         ],
    vars         => [ VARS       => 'vars'           ],
};

*get_methods = \&accessors;
*set_methods = \&mutators;


#-----------------------------------------------------------------------
# Define exportable items and export hooks (see Badger::Exporter)
#-----------------------------------------------------------------------

our $EXPORT_ANY   = ['BCLASS'];
our $EXPORT_FAIL  = \&_export_fail;
our $EXPORT_HOOKS = {
    debug    => [\&_debug_hook, 1],
    dumps    => [\&_dumps_hook, 1],
    map { $_ => \&_export_hook }
    qw(
        base uber mixin mixins version constant constants words vars
        config exports throws messages utils codec codecs filesystem
        hooks methods alias slots accessors mutators get_methods
        set_methods hash_methods init_method auto_can overload as_text
        is_true
    )
};


sub export {
    my ($class, $package, @args) = @_;
    no strict   REFS;
    no warnings ONCE;
    ${ $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) {
                $pkg = $1 if  $pkg =~ /(\w+)$/; # Badger - Badger --> Badger
            } else {
                $pkg =~ s/^${base}:://;         # Badger::X::Y - Badger --> X::Y
            }
            $pkg =~ s/::/./g;                   # X::Y --> X.Y
            lc $pkg;                            # X.Y --> x.y
        };
}


#-----------------------------------------------------------------------
# methods to access symbol table
#-----------------------------------------------------------------------

*pkg = \&name;
sub name       {    $_[0]->{ name    } }
sub symbols    {    $_[0]->{ symbols } }
sub symbol     {    $_[0]->{ symbols }->{ $_[1] } }
sub scalar_ref { *{ $_[0]->{ symbols }->{ $_[1] } || return }{ SCALAR } }
sub array_ref  { *{ $_[0]->{ symbols }->{ $_[1] } || return }{ ARRAY  } }
sub hash_ref   { *{ $_[0]->{ symbols }->{ $_[1] } || return }{ HASH   } }
sub code_ref   { *{ $_[0]->{ symbols }->{ $_[1] } || return }{ CODE   } }
sub glob_ref   { *{ $_[0]->{ symbols }->{ $_[1] } || return }{ GLOB   } }
sub scalar     { ${ scalar_ref(@_) || return } }
sub array      { @{ array_ref(@_)  || return } }
sub hash       { %{ hash_ref(@_)   || return } }

sub import_symbol {
    my ($self, $symbol, $ref) = @_;
    no strict   REFS;
    no warnings ONCE;
    *{ $self->{ name }.PKG.$symbol } = $ref;
}


#-----------------------------------------------------------------------
# methods for accessing class variables that DTRT in subclasses
#-----------------------------------------------------------------------

sub var {
    my $self = shift;
    my $name = shift;
    no strict   REFS;
    no warnings ONCE;

#    _debug("Looking for $self->{ name }", PKG, $name, "  args: ", scalar(@_), " => ", join(', ', @_), "\n");
    return @_
        ? (${ $self->{name}.PKG.$name } = shift)
        :  ${ $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 : [ @_ ];
    my $pkg   = $self->{ name };

    $bases = [ split(DELIMITER, $bases) ]
        unless ref $bases eq ARRAY;

    # add each of $bases to @ISA and autoload it
    foreach my $base (@$bases) {
        no strict REFS;
        next if $pkg->isa($base);
        _debug("Adding $pkg base class $base\n") if DEBUG;
        push @{ $pkg.PKG.ISA }, $base;
        _autoload($base);
    }
    return $self;
}

sub mixin {
    my $self   = shift;
    my $mixins = @_ == 1 ? shift : [ @_ ];

    $mixins = [ split(DELIMITER, $mixins) ]
        unless ref $mixins eq ARRAY;

    foreach my $name (@$mixins) {
#        $name = $target . $name if $name =~ /^::/;
#        $self->debug("mixing $name into $self\n") if $DEBUG;
        _autoload($name)->mixin($self->{ name });
    }

    return $self;
}

sub mixins {
    my $self = shift;
    $self->base(MIXIN);
    $self->{ name }->mixins(@_);
    return $self;

    my $syms   = @_ == 1 ? shift : [ @_ ];
    my $mixins = $self->var_default(MIXINS, [ ]);

    $syms = [ split(DELIMITER, $syms) ]
        unless ref $syms eq ARRAY;

#    $mixins->{ $_ }
    push(@$mixins, @$syms);

    $self->debug("$self MIXINS are: ", $self->dump_data_inline($mixins), "\n") if DEBUG;

    $self->exports( any => $syms );

}

sub version {
    my ($self, $version) = @_;
    my $pkg = $self->{ name };
    no strict 'refs';
    _debug("Defining $pkg version $version\n") if DEBUG;

    # define $VERSION and VERSION()
    *{ $pkg.PKG.VERSION } = \$version
        unless defined ${ $pkg.PKG.VERSION }
                    && ${ $pkg.PKG.VERSION };
    *{ $pkg.PKG.VERSION } = sub() { $version }
        unless defined &{ $pkg.PKG.VERSION };        # CHECK THIS - was 'version'

    return $self;
}

sub constant {
    my $self = shift;
    my $constants = @_ == 1 ? shift : { @_ };
    my $pkg = $self->{ name };

    # split string into pairs of assignments, e.g. "foo=bar, baz=bam"
    $constants = {
        map { split /\s*=>?\s*/ }
        split(DELIMITER, $constants)
    } unless ref $constants eq HASH;


    while (my ($name, $value) = each %$constants) {
        no strict REFS;
        my $v = $value;     # new lexical variable to bind in closure
        _debug("Defining $pkg constant $name => $value\n") if DEBUG;
        *{ $pkg.PKG.$name } = sub() { $value };
    }
    return $self;
}

sub words {
    my $self  = shift;
    my $words = @_ == 1 ? shift : [ @_ ];
    my $pkg   = $self->{ name };

    $words = [ split(DELIMITER, $words) ]
        unless ref $words eq ARRAY;

    foreach (@$words) {
        no strict REFS;
        my $word = $_;  # new lexical variable to bind in closure
        _debug("Defining $pkg word $word\n") if DEBUG;
        *{ $pkg.PKG.$word } = sub() { $word };
    }
    return $self;
}

sub exports {
    my $self = shift;
    my $pkg  = $self->{ name };
    $self->base(EXPORTER);
    $pkg->exports(@_);
    return $self;
}

sub throws {
    my ($self, $throws) = @_;
    $self->import_symbol(THROWS, \$throws);
    return $self;
}

sub messages {
    my $self = shift;
    my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $pkg = $self->{ name };
    no strict   REFS;
    no warnings ONCE;

    # if there aren't any existing $MESSAGES then we can store
    # $messages in it and be done, otherwise we have to merge.
    my $messages = ${ $pkg.PKG.MESSAGES };

    if ($messages) {
        _debug("merging $pkg messages: ", join(', ', keys %$args), "\n") if DEBUG;
        @$messages{ keys %$args } = values %$args;
    }
    else {
        _debug("adding $pkg messages: ", join(', ', keys %$args), "\n") if DEBUG;
        ${ $pkg.PKG.MESSAGES } = $messages = $args;
    }

    return $self;
}

sub method {
    my $self = shift;
    my $name = shift;
    no strict REFS;
    no warnings 'redefine';

    # method($name) can be used to fetch a method/sub
    return $self->{ name }->can($name)
        unless @_;

    # method($name => $code) or $method($name => $value) to define method
    my $code = shift;
    _debug("defining method: $self\::$name => $code\n") if DEBUG;

    *{ $self->{name}.PKG.$name } = ref $code eq CODE
        ? $code
        : sub { $code };        # constant method returns value

    return $self;
}

sub methods {
    my $self = shift;
    my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $pkg  = $self->{ name };
    no strict REFS;
    no warnings 'redefine';

    while (my ($name, $code) = each %$args) {
        _debug("defining method: $self\::$name => $code\n") if DEBUG;
        *{ $pkg.PKG.$name }
            = ref $code eq CODE ? $code : sub { $code };
    }
    return $self;
}

sub alias {
    my $self = shift;
    my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
    my $pkg  = $self->{ name };
    no strict REFS;

    while (my ($names, $code) = each %$args) {
        _debug("defining alias: $self\::$names => $code\n") if DEBUG;
        $code = $self->method($code)
            || croak "Invalid method specified for '$names' alias: $code"
                unless ref $code eq CODE;
        foreach my $name (split(DELIMITER, $names)) {
            *{ $pkg.PKG.$name } = $code;
        }
    }
    return $self;
}

sub overload {
    my $self = shift;
    my $args = @_ && ref $_[0] eq HASH ? shift : { @_ };
    _debug("overload on $self->{name} : { ", join(', ', %$args), " }\n") if DEBUG;
    overload::OVERLOAD($self->{name}, %$args);
    return $self;
}

sub as_text {
    my ($self, $method) = @_;
    $self->overload( '""' => $method, fallback => 1 );
}

sub is_true {
    my ($self, $arg) = @_;
    my $method =
        $arg eq FALSE ? \&FALSE :      # allow 0/1 as shortcut
        $arg eq TRUE  ? \&TRUE  :
        $arg;
    $self->overload( bool => $method, fallback => 1 );
}


#-----------------------------------------------------------------------
# misc methods
#-----------------------------------------------------------------------

sub instance {
    my $self = shift;
    $self->{ name }->new(@_);
}

sub loaded {
    # "loaded" is defined as "has an entry in the symbol table"
    # NOTE: this is incorrect - see comment in _autoload() wrt
    # case-insensitive filesystems
    keys %{ $_[0]->{ symbols } } ? 1 : 0;
}

sub load {
    my $self = shift;
    _autoload($self->{ name }) || return;
    return $self;
}

sub maybe_load {
    my $self = shift;
    return eval { $self->load } || do {
        _debug("maybe_load($self) caught error: $@\n") if DEBUG;
        # Don't confuse "Can't locate Missing/Module/Used/In/Your/Module.pm"
        # messages with "Can't locate Your/Module.pm".  The former is an
        # error that should be reported, the latter isn't.  We convert the
        # class name to a regex that matches any non-word directory separators
        # e.g. Your::Module => Your\W+Module
        my $name = join(
            "\\W+",
            map { quotemeta $_ }
            split('::', $self->{ name })
        );
        _debug("checking to see if we couldn't locate $name\n") if DEBUG;
        croak $@ if $@ && $@ !~ /^Can't locate $name.*? in \@INC/;
        0;
    }
}


#-----------------------------------------------------------------------
# methods for building Badger::Class subclasses
#-----------------------------------------------------------------------

sub uber {
    my ($self, $base) = @_;
    my $pkg = $self->{ name };
    $self->base($base);
    $pkg->UBER;
    return $self;
}

sub hooks {
    my $self  = shift;
    my $args  = @_ == 1 ? shift : { @_ };
    my $hooks = $self->var_default( HOOKS => { } );

    # split string into list ref
    $args = [ split(DELIMITER, $args) ]
        unless ref $args;

    # map list ref to hash ref
    $args = {
        map { $_ => $_ }
        @$args
    } if ref $args eq ARRAY;

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

    _debug("merging $self->{ name } hooks: ", join(', ', keys %$args), "\n") if DEBUG;

    @$hooks{ keys %$args } = values %$args;

    return $self;
}


#-----------------------------------------------------------------------
# autoload($module)
#
# Helper subroutine to autoload a module.
#-----------------------------------------------------------------------

sub _autoload {
    my $class   = shift;
    no strict   REFS;
    no warnings ONCE;
    my $symbols = \%{"${class}::"};

    unless (
            defined ${ $class.PKG.LOADED  }
        ||  scalar(grep { ! /::$/ } keys %$symbols) > 1     # any symbols defined other than import / sub-namespaces
    ) {
        _debug("autoloading $class\n") if DEBUG;
        local $SIG{__DIE__};
        eval "use $class";
        croak $@ if $@;

        # Problem here is that case-insensitive filesystems could load the
        # wrong module.  We could check the symbol table, but it will always
        # have an 'import' entry because 'use' attempts to call import().
        # So we assume a successful module load requires there to be a symbol
        # table with entries other than a single 'import'
        # [later] Oh blimey, it's worse than that.  There may be other
        # sub-namespaces.
        return 0
            if  scalar(grep { ! /::$/ } keys %$symbols) == 1
            &&  exists $symbols->{ import };

        ${ $class.PKG.LOADED } ||= 1;
    }

    return $class;
}

sub _debug {
    print STDERR @_;
}


1;

__END__