File Coverage

blib/lib/Class/Accessor/Validated.pm

Criterion	Covered	Total	%
statement	64	68	94.1
branch	17	18	94.4
condition	5	9	55.5
subroutine	10	11	90.9
pod	2	2	100.0
total	98	108	90.7

package Class::Accessor::Validated;

use strict;
use warnings;

use Class::Accessor::Fast;
use Class::Accessor;

use Exporter qw(import);

our @EXPORT_OK = qw(setup_accessors);
our $VERSION   = '0.04';

our $FOLLOW_BAD_PRACTICE = 0;

use parent qw(Exporter Class::Accessor::Fast);

########################################################################
sub new {
########################################################################
  my ( $class, @args ) = @_;

  my $arg_ref = ref $args[0] ? $args[0] : {@args};

  my @bad_keys;

  for my $maybe_valid_key ( keys %{$arg_ref} ) {
    my $follows_best_practice = $class->can("set_$maybe_valid_key") && $class->can("get_$maybe_valid_key");

    my $follows_bad_practice = $FOLLOW_BAD_PRACTICE && $class->can($maybe_valid_key);

    next if $follows_best_practice || $follows_bad_practice;

    push @bad_keys, $maybe_valid_key;
  }

  no strict 'refs';

  my %required_keys;

  for my $ancestor_class ( reverse _linear_isa($class) ) {
    my $symbol   = $ancestor_class . '::ATTRIBUTES';
    my $attr_ref = *{$symbol}{HASH};
    next if !$attr_ref;

    %required_keys = ( %required_keys, %{$attr_ref} );
  }

  my @missing_required_keys;

  for my $maybe_required_key ( keys %required_keys ) {
    next if !$required_keys{$maybe_required_key};
    next if exists $arg_ref->{$maybe_required_key};
    push @missing_required_keys, $maybe_required_key;
  }

  my @errors;

  if (@bad_keys) {
    push @errors, 'invalid argument(s): ' . join ', ', @bad_keys;
  }

  if (@missing_required_keys) {
    push @errors, 'required argument(s): ' . join ', ', @missing_required_keys;
  }

  if (@errors) {
    die join '; ', @errors;
  }

  return $class->SUPER::new($arg_ref);
}

########################################################################
sub setup_accessors {
########################################################################
  my ( $class, @keys ) = @_;
  Class::Accessor->follow_best_practice($class);
  Class::Accessor::Fast->mk_accessors( $class, @keys );

  return 1;
}

########################################################################
sub _linear_isa {
########################################################################
  my ($start_class) = @_;

  no strict 'refs';  ## no critic

  my @isa_list;
  my %seen;
  my @queue = ($start_class);

  while ( my $current = shift @queue ) {
    next if $seen{$current};
    $seen{$current} = 1;
    push @isa_list, $current;
    unshift @queue, @{ $current . '::ISA' };
  }

  return @isa_list;
}

1;

__END__