#=====================================================================
package Class::Prototype;
#=====================================================================
use strict;
use warnings; # turn off when you're ready
use Carp;
#=====================================================================
#  Class::Prototype DATA
#=====================================================================
my $VERSION = 0.03;

{ # keep the methods at Class::Prototype access level
#=====================================================================
#  FAMILY WIDE METHODS
#=====================================================================
sub new {

    my ( $caller ) = shift;
    my ( %arg ) = @_;
    my $class = ref($caller) || $caller;

    croak "Class::Prototype is a parent class only. You cannot " . 
        "create Class::Prototypes in it!"
        if $caller eq 'Class::Prototype';

    my $ego = bless {}, $class;

# class initialization and object data, see POD for info222
    $ego->can('attributes') 
        or croak "$class has no attributes method defined! ",
        "See the Class::Prototype perldoc for details.";
    $ego->{__attributes} = $ego->attributes();

    while ( my ( $attr, $val ) = each %{ $ego->{__attributes} } ) {

        my ( $default, $access ) = @{$val};

        my $type = ref $default || 'scalar';
        $type = 'scalar' if $type eq 'Regexp';

        my ( $method ) = $attr =~ /^_([a-zA-Z]\w*)$/;

        croak "Bad attribute name, $attr, in attributes ",
        "(must have an underscore prefix)!\n" unless $method;

        my $value;
        if ( $access eq 'readonly') { # only the default
            $value = $default;
        } 
        else  # if an arg is given, use it, otherwise default
        { 
            $value = defined $arg{$method} ?
                $arg{$method} : $default;
        } 
# auto-install method unless the package already defines it
        $ego->_install_method($method, $access, $type, $value)
            unless $ego->can($method);
    }

#  Allow children to get in on building the object if they want to do
#  more than simple attribute loading
    $ego->can("new_hook") and $ego->new_hook(@_);

# object is built, methods made, defaults installed so...?
    delete $ego->{__attributes};

    return $ego;
}
#=====================================================================
sub _install_method {

    my ( $ego, $method, $access, $type, $value ) = @_;
    my $attr = "_$method";

    no strict 'refs'; # can't typeglob subs correctly otherwise
    no warnings;      # pointless unitialized warnings

    print 
        "Installing method: $method()\n",
        "           access: $access\n",
        "            value: ", defined $value ? $value : 'UNDEF',
        "\n             type: $type\n\n" if $ego->verbosity() > 4;

    if ( $type eq 'scalar' ) {
# SCALARS ------------------------------------------------------------
# ---- attribute is write once or readonly, NOTE *if* CLAUSE AT END
        *{"$class::$method"} = sub { 
            my($ego,$arg) = @_;

            if ( defined $ego->{$attr} ) {
# complain if trying to set again
            carp "You cannot reset $method() (to $arg), skipping!" 
                if defined $arg;
# it's already set, so get
            return $ego->{$attr};
        }
            $ego->{$attr} = $arg;
        }
        if $access eq 'writeonce' or $access eq 'readonly';

# ---- attribute is normal, set if given value, get otherwise
        *{"$class::$method"} = sub {
            my($ego,$arg) = @_;

            $ego->{$attr} = $arg if defined $arg;
            return $ego->{$attr} unless defined $arg;
        }
        if $access eq 'write';
# SCALARS ends -------------------------------------------------------
    }
    elsif ( $type eq 'ARRAY' ) {
# ARRAYS -------------------------------------------------------------
# ---- regular arrays, shift or return all w/o arg, push w/ 
        *{"$class::$method"} = sub { 
            my($ego) = shift;
            my  $args = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;

            unless ( @{$args} ) {
# scalar context: destructive while->next->element; list: get all
            return wantarray ?
                @{$ego->{$attr}} : shift(@{$ego->{$attr}});
        }
            push(@{$ego->{$attr}}, @{$args});
        }
        if $access eq 'write';

# ---- writeonce arrays, initialization is the value
        *{"$class::$method"} = sub { 
            my($ego) = shift;
            my  $args = ref $_[0] eq 'ARRAY' ? $_[0] : \@_;
            if ( ref $ego->{$attr} and @{$ego->{$attr}} ) {
# complain if trying to set again
            carp "You cannot add values to $method(), skipping!"
                if ref $args and @{$args};
# it's already set, so get
            return wantarray ? @{$ego->{$attr}} : $ego->{$attr};
        }
            $ego->{$attr} = $args;
        }
        if $access eq 'writeonce';

        if ( $access eq 'readonly' ) {
            $ego->{$attr} = $value;
            *{"$class::$method"} = sub {
                my($ego) = shift;
            carp "Disregarded arguments sent to readonly $method()!"
                if @_;
                return wantarray ? @{$ego->{$attr}} : $ego->{$attr};
            };
            return;
        }
    }
# ARRAYS ends -------------------------------------------------------
    elsif ( $type eq 'HASH' ) {
# HASHES -------------------------------------------------------------

# ---- we want a "keys" method no matter the type ------------------
        *{"$class::" . "keys_$method"} = sub {
            my($ego) = shift;
            return keys %{$ego->{$attr}};
        };

# ---- regular hashes, set, get by key or return all w/o arg
        *{"$class::$method"} = sub { 
            my($ego) = shift;

            my $arg;
        if ( ref $_[0] eq 'HASH' ) # hasref to set new values
        {
            $arg = $_[0];
        }
        elsif ( not @_ % 2 ) # plain list in pairs, turn to a hash(ref)
        {
            $arg = { @_ };
        }
        else # plain arg to get value
        {
            return $ego->{$attr}{$_[0]};
        }

            unless ( $arg ) {
# no args, so return the full hash
            return wantarray ?
                %{$ego->{$attr}} : $ego->{$attr};
        }
            while ( my ($key,$value) = each %{$arg} ) {
                $ego->{$attr}{$key} = $value;
            }
        }
        if $access eq 'write';
# AND!! a delete method to go with it
        *{"$class::" . "delete_$method"} = sub {
            my($ego) = shift;
            my $keys = ref $_[0] eq 'ARRAY' ? $_[0] : @_;

            for my $key ( @{$keys} ) {
                delete $ego->{$attr}{$key};
            }
        }
        if $access eq 'write';

# ---- writeonce hashes, initialization is the value -----------------
        *{"$class::$method"} = sub { 
            my($ego) = shift;
            my  $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};
            print "calling $method with @{$args}\n";
            if ( ref $ego->{$attr} and %{$ego->{$attr}} ) {
# complain if trying to set again
            carp "You cannot add values to $method(), skipping!"
                if ref $args and %{$args};
# it's already set, so get
            return wantarray ? %{$ego->{$attr}} : $ego->{$attr};
        }
            $ego->{$attr} = $args;
        }
        if $access eq 'writeonce';

        if ( $access eq 'readonly' ) {
            $ego->{$attr} = $value;
            *{"$class::$method"} = sub {
                my($ego, @keys) = @_;
                my @return_list;
                if ( @keys ) {
                    push @return_list, $ego->{$attr}{$_} for @keys;
                    return wantarray ? @return_list : \@return_list;
                }
                return wantarray ? %{$ego->{$attr}} : $ego->{$attr};
            };
            return;
        }
    }
# HASHES ends -------------------------------------------------------

# if we have been unable to auto install a method 321
    croak "Non-existent method, '$method,' called!\n"
        unless $ego->can($method);

# unless $ego->can($method) at this point throw a croak
    carp 
        "Setting $attr via $method->($value)\n" if $ego->verbosity() > 3;
    $ego->$method($value);
}
#=====================================================================
sub show_attributes {

    my ( $ego ) = @_;
    return grep defined, map { /^_([a-zA-Z]\w*)$/ } keys %{$ego};
}
#=====================================================================
sub _standard_attributes { 

    my ( $ego ) = @_;
    croak "Can't call _standard_attributes() post new()!" 
        unless $ego->{__attributes};
    keys %{$ego->{__attributes}};
}
#=====================================================================
sub _default_for {

    my ( $ego, $attr ) = @_;
    croak "Can't call _default_for() post new()!" 
        unless $ego->{__attributes};
    $ego->{__attributes}{$attr}[0];
}
#=====================================================================
sub _writeable {

    my ( $ego, $attr ) = @_;
    $ego->{__attributes}{$attr}[1] eq 'write';
}
#=====================================================================
sub verbosity {

    my ( $ego, $verbosity ) = @_;

# 0 (off) through 5 (max, not implemented)

    return $ego->{__VERBOSITY} unless defined $verbosity;

    carp "Cannot set verbosity to '$verbosity'!\n" 
        and return 
        unless $verbosity =~ /^[0-5]$/;

    $ego->{__VERBOSITY} = $verbosity;
}
#=====================================================================
sub serial {

    shift if ref($_[0]);

    return unless @_;
    join(', ', @_[0..$#_-1]) . 
        (@_>2 ? ',':'' ) . 
        (@_>1 ? (' and ' . $_[-1]) : $_[-1]);
}
#=====================================================================
sub DESTROY { 1 }
#=====================================================================
sub dump {
# erase this i think 
    my ( $ego ) = shift;
    while ( my ( $key, $value ) = each %{$ego} ) {

        print "$key --> $value";
    }
}
#=====================================================================

}#====================================================================
#  Class::Prototype ENDS
#=====================================================================

    1;  # let's eval true, shall we?

#=====================================================================
