package Class::Accessor::Assert;
use 5.006;
use strict;
use warnings;
use base qw(Class::Accessor Class::Data::Inheritable);
use Carp qw(croak confess);
our $VERSION = '1.40';

sub _mk_accessors {
    my ( $self, $maker, @fields ) = @_;
    $self->mk_classdata("accessor_specs")
      unless $self->can("accessor_specs");

    my %spec = $self->parse_fields(@fields);
    $self->accessor_specs( { %spec, %{ $self->accessor_specs || {} } } );

    $self->SUPER::_mk_accessors( 'rw', keys %spec );

    {
        no strict 'refs';

        # additional methods for magic array methods
        my $class = ref $self || $self;
	# Note how we curry the subs with the lexical "$field":
	# The subs are closures and therefore have access to their lexical
	# scope. Clarity suffers from this, but the performance should be
	# about 25% higher than a cleaner approach due to a saved subroutine
	# call for every ary_*(...) call.
        for my $field ( grep { $spec{$_}{array} } keys %spec ) {
	    # foo_push sub
            *{"${class}::${field}_push"} = sub {
                my ( $self, @values ) = @_;
                $self->{$field} = [] unless defined $self->{$field};
                push @{ $self->{$field} }, @values;
            };
	    # foo_pop sub
            *{"${class}::${field}_pop"} = sub {
                my ( $self ) = @_;
                return pop @{ $self->{$field} || [] };
            };
	    # foo_unshift sub
            *{"${class}::${field}_unshift"} = sub {
                my ( $self, @values ) = @_;
                $self->{$field} = [] unless defined $self->{$field};
                unshift @{ $self->{$field} }, @values;
            };
	    # foo_shift sub
            *{"${class}::${field}_shift"} = sub {
                my ( $self ) = @_;
                return shift @{ $self->{$field} || [] };
            };
        }
    }
}

sub new {
    my ( $self, $stuff ) = @_;
    my $not_a_void_context = eval { %{ $stuff || {} } };
    croak "$stuff doesn't look much like a hash to me" if $@;
    if ( $self->can("accessor_specs") ) {
        my $spec = $self->accessor_specs;
        for my $k ( keys %$spec ) {
            confess "Required member $k not given to constructor"
              if $spec->{$k}->{required}
              and not exists $stuff->{$k};
            confess "Member $k needs to be of type " . $spec->{$k}->{class}
              if exists $spec->{$k}->{class}
              and exists $stuff->{$k}
              and !UNIVERSAL::isa( $stuff->{$k}, $spec->{$k}->{class} );
        }
    }
    return $self->SUPER::new($stuff);
}

sub set {
    return shift->SUPER::set(@_) unless $_[0]->can("accessor_specs");
    my ( $self, $key ) = splice( @_, 0, 2 );
    my $spec = $self->accessor_specs;
    return $self->SUPER::set( $key, @_ )
      if !exists $spec->{$key}
      or @_ > 1;    # No support for arrays
    confess "Member $key needs to be of type " . $spec->{$key}->{class}
      if defined $_[0]
      and exists $spec->{$key}->{class}
      and !UNIVERSAL::isa( $_[0], $spec->{$key}->{class} );

    $_[0] = [ $_[0] ]
      if defined $_[0]
      and $spec->{$key}->{array}
      and ref $_[0] ne 'ARRAY';

    $self->{$key} = $_[0];
}

sub get {
    return shift->SUPER::get(@_) unless $_[0]->can("accessor_specs");
    my ( $self, $key ) = splice( @_, 0, 2 );
    my $spec = $self->accessor_specs;
    return $self->SUPER::get( $key, @_ )
      if !exists $spec->{$key}
      or @_ > 1;    # No support for arrays
    if ( $spec->{$key}{array} ) {
        wantarray
          ? @{ $self->SUPER::get( $key, @_ ) || [] }
          : $self->SUPER::get( $key, @_ );
    }
    else {
        $self->SUPER::get( $key, @_ );
    }
}

sub parse_fields {
    my ( $self, @fields ) = @_;
    my %spec;
    for my $f (@fields) {
        my $orig_f = $f;    # For error reporting
        my %subspec;

        # All the tests go here
        $subspec{required} = $f =~ s/^\+//;
        $f =~ s/=(.*)// and $subspec{class} = $1;
        $subspec{array} = $f =~ s/^\@//;
        $f =~ /^\w+$/
          or croak "Couldn't understand field specification $orig_f";
        $spec{$f} = \%subspec;
    }
    return %spec;
}

1;
__END__

=head1 NAME

Class::Accessor::Assert - Accessors which type-check

=head1 SYNOPSIS

  use Class::Accessor::Assert;
  __PACKAGE__->mk_accessors( qw( +foo bar=Some::Class baz @bits ) );

=head1 DESCRIPTION

This is a version of L<Class::Accessor> which offers rudimentary
type-checking and existence-checking of arguments to constructors
and set accessors. 

To specify that a member is mandatory in the constructor, prefix its
name with a C<+>. To specify that it needs to be of a certain class
when setting that member, suffix C<=CLASSNAME>. Unblessed reference
types such as C<=HASH> or C<=ARRAY> are acceptable.

To specify that a member is an array, prefix its name with a C<@>.
These members also have the following four special methods that wrap
the builtin array operations C<push>, C<pop>, C<unshift>, and 
C<shift>:

    # for a @bits member:
    
    $y->bits_push(@new_values);
    print $y->bits_pop;
    
    $y->bits_unshift(@new_values);
    print $y->bits_shift;

The C<@> can be combined with the C<+> prefix to make a member that
is an array that you must set in the constructor. The C<+> must 
precede the C<@>.

    # 'foo' is required in the constructor
    __PACKAGE__->mk_accessors(qw( +@foo ));

=head1 SEE ALSO

L<Class::Accessor>

=head1 AUTHOR

This module is maintained by

  Steffen Mueller, accessor-module at steffen-mueller dot net

Original author is

  Simon Cozens, simon@simon-cozens.org

Please direct inquiries, bug reports, etc. towards the maintainer, not the
original author. Simon no longer provides support for this module, so please
respect that.

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Simon Cozens

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut