File Coverage

blib/lib/classes.pm

Criterion	Covered	Total	%
statement	501	764	65.5
branch	188	348	54.0
condition	71	160	44.3
subroutine	38	72	52.7
pod	14	14	100.0
total	812	1358	59.7

package classes;

# $Id: classes.pm 147 2008-03-08 16:04:33Z rmuhle $

our $VERSION = '0.944';
use 5.006_001;
use Scalar::Util 'reftype', 'blessed';    # standard from 5.8.1

# keep false alarms quiet
use strict; no strict 'refs'; no warnings;

sub classes (@); *define = \&classes::classes;
sub load;

# fastest PERL_VERSION constant (from Schwern's CLASS module)
BEGIN{ *PERL_VERSION = eval "sub () { $] } " }

# do not change
$classes::ok_class_name
    = qr/^(?!(?:
            B$|                            # binary module
            _$
           )
        )
    (?i:(?:[a-z_]\w*\:\:)*[a-z_]\w*)$/xo;
$classes::ok_attr_name = qr/^(?i:[a-z_]\w*)$/xo;

# this one changable via tag
$classes::def_base_exception = 'X::classes::traceable';

######################################################################

sub import {
    my $package = shift;
    my (@class_declarations, $dynamic);
    my $caller = caller;

    # use classes DECLARATION;
    if ( !ref $_[0] ) {
        push @_, 1 if @_ == 1;
        push @class_declarations, {@_};
    }

    # use classes {DECLARATION}, {DECLARATION};
    else {
        @class_declarations = @_;
    }

    # implied name
    map { $_->{'caller'} = $caller } @class_declarations;

    classes::classes(@class_declarations);

    return $package;
}

######################################################################
# Called by import() itself to define classes at compile-time.
# Exported into anything that calls 'use classes'.
sub classes (@) {
    my @args = @_;
    my $tags;

    # classes { DECLARATION };
    if ( ref $args[0] eq 'HASH' ) {
        $tags = $args[0];
        map { classes $_ } @args if @args > 1; # recurse
    }

    # classes DECLARATION;
    elsif ( @args > 1 ) {
        $tags = {@args};
    }

    #-----------------------------------------------------------------

    my ($class,          $type,           $inherits,      $extends,
        $throws,         $exceptions,     $attrs,         $methods,
        $class_attrs,    $class_attrs_ro, $class_methods, $attrs_ro,
        $new_m,          $init_m,         $clone_m,       $caller,
        $mixes,          $mixes_def,      $class_mixes,   $dump_m,
        $base_exception, $unqualified,    $pkg_mixes,     $needs,
        $pkg_methods,    $needs,          $attrs_pr,      $justahash,
        $class_attrs_pr, $noaccessors,    $def_base_exception,
    );

    my $lookup = {
        caller               => \$caller,
        name                 => \$class,
        attrs                => \$attrs,
        attrs_ro             => \$attrs_ro,
        attrs_pr             => \$attrs_pr,
        class_attrs          => \$class_attrs,
        class_attrs_ro       => \$class_attrs_ro,
        class_attrs_pr       => \$class_attrs_pr,
        mixes                => \$mixes,
        class_mixes          => \$class_mixes,
        pkg_mixes            => \$pkg_mixes,
        mixes_def            => \$mixes_def,
        methods              => \$methods,
        class_methods        => \$class_methods,
        pkg_methods          => \$pkg_methods,
        throws               => \$throws,
        needs                => \$needs,
        extends              => \$extends,
        inherits             => \$inherits,
        type                 => \$type,
        exceptions           => \$exceptions,
        base_exception       => \$base_exception,
        new                  => \$new_m,
        init                 => \$init_m,
        clone                => \$clone_m,
        dump                 => \$dump_m,
        def_base_exception   => \$def_base_exception,
        unqualified          => \$unqualified,
        noaccessors          => \$noaccessors,
        justahash            => \$justahash,
    };

    while ( my ( $tag, $val ) = each %$tags ) {
        my $ref = $lookup->{$tag}
            or X::Usage->throw( "$tag ??" );
        $$ref = $val;
    }

    $class ||= $caller || caller;
    X::InvalidName->throw("name=>'$class'")
        if $class !~ $classes::ok_class_name; # main ok

    #-----------------------------------------------------------------
    # add CLASS and $CLASS constants (from Michael Schwern's CLASS)

    my $const_CLASS = $class . '::CLASS';
    if (!$$const_CLASS) {
        *$const_CLASS = \$class;
        if ( PERL_VERSION >= 5.008 ) {
            *$const_CLASS = sub () {$class};
        }
        else {
            *$const_CLASS = eval " sub () { q[$class] } ";
        }
    }

    #-----------------------------------------------------------------

    my $class_decl = $class . '::DECL';
    if (!*$class_decl{CODE}) {
        $$class_decl->{'name'} = $class;
        $$class_decl->{'type'} ||= 'static';
        if ( PERL_VERSION >= 5.008 ) {
            *$class_decl = sub () { $$class_decl };
        }
        else {
            *$class_decl = eval 'sub () { $' . $class_decl . '}';
        }
    }

    #-----------------------------------------------------------------

    # setup the special MIXIN method and var
    my $class_MIXIN = $class . '::MIXIN';
    if (!*$class_MIXIN{CODE}) {
        $$class_MIXIN = undef;
        if ( PERL_VERSION >= 5.008 ) {
            *$class_MIXIN = sub () { $$class_MIXIN };
        }
        else {
            *$class_MIXIN = eval 'sub () { $' . $class_MIXIN . '}';
        }
    }

    #-----------------------------------------------------------------

    $classes::def_base_exception = $def_base_exception
        if $def_base_exception;

    #-----------------------------------------------------------------

    # keep using a type that has already been declared
    if ($type) {
        X::Usage->throw( "type=>'$type' ??\n"
            . "    type => 'static'|'dynamic'|'mixable'\n" )
           if ! ( $type eq 'static'
              ||  $type eq 'dynamic'
              ||  $type eq 'mixable' );
        $$class_decl->{'type'} = $type;
    }
    else {
        $type = $$class_decl->{'type'};
    }

    #-----------------------------------------------------------------
    # export a 'classes' function/statement into caller

    *{ $class . '::classes' } = \&classes::classes
        if $type eq 'dynamic';

    #-----------------------------------------------------------------

    my $class_super = $class . '::SUPER';
    if (!*$class_super{CODE}) {
        if ( PERL_VERSION >= 5.008 ) {
            *$class_super = sub () { ${ $class.'::ISA' }[0] };
        }
        else {
            *$class_super = eval 'sub () { $'.$class.'::ISA[0] }';
        }
    }

    #-----------------------------------------------------------------

    _define_mixins( $class, $mixes, $mixes_def, '')
        if defined $mixes;
    _define_mixins( $class, $class_mixes, $mixes_def, 'class_' )
        if defined $class_mixes;
    _define_mixins( $class, $pkg_mixes, $mixes_def, 'pkg_' )
        if defined $pkg_mixes;

    #-----------------------------------------------------------------
    # same as 'throws' for now

    # 'needs' IS DEPRECATED, use perl 'use' instead, too many
    # compilers/builders depend on 'use' to identify needed modules
    if ($needs) {
        my $is_ref = ref $needs;

        # needs => 'SomeOtherMod',
        if ( !$is_ref ) {
            $needs = [$needs];
            $is_ref = 'ARRAY';
        }

        X::Usage->throw( <<'EOM' ) if $is_ref ne 'ARRAY';

    DEPRECATED, use perl 'use' instead, too many compilers/builders
    depend on 'use' to identify which modules are needed
EOM

        for my $pkg (@$needs) {
            classes::load($pkg);
            push @{ $$class_decl->{'needs'} }, $pkg;
        }
    }    # needs


    #-----------------------------------------------------------------

    if ($throws) {
        my $is_ref = ref $throws;

        # throws => 'X::Usage',
        if ( !$is_ref ) {
            $throws = [$throws];
            $is_ref = 'ARRAY';
        }

        X::Usage->throw( <<'EOM' ) if $is_ref ne 'ARRAY';

    throws => 'X::Usage',
    throws => [ 'X::Usage', 'X::Mine::NotFound' ],
EOM

        for my $exc (@$throws) {
            classes::load($exc);
            push @{ $$class_decl->{'throws'} }, $exc;
        }
    }    # throws

    #-----------------------------------------------------------------

    if ($base_exception) {

        # base_exception => {name=>'X::MyBase',},
        if (ref $base_exception) {
            classes::classes($base_exception);
            $base_exception = $base_exception->{'name'};
        }

        # base_exception => 'X::class',
        # base_exception => 'Exception::Class',
        else {
            classes::load($base_exception);
        }

        $$class_decl->{'base_exception'} = $base_exception;
    }

    #-----------------------------------------------------------------

    if ($exceptions) {
        my $is_ref  = ref $exceptions;
        my $usage   = <<'EOM';

    exceptions => 'X::MyClass::Own1',
    exceptions => [
        'X::MyClass::Own1',
        'X::MyClass::Own2',
        { name=>'X::MyClass::EOF', attrs=>['file'], ... },
    ],
EOM

        # go with base exception class if one is declared
        my $base_x_class = $base_exception;

        # otherwise define X::MyClass default base
        if (!$base_x_class) {
            $base_x_class = "X::$class";

            # but create only if hasn't been created already
            if (!%{$base_x_class.'::'}) {
                classes::classes(
                    name    => $base_x_class,
                    extends => $classes::def_base_exception,
                );
            }
        }

        if ($is_ref ne 'ARRAY') {
            $exceptions = [$exceptions];
            $is_ref = 'ARRAY';
        }

        for my $exc (@$exceptions) {
            my $exc_is_ref = ref $exc;

            # exceptions => ['X::Name']
            if (!$exc_is_ref) {
                X::NameUnavailable->throw([$exc]) if %{$exc.'::'};
                classes::classes(name=>$exc, extends=>$base_x_class);

            }

            # exceptions => [{name=>'X::Name',attrs=>['file']}]
            elsif ($exc_is_ref eq 'HASH') {
                my $name = $exc->{'name'};
                $exc->{'extends'} ||= $base_x_class;
                X::NameUnavailable->throw([$name])
                    if %{$name.'::'};
                classes::classes($exc);
            }

            # bad
            else {
                X::Usage->throw($exceptions . $usage);
            }

            push @{ $$class_decl->{'exceptions'} }, $exc;
        }

    } # exceptions

    #-----------------------------------------------------------------

    # extends trumps inherits
    if ($extends) {
        X::Usage->throw(
            "extends=>'parent' OR inherits=>[qw( Parent1 Parent2 )]"
            )
            if $inherits || ref $extends;
            classes::load($extends);
            @{$class . '::ISA'} = ($extends);
            $$class_decl->{'extends'} = $extends;
            delete $$class_decl->{'inherits'};
    }

    #-----------------------------------------------------------------

    if ($inherits) {
        my $is_ref = ref $inherits;
        my $usage  = <<'EOM';

    extends  => 'SuperClass',
    inherits => 'SuperClass',
    inherits => [qw( Class1 Class2 )],
EOM

        if (!$is_ref) {
            $inherits = [$inherits];
            $is_ref = 'ARRAY';
        }

        X::Usage->throw($usage)
            if !$is_ref || $is_ref ne 'ARRAY';

        for my $parent (@$inherits) {
            next if $class->isa($parent);
            classes::load($parent);
            push @{ $class . '::ISA' }, $parent;
            push @{ $$class_decl->{'inherits'} }, $parent;
        }

    }    # inherits

    #-----------------------------------------------------------------

    if ($class_attrs_ro) {
        my $is_ref = ref $class_attrs_ro;
        my $usage  = <<'EOM';

    class_attrs_ro => [qw( attr1 attr2 )],
    class_attrs_ro => {
        attr0 => undef,
        attr1 => 1,
        attr2 => 'scalar',
        attr3 => \$scalar_ref,
        attr4 => [ 'array', 'ref' ],
        attr5 => { 'hash' => 'ref' },
        attr6 => sub { ... },
        attr7 => qr/^Get the idea(?:\?|\!)$/o,
        attr8 => 0,
        attr9 => '',
    },
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$class_attrs_ro) {
                X::InvalidName->throw(
                    "class_attrs_ro=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => undef, 'ro' );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $i_value ) = each %$class_attrs_ro ) {
                X::InvalidName->throw(
                    "class_attrs_ro=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => $i_value, 'ro' );
            }
        }
        else {
            X::Usage->throw($usage);
        }
    }    # class_attrs_ro

    #-----------------------------------------------------------------

    if ($class_attrs_pr) {
        my $is_ref = ref $class_attrs_pr;
        my $usage  = <<'EOM';

    class_attrs_pr => [qw( attr1 attr2 )],
    class_attrs_pr => {
        attr0 => undef,
        attr1 => 1,
        attr2 => 'scalar',
        attr3 => \$scalar_ref,
        attr4 => [ 'array', 'ref' ],
        attr5 => { 'hash' => 'ref' },
        attr6 => sub { ... },
        attr7 => qr/^Get the idea(?:\?|\!)$/o,
        attr8 => 0,
        attr9 => '',
    },
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$class_attrs_pr) {
                X::InvalidName->throw(
                    "class_attrs_pr=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => undef, 'pr' );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $i_value ) = each %$class_attrs_pr ) {
                X::InvalidName->throw(
                    "class_attrs_pr=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => $i_value, 'pr' );
            }
        }
        else {
            X::Usage->throw($usage);
        }
    }    # class_attrs_pr

    #-----------------------------------------------------------------

    if ($class_attrs) {
        my $is_ref = ref $class_attrs;
        my $usage  = <<'EOM';

    class_attrs => [qw( attr1 attr2 )],
    class_attrs => {
        attr0 => undef,
        attr1 => 1,
        attr2 => 'scalar',
        attr3 => \$scalar_ref,
        attr4 => [ 'array', 'ref' ],
        attr5 => { 'hash' => 'ref' },
        attr6 => sub { ... },
        attr7 => qr/^Get the idea(?:\?|\!)$/o,
        attr8 => 0,
        attr9 => '',
    },
EOM

        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$class_attrs) {
                X::InvalidName->throw(
                    "class_attrs=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => undef );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $i_value ) = each %$class_attrs ) {
                X::InvalidName->throw(
                    "class_attrs=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_class_attr( $class, $name => $i_value );
            }
        }
        else {
            X::Usage->throw($usage);
        }

    }    # class_attrs

    #-----------------------------------------------------------------

    if ($justahash) {
        $$class_decl->{'justahash'} = $justahash;
        $noaccessors = 1;
        $unqualified = 1;
        $new_m     ||= 'classes::new_fast';
    }
    else {
        $$class_decl->{'unqualified'} = $unqualified if $unqualified;
        $$class_decl->{'noaccessors'} = $noaccessors if $noaccessors;
    }

    #-----------------------------------------------------------------

    if ($attrs_ro) {
        my $is_ref = ref $attrs_ro;
        my $usage  = <<'EOM';

    attrs_ro => [qw( attr1 attr2 )],
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$attrs_ro) {
                X::InvalidName->throw(
                    "attrs_ro=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_attr( $class, $name, 'ro',
                        $unqualified, $noaccessors );
            }
        }
        else {
            X::Usage->throw($usage);
        }

    }    # attrs_ro

    #-----------------------------------------------------------------

    if ($attrs_pr) {
        my $is_ref = ref $attrs_pr;
        my $usage  = <<'EOM';

    attrs_pr => [qw( attr1 attr2 )],
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$attrs_pr) {
                X::InvalidName->throw(
                    "attrs_pr=>['$name']"
                ) if !$name || $name !~ $classes::ok_attr_name;
                _define_attr( $class, $name, 'pr',
                        $unqualified, $noaccessors );
            }
        }
        else {
            X::Usage->throw($usage);
        }

    }    # attrs_pr
    #-----------------------------------------------------------------

    if ($attrs) {
        my $is_ref = ref $attrs;
        my $usage  = <<'EOM';

    attrs => [qw( attr1 attr2 )],
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$attrs) {
                X::InvalidName->throw( "attrs=>['$name']" )
                    if !$name || $name !~ $classes::ok_attr_name;
                _define_attr( $class, $name, '',
                        $unqualified, $noaccessors );
            }
        }
        else {
            X::Usage->throw($usage);
        }

    }    # attrs

    #-----------------------------------------------------------------

    if ($class_methods) {
        my $is_ref = ref $class_methods;
        my $usage  = <<'EOM';

    class_methods => [ 'method1', 'method2' ],
    class_methods => {
        method1 => 'method1',
        method2 => 'local_method',
        method3 => 'Extern::library::method',
        method4 => 'ABSTRACT',
        method5 =>  | 'EMPTY',
        method6 => sub { ... } | $code_ref | \&some::method,
    },
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$class_methods) {
                _define_method( $class, $name => $name, 'class_' );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $method ) = each %$class_methods ) {
                my $is_ref = ref $method;
                _define_method( $class, $name => $method, 'class_');
            }
        }
        else {
            X::Usage->throw($usage);
        }
    }    # class_methods

    #---------------------------------------------------------------

    if ($pkg_methods) {
        my $is_ref = ref $pkg_methods;
        my $usage  = <<'EOM';

    pkg_methods => [ 'method1', 'method2' ],
    pkg_methods => {
        method1 => 'method1',
        method2 => 'local_method',
        method3 => 'Extern::library::method',
        method4 => 'ABSTRACT',
        method5 =>  | 'EMPTY',
        method6 => sub { ... } | $code_ref | \&some::method,
    },
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$pkg_methods) {
                _define_method( $class, $name => $name, 'pkg_' );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $method ) = each %$pkg_methods ) {
                my $is_ref = ref $method;
                _define_method( $class, $name => $method, 'pkg_');
            }
        }
        else {
            X::Usage->throw($usage);
        }

        # allows pkg_methods to be imported on request
        my $class_decl = $class . '::DECL';
        *{$class.'::import'} = sub {
            my $package = shift;
            my $caller = caller;

            # use MyPackage qw(my_pkg_method another_function);
            if ($_[0] and $_[0] ne ':all') {
                for my $method (@_) {
                    X::NotPkgMethod->throw([$method])
                        if !$$class_decl->{'pkg_methods'}->{$method};
                    *{$caller.'::'.$method} = \&{$class.'::'.$method};
                }
            }

            # use MyPackage ':all';
            else {
               for my $method (keys %{$$class_decl->{'pkg_methods'}}){
                    *{$caller.'::'.$method} = \&{$class.'::'.$method};
               }
            }
            return $package;
        };

    }    # pkg_methods

    #---------------------------------------------------------------

    if ($methods) {
        my $is_ref = ref $methods;
        my $usage  = <<'EOM';

    methods => [ 'method1', 'method2' ],
    methods => {
        method1 => 'method1',
        method2 => 'local_method',
        method3 => 'Extern::library::method',
        method4 => 'ABSTRACT',
        method5 =>  || 'EMPTY',
        method6 => sub { ... } || $code_ref || \&some::method,
    },
EOM
        if ( $is_ref eq 'ARRAY' ) {
            for my $name (@$methods) {
                _define_method( $class, $name => $name, '' );
            }
        }
        elsif ( $is_ref eq 'HASH' ) {
            while ( my ( $name, $method ) = each %$methods ) {
                _define_method( $class, $name => $method, '' );
            }
        }
        else {
            X::Usage->throw($usage);
        }

    }    # methods

    #---------------------------------------------------------------
    # new, clone, initialize, and dump shortcuts

    _define_method( $class, 'initialize' => $init_m, '' ) if $init_m;
    _define_method( $class, 'clone' => $clone_m, '' ) if $clone_m;
    _define_method( $class, 'dump'  => $dump_m, '' )  if $dump_m;
    _define_method( $class, 'new' => $new_m, 'class_' ) if $new_m;

    return $class;
}

####################################################################

sub load {
    my $pkg = shift;

    X::InvalidName->throw( [$pkg] )
        if $pkg !~ $classes::ok_class_name;

    # from 'base', don't bother loading if have VERSION,
    my $vglob = ${$pkg.'::'}{VERSION};
    return $pkg if $vglob && *$vglob{SCALAR};

    # unlike 'base' that does a 'require', we 'use' instead to
    local $SIG{__DIE__} = 'IGNORE';
    eval "use $pkg";

    # unlike 'base' that does a 'require', we 'use' instead to
    # propogate exception as is unless "can't locate", which is
    # expected when the base pkg is defined in same file, etc.
    # had to remove the '^' initial match because of braindead
    # idiot programs like Indigo's perl2exe that stick a bunch
    # of irrelevant text before the actual expected error string
    die if $@ && $@ !~ /Can't locate .*? at \(eval /o;

    # problem if the pkg doesn't have any var or sub symbols in it
    # milage may vary when loading pkgs that use DynaLoader (ugh)
    X::Empty->throw([$pkg]) if !%{$pkg.'::'};

    # for 'use base' compatibility, if the loaded pkg didn't have
    # a VERSION of its own give it one so we don't load it again
    ${$pkg.'::VERSION'} = "-1, set by classes.pm"
        if !defined ${$pkg.'::VERSION'};

    return $pkg;
}


####################################################################

sub _define_mixins {
    my ($class, $mixes, $mixes_def, $type) = @_;
    my $is_ref      = ref $mixes;
    my $class_DECL  = $class.'::DECL';
    my $class_MIXIN = $class.'::MIXIN';

    my $usage  = <<'EOM';

    [class_|pkg_]mixes => 'Module',
    [class_|pkg_]mixes => { Module => ... },
    [class_|pkg_]mixes => [
        'Module1',
        { Module2 => ['method1'] },
        { Module3 => 'ALL'|'PUB'|'SAFE' },
        { Module4 => qr/.../ },
        { Module5 => ... , scope=>'CLASS' },
     ],

    mixes_def => 'ALL'|'PUB'|'SAFE',
EOM
    # mixes => 'Module1',
    # mixes => { Module1 => ... },
    if ( !$is_ref || $is_ref eq 'HASH' ) {
        $mixes  = [$mixes];
        $is_ref = 'ARRAY';
    }

    X::Usage->throw($usage) if $is_ref ne 'ARRAY';

    MIXIN:
    for my $module ( reverse @$mixes ) {         # first wins

        my $is_ref = ref $module;
        my $filter = $mixes_def || 'SAFE';

        # mixes => [ 'Module1' ],
        if ( !$is_ref ) {
            $module = { $module => $filter };
            $is_ref = 'HASH';
        }

        X::Usage->throw($usage) if $is_ref ne 'HASH';

        # mixes => [ { Module1 => ... } ],
        ($module, $filter) = each %$module; # only one left

        X::InvalidName->throw( "mixes=>'$module' ??" )
            if !$module || $module !~ $classes::ok_class_name;

        # only SAFE, PUB, and ALL acceptable non-refs
        my $filter_is_ref = ref $filter;
        if ( !$filter_is_ref ) {
            {
                $filter = qr/^(?!(?:_|\d|[A-Z0-9_]+$))/o,
                    last if $filter eq 'SAFE';
                $filter = qr/^
                    (?!_|BEGIN|CHECK|END|INIT|CLONE
                        |CLASS|SUPER|DECL|MIXIN)
                    [a-z_]\w*$/xoi,
                    last if $filter eq 'PUB';
                $filter = qr/^
                    (?!BEGIN|CHECK|END|INIT|CLONE
                      |CLASS|SUPER|DECL|MIXIN)
                    [a-z_]\w*$/xoi,
                    last if $filter eq 'ALL';
                X::Usage->throw($filter." ??\n".$usage);
            }
            $filter_is_ref = 'Regexp';
        }

        classes::load($module);
        my $mod_sym  = $module.'::';

        # unfortunately the following causes an empty DECL
        # to autovivify if not one there already, perl's problem
        my $mod_DECL = ${"$module\::DECL"};

        my $mod_type = ${"$module\::DECL"}->{'type'};

        # if declared AND type is set by author to 'mixin'
        # go ahead and only use the declaration.

        if ( $mod_type and $mod_type eq 'mixable' ) {
            my $methods        = $mod_DECL->{'methods'};
            my $class_methods  = $mod_DECL->{'class_methods'};
            my $pkg_methods    = $mod_DECL->{'pkg_methods'};
            my $attrs          = $mod_DECL->{'attrs'};
            my $attrs_ro       = $mod_DECL->{'attrs_ro'};
            my $attrs_pr       = $mod_DECL->{'attrs_pr'};
            my $class_attrs    = $mod_DECL->{'class_attrs'};
            my $class_attrs_ro = $mod_DECL->{'class_attrs_ro'};
            my $class_attrs_pr = $mod_DECL->{'class_attrs_pr'};

            while ( my ($name, $ivalue) = each %$class_methods ) {
                _clear_method_name($class, $name);
                _mixin( $module => $class, $name );
                $$class_DECL->{'class_methods'}->{$name} = $ivalue;
            }

            while ( my ($name, $ivalue) = each %$methods ) {
                _clear_method_name($class, $name);
                _mixin( $module => $class, $name );
                $$class_DECL->{'methods'}->{$name} = $ivalue;
            }

            while ( my ($name, $ivalue) = each %$pkg_methods ) {
                _clear_method_name($class, $name);
                _mixin( $module => $class, $name );
                $$class_DECL->{'pkg_methods'}->{$name} = $ivalue;
            }

            for my $name ( @$attrs ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin( $module => $class, "set_$name" );
                _mixin( $module => $class, "get_$name" );
                _mixin_key( $module => $class, $name );
                push @{$$class_DECL->{'attrs'}}, $name;
            }

            for my $name ( @$attrs_ro ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin( $module => $class, "get_$name" );
                _mixin_key( $module => $class, $name );
                push @{$$class_DECL->{'attrs_ro'}}, $name;
            }

            for my $name ( @$attrs_pr ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin_key( $module => $class, $name );
                push @{$$class_DECL->{'attrs_pr'}}, $name;
            }

            while ( my ($name, $ivalue) = each %$class_attrs ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin( $module => $class, "set_$name" );
                _mixin( $module => $class, "get_$name" );
                _mixin_key( $module => $class, $name, 'class' );
                $$class_DECL->{'class_attrs'}->{$name} = $ivalue;
            }

            while ( my ($name, $ivalue) = each %$class_attrs_ro ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin( $module => $class, "get_$name" );
                _mixin_key( $module => $class, $name, 'class' );
                $$class_DECL->{'class_attrs_ro'}->{$name} = $ivalue;
            }

            while ( my ($name, $ivalue) = each %$class_attrs_pr ) {
                _clear_method_name($class, "set_$name");
                _clear_method_name($class, "get_$name");
                _mixin_key( $module => $class, $name, 'class' );
                $$class_DECL->{'class_attrs_pr'}->{$name} = $ivalue;
            }

            next MIXIN;
        }

        # not declared as a mixable ...

        # we only look at the methods in the symbol table here
        # and don't care how they got there. these may very well have
        # classes declarations but probably not. more likely these
        # are old fashioned function libraries

        # mixes => [ { Module1 => ['method'] } ],
        if ( $filter_is_ref eq 'ARRAY' ) {
            for my $name ( @$filter ){

                X::InvalidName->throw(
                    "mixes=>{$module=>['$name']} ??"
                    ) if !$name || $name !~ /^[a-z_]\w*$/o;

                my $glob = $$mod_sym{$name};
                my $code;

                # careful: only CODE slot, not others
                next if !$glob || !( $code = *$glob{CODE} );

                # import
                *{ $class . '::' . $name } = $code;
                _clear_method_name($class, $name);

                $$class_MIXIN->{$name} = $module.'::'.$name;
                $$class_DECL->{$type.'methods'}->{$name}
                    = $module.'::'.$name;
            }
        }

        # mixes => [ { Module1 => qr/.../o } ],
        elsif ( $filter_is_ref eq 'Regexp'
             or $filter_is_ref eq 'Regex' ) { # older
            while ( my ($name) = each %$mod_sym ) {

                my $glob = $$mod_sym{$name};
                my $code;

                # careful: only CODE slot, not others
                next if $name !~ $filter || !$glob
                        || !( $code = *$glob{CODE} );

                # import
                *{ $class . '::' . $name } = $code;
                _clear_method_name($class,$name);
                $$class_MIXIN->{$name} = $module;

                $$class_DECL->{$type.'methods' }->{$name}
                    = $module.'::'.$name;
            }
        }

        # ref to something else
        else {
            X::Usage->throw($filter_is_ref . $usage);
        }                                 # filter_is_ref
    }                                     # module
}

sub _mixin {
    my ($from_pkg, $to_pkg, $name, $dest_name) = @_;
    $dest_name ||= $name;
    *{ $to_pkg . '::' . $dest_name } = \&{ $from_pkg . '::' . $name };
    my $really_from = ${ $from_pkg.'::MIXIN' }->{$name};
    ${ $to_pkg.'::MIXIN' }->{$dest_name} = $really_from || $from_pkg;
}

sub _mixin_key {
    my ($from_pkg, $to_pkg, $name, $is_class) = @_;
    my $var_name = ($is_class && 'CLASS_') . 'ATTR_' . $name;
    *{$to_pkg.'::'.$var_name} = \${$from_pkg.'::'.$var_name};
    my $really_from = ${$from_pkg.'::MIXIN'}->{"\$$var_name"};
    ${ $to_pkg.'::MIXIN' }->{"\$$var_name"}
        = $really_from || $from_pkg;
}

sub _clear_method_name {
    my $decl = ${ $_[0].'::DECL' };
    my ($cm, $m, $pkm);
    $pkm = $decl->{'pkg_methods'}    and delete $pkm->{$_[1]};
    $cm  = $decl->{'class_methods'}  and delete $cm->{$_[1]};
    $m   = $decl->{'methods'}        and delete $m->{$_[1]};
    delete ${ $_[0].'::MIXIN' }->{$_[1]};
    return;
}

####################################################################

sub _define_class_attr {
    my ( $class, $name => $i_value, $scope ) = @_;
    my $qual_name  = $class.'::'.$name;
    my $scope_x = sub {X::AttrScope->throw([$name])};
    my $has_getter = $class->can("get_$name");
    my $has_setter = $class->can("set_$name");

    # set the initial value
    $$qual_name = $i_value;

    # create a string containing the name of the class attribute
    # for use privately within the class
    *{"$class\::CLASS_ATTR_$name"} = \$qual_name;

    # define 'getter' for all but private
    *{"$class\::get_$name"} = sub { $$qual_name }
        if $scope ne 'pr';

    # define 'setter' for read-write
    if ($scope ne 'pr' and $scope ne 'ro') {
        *{"$class\::set_$name"}
            = sub { $$qual_name = $_[1]; return };
    }

    # private shouldn't have getter or setter, if so, cause exception
    *{"$class\::get_$name"} = $scope_x
        if $scope eq 'pr' && $has_getter;
    *{"$class\::set_$name"} = $scope_x
        if $scope eq 'pr' && $has_setter;

    # read-only shouldn't have setter if so, cause exception
    *{"$class\::set_$name"} = $scope_x
        if $scope eq 'ro' && $has_setter;

    # update declaration
    my $decl = ${ $class.'::DECL' };
    $decl->{'class_attrs'
        . ($scope ? "_$scope" : '')}->{$name} = $i_value;

    return $class;
}

####################################################################

sub _define_attr {
    my ( $class, $name, $scope, $unqual, $noaccess ) = @_;
    my $qual_name   = $class.'::'.$name;
    my $attr_name   = $unqual ? $name : $qual_name;

    # create a string containing the name of the attribute
    # for use privately within the class as a object hash key
    *{"$class\::ATTR_$name"} = \$attr_name;

    # noaccess means don't create accessors, plain old perl objects
    if (!$noaccess) {
        my $scope_x = sub {X::AttrScope->throw([$name])};
        my $has_getter = $class->can("get_$name");
        my $has_setter = $class->can("set_$name");

        # define 'getter' for all but private
        *{"$class\::get_$name"} = sub { $_[0]->{$attr_name} }
            if $scope ne 'pr';

        # define 'setter' for read-write
        if ($scope ne 'pr' and $scope ne 'ro') {
            *{"$class\::set_$name"}
                = sub { $_[0]->{$attr_name} = $_[1]; return };
        }

        # private shouldn't have getter or setter
        # if so override with one that throws an exception at run time
        *{"$class\::get_$name"} = $scope_x
            if $scope eq 'pr' && $has_getter;
        *{"$class\::set_$name"} = $scope_x
            if $scope eq 'pr' && $has_setter;

        # read-only shouldn't have setter if so, cause exception
        *{"$class\::set_$name"} = $scope_x
            if $scope eq 'ro' && $has_setter;
    }

    # update declaration
    my $decl = ${ $class.'::DECL' };
    my $tag = 'attrs' . ($scope ? "_$scope" : '');
    push @{$decl->{$tag}}, $name
        if !grep {$_ eq $name} @{$decl->{$tag}};

    return $class;
}

####################################################################

sub _define_method {
    my ( $class, $name, $method, $type ) = @_; # trust
    my $is_ref = ref $method;
    my ($code, $m_pkg, $m_name);

    $method = 'EMPTY' if !$method;

    # classes::abstract, classes::empty, Module::method, method
    if (!$is_ref ) {

        # inline anon to get better X::Unimplemented message
        if ( $method eq 'ABSTRACT' ) {
            $code = sub {
                X::Unimplemented->throw( "$class->$name()" );
            };
        }

        elsif ( $method eq 'EMPTY' ) {
            $code = sub { };
        }

        # Module::Mine::method_name or method_name
        else {
            ($m_pkg, $m_name) = $method
                =~ /^
                    (?:
                        (
                            (?:
                                [a-z_]\w*\:\:    # opt: Module::
                            )*
                            [a-z_]\w*            # opt: Mine
                        )
                        ::                       # opt: ::
                    )?
                    (
                        [a-z_]\w*                # req: method_name
                    )
                $/iogx;

            X::InvalidName->throw( [$method] ) if !$m_name;

            # no package name, method_name only - qualify
            if (!$m_pkg) {
                $method = $class . '::' . $m_name;
                $m_pkg ||= $class;
            }

            # treat as any other mixin
            else {
                _clear_method_name($class, $name);
                _mixin( $m_pkg => $class, $m_name => $name );
                my $decl = ${ $class.'::DECL' };
                $decl->{$type.'methods'}->{$name} = $method;
                return $class;
            }

            load $m_pkg if !%{$m_pkg.'::'};

            # unfortunately since we allow compile-time
            # class definition it is too early to test for defined
            # method, we have to trust that one will be defined
            # or caught by perl run-time, the following springs
            # a symbolic code ref into life no matter what,
            # rather annoying, but best we can do for now

            $code = \&$method;
        }

    }

    # sub { ... }  or  \&method
    else {
        X::Usage->throw( "$name $is_ref ??" )
            if $is_ref ne 'CODE';
        $code = $method;
        $method = 'CODE';
    }

    *{ $class . '::' . $name }  = $code;

    # update declaration - same named removed since all are methods
    _clear_method_name($class, $name);
    my $decl = ${ $class.'::DECL' };
    $decl->{$type.'methods'}->{$name} = $method;

    return $class;
}

######################################################################

sub new_args {
    my $class = shift;
    my $self = {};
    bless $self, $class;
    return $self->classes::init_args(@_);
}

sub new_only {
    return bless {}, $_[0];
}

sub new_init {
    my $class = shift;
    my $self = {};
    bless $self, $class;
    return $self->initialize(@_);
}

sub new_fast {
    my $class = shift;
    return bless($_[0], $class) if ref $_[0];
    return bless({@_}, $class)  if @_;
    return bless({}, $class);
}

######################################################################

sub init_args {
    my $self  = shift;
    my $attrs = $_[0];
    $attrs = {@_} if ref $attrs ne 'HASH';

    while ( my ( $attr, $value ) = each %$attrs ) {
        my $setter = $self->can("set_$attr")
            or X::UnknownAttr->throw([$attr]);
        $self->$setter($value);
    }

    return $self;
}

######################################################################
# Modeled after Clone::PP and Clone, Matthew Simon Cavalletto,
# David Muir Sharnoff, Ray Finch, chocolateboy. See pod for
# differences.
#
# Could use some work to get object 'clone' methods observed--
# especially with the prevalence of unclonable perl classes
# out there, but alas, this makes cloning self refs difficult
# because their cached copies no longer match.

sub clone {
    X::Usage->throw('$obj->clone') if @_ != 1;
    my ($this) = @_;

    # 'undef' is a valid leaf clone value
    return $this if !defined $this;

    my $is_ref     = reftype $this;
    my $blessed_as = blessed $this;
    my $clone      = undef;

    # cache of back references to prevent recursion, mark top,
    # localized global makes the clone_cache visible down through
    # the recursive subroutine calls

    local %classes::_clone_cache = ( __top => 1, __self => $this )
        unless ( exists $classes::_clone_cache{'__self'} );

    if ( $classes::_clone_cache{__top} ) {

        # put stuff for first run, if needed, here

        delete $classes::_clone_cache{__top};
    }

    # block recursion, seen already
    return $classes::_clone_cache{$this}
        if exists $classes::_clone_cache{$this};

    # scalar = leaf
    return $this if !$is_ref;

    # clone each key or value that is a ref recursively
    if ( $is_ref eq 'HASH' ) {
        $classes::_clone_cache{$this} = $clone = {};
        %$clone = map { !ref $_ ? $_ : classes::clone($_) } %$this;
    }

    # clone each element in array  that is a ref recursively
    elsif ( $is_ref eq 'ARRAY' ) {
        $classes::_clone_cache{$this} = $clone = [];
        @$clone = map { !ref $_ ? $_ : classes::clone($_) } @$this;
    }

    # clone refs to refs and simple refs to scalars
    elsif ( $is_ref =~ /^(REF|SCALAR)$/o && !$blessed_as ) {
        $classes::_clone_cache{$this} = $clone = \( my $var = q[] );
        $$clone = classes::clone($$this);
    }

    # plain copies of anything else (globs, regx, etc.)
    else {
        $classes::_clone_cache{$this} = $clone = $this;
    }

    bless $clone, $blessed_as if $blessed_as;
    return $clone;
}

######################################################################

sub sprintf {
    my ($self, $format, @attrs) = @_;
    my @values = map {
        my $getter = $self->can("get_$_");
        defined $getter ? $self->$getter : undef;
    } @attrs;
    CORE::sprintf $format, @values;
}

sub printf {
    my ($self, $format, @attrs) = @_;
    my @values = map {
        my $getter = $self->can("get_$_");
        defined $getter ? $self->$getter : undef;
    } @attrs;
    CORE::printf $format, @values;
}

######################################################################

sub set {
    my ( $self, $name, $value ) = @_;
    my $accessor = $self->can("set_$name")
        || X::MethodNotFound->throw("set_$name");
    return $self->$accessor($value);
}

sub get {
    my ( $self, $name ) = @_;
    my $accessor = $self->can("get_$name")
        || X::MethodNotFound->throw("get_$name");
    return $self->$accessor;
}

####################################################################

sub dump {
    my ( $this, $out ) = @_;
    my $is_ref     = ref $out;
    my $blessed_as = blessed $this;
    my $class      = $blessed_as || $this || caller;
    my $decl       = ${ $class . '::DECL' };
    my $mixins     = ${ $class . '::MIXIN' };

    my $usage = <<'EOM';

    MyClass|$object->classes::dump;
    ... ->classes::dump( $handle );
    ... ->classes::dump( \$buffer );
    classes::dump(['just','anything']);
EOM

    X::Usage->throw($usage)
        if $out && !$is_ref; # handle or scalar ref

    $out ||= *STDERR;

    require Data::Dumper;

    local $Data::Dumper::Varname;
    local $Data::Dumper::Indent = 1;
    my $buf;

    # header line
    my $len = length $class;
    my $pad = int( ( 70 - $len ) / 2 );
    my $rest = 70 - ( $pad*2 + $len );
    $pad -= 2;
    $buf .= '#' x $pad . "  $class  "
          . '#' x ( $pad + $rest ) . "\n\n";

    if ( $decl ) {
        $Data::Dumper::Varname = 'DECL';
        $buf .= Data::Dumper::Dumper($decl) . "\n";

        if ( $mixins ) {
            $Data::Dumper::Varname = 'MIXIN';
            $buf .= Data::Dumper::Dumper($mixins) . "\n";
        }

        my $d_class_attrs    = $decl->{'class_attrs'};
        my $d_class_attrs_ro = $decl->{'class_attrs_ro'};

        # pull out internal class attrs (if any) by accessor
        if ( $d_class_attrs || $d_class_attrs_ro ) {
            my %class_attr;
            $Data::Dumper::Varname = 'CLASS_STATE';
            if ( $d_class_attrs ) {
                while ( my ( $tag, $val ) = each %$d_class_attrs ) {
                    my $getter = "get_$tag";
                    my $accessor = $class->can($getter);
                    $class_attr{$tag} =
                       $accessor
                            ? $class->$accessor
                            : 'ERROR_NO_ACCESSOR';
                }
            }
            if ( $d_class_attrs_ro ) {
                while ( my ($tag, $val) = each %$d_class_attrs_ro ) {
                    my $getter = "get_$tag";
                    my $accessor = $class->can($getter);
                    $class_attr{$tag} =
                       $accessor
                            ? $class->$accessor
                            : 'ERROR_NO_ACCESSOR';
                }
            }
            $buf .= Data::Dumper::Dumper( \%class_attr ) . "\n";
        }

        # object only
        if ($blessed_as) {
            $Data::Dumper::Varname = 'OBJECT_STATE';
            $buf .= Data::Dumper::Dumper($this) . "\n";
        }

    }

    else {
        $Data::Dumper::Varname = 'THIS';
        $buf .= Data::Dumper::Dumper( $this );

        if ($blessed_as) {
            $Data::Dumper::Varname = 'PACKAGE_SYMBOLS';
            $buf .= Data::Dumper::Dumper( \%{$blessed_as.'::'} );
        }

    }

    # string buffer
    if ( $is_ref and $is_ref eq 'SCALAR' ) {
        $$out = $buf;
    }

    # io handle
    else {
        print $out $buf;
    }

    return $this;
}

######################################################################

sub id { Scalar::Util::refaddr($_[0]) }

######################################################################
# Throwable mixin - the guts of perl exceptions

package classes::Throwable;
use strict 'subs'; no warnings;
use Scalar::Util;

use classes
    type => 'mixable',
    class_methods => {
        throw   => 'throw',
        caught  => 'caught',
        catch   => 'caught',     # synonym
    },
    methods => {
        capture  => 'capture',
        rethrow  => 'rethrow',
        send     => 'rethrow',
    },
; # END DECLARATION

sub capture { $_[0] };
sub throw   { my $x = shift->new(@_); $x->capture; die $x }
sub rethrow { die $_[0] if $_[0] }

sub caught {
    my $class    = shift;
    my $last_err = $@;

    return $last_err
        if Scalar::Util::blessed $last_err && $last_err->isa($class);

    return undef;
}

######################################################################
# Bare minimum exception class

package X::classes;
use strict 'subs'; no warnings;
use Scalar::Util;

use classes
    mixes   => 'classes::Throwable',
    new     => 'classes::new_init',
    init    => 'classes::init_args',
    clone   => 'classes::clone',
    dump    => 'classes::dump',
    methods => ['as_string'],
;

sub as_string {
    my $c = Scalar::Util::blessed shift;
    return "exception $c\n"
}

use overload bool => sub {1}, '""' => 'as_string', fallback => 1;

######################################################################
# base exception class

package X::classes::traceable;
use strict 'subs'; no warnings;
use Scalar::Util;

use classes
    extends   => 'X::classes',
    new       => 'classes::new_init',
    init      => 'initialize',
    clone     => 'classes::clone',
    dump      => 'classes::dump',
    class_attrs => {
        'Verbose'       => 3,
        'Order'         => ['item','message'],
        'Format'        => '',
        'Caller_Format' => q[    at %4$s %1$s '%2$s' %3$s],
        'Whole_Stack'   => undef,
    },
    attrs => [qw(
            item message full_message attr_list
        )],
    attrs_ro => [qw(
            pid uid euid gid egid time
            call_stack call_package call_method call_file call_line
        )],
    methods => [ 'as_string' ],
;

sub get_full_message { get_message(@_) }
sub set_full_message { set_message(@_) }

sub capture {
    my ($self, $offset) = @_;

    my @call_stack;
    $offset = @_ >= 2 ? $offset : 0;

    # remove this method (at least)
    my $whole_stack = $self->get_Whole_Stack;
    my $frame = $whole_stack ? 1 : 1 + $offset;

    # fixes problems with some versions of perl time
    $self->{$ATTR_time} = CORE::time();

    # process ownership
    $self->{$ATTR_pid}  = $$;
    $self->{$ATTR_uid}  = $<;
    $self->{$ATTR_euid} = $>;
    $self->{$ATTR_gid}  = $(;
    $self->{$ATTR_egid} = $);

CALL_TRACE:
    while (1) {
        my @call_frame = caller($frame);
        last CALL_TRACE if !@call_frame;
        push @call_stack, \@call_frame;
        ++$frame;
    }

    # if at least one frame, give context of the caller's caller
    shift @call_stack if @call_stack > 1 && !$whole_stack;

    my $call_stack_ref = \@call_stack;
    $self->{$ATTR_call_stack}   = $call_stack_ref;
    $self->{$ATTR_call_package} = $call_stack[0][0];
    $self->{$ATTR_call_file}    = $call_stack[0][1];
    $self->{$ATTR_call_line}    = $call_stack[0][2];
    $self->{$ATTR_call_method}  = $call_stack[0][3];

    return $self;
}

sub initialize {
    my $self = shift;
    my $is_ref = ref $_[0];

    $self->{$ATTR_message}      = '';
    $self->{$ATTR_full_message} = '';

    # X::classes::traceable->new('some message')
    if ( !$is_ref && @_ == 1 ) {
        $self->{$ATTR_message} = $_[0];
        return $self;
    }

    # X::classes::traceable->new( ['item'] )
    elsif ( $is_ref eq 'ARRAY' ) {
        $self->set_attr_list($_[0]);
        return $self;
    }
    # normal
    # X::classes::traceable->new( message=>'blah', item=>2 )
    # X::classes::traceable->new( -message=>'blah', -item=>2 )
    # X::classes::traceable->new( { message=>'blah', item=>2 } )
    # X::classes::traceable->new( { -message=>'blah', -item=>2 } )
    return $self->classes::init_args(@_);
}

sub set_attr_list {
    my $self = shift;
    X::Usage->throw("\$exc->set_attr_list(ARRAYREF)\n")
        if ref $_[0] ne 'ARRAY';
    my $attr_list = $self->{$ATTR_attr_list} = $_[0];

    # Rest is dispatch side-effect ...

    my $order = $self->get_Order; # commonly overriden
    my @order = @$order;

    # cannot dispatch if no 'Order' of attr_list
    return $attr_list unless @order >= 1;

    for my $attr_value (@$attr_list) {
        my $attr_name = shift @order;

        # order = 'name', undef,     'rank'
        # list  = 'Bob',  'ignored', 'private', 'ignored2'
        next if !$attr_name;

        # dispatch to accessor
        $self->classes::set( $attr_name => $attr_value );
    }

    return $attr_list;
}

sub as_string {
    my $self    = shift;
    my $verbose = $self->get_Verbose;

    return '' if not $verbose;

    my $exception_name = Scalar::Util::blessed $self;
    my $full_message   = $self->get_full_message;

    my $attrs          = $self->get_attr_list;
    my @attrs          = @$attrs if $attrs;
    my $format         = $self->get_Format;

    return $exception_name . "\n" if $verbose == 1;

    # exception
    my $string = $exception_name;

    # exception + message or attr_list
    if ( $verbose >= 2 ) {
        $string .= ' ';
        $string .= $full_message
            || (
            ($format)
            ? sprintf( $format, @attrs )
            : "@attrs"
            );
        $string .= "\n";
    }

    # exception + message or attr_list + trace (3=file, 4=path)
    if ( $verbose >= 3 ) {
        my $caller_format = $self->get_Caller_Format;
        my $call_stack    = $self->get_call_stack;
        for my $caller (@$call_stack) {
            if ( $verbose == 3) {
                use File::Basename 'basename';
                $$caller[1] = basename $$caller[1];
            }
            $string .= sprintf $caller_format . "\n", @$caller;
        }
    }

    return $string;
}

use overload bool => sub {1}, '""' => 'as_string', fallback => 1;

################################################################
## exceptions used by 'classes' itself
################################################################

package main;
classes::classes
    { name=>'X::NameUnavailable', extends=>'X::classes::traceable' },
    { name=>'X::InvalidName', extends=>'X::classes::traceable' },
    { name=>'X::NotPkgMethod', extends=>'X::classes::traceable' },
    { name=>'X::Unimplemented', extends=>'X::classes::traceable' },
    { name=>'X::Usage', extends=>'X::classes::traceable' },
    { name=>'X::Undefined', extends=>'X::classes::traceable' },
    { name=>'X::Empty', extends=>'X::classes::traceable' },
    { name=>'X::MethodNotFound', extends=>'X::classes::traceable' },
    { name=>'X::AttrScope', extends=>'X::classes::traceable' },
    { name=>'X::UnknownAttr', extends=>'X::classes::traceable' },
;

1;
__END__