File Coverage

blib/lib/Class/XSAccessor/Array.pm

Criterion	Covered	Total	%
statement	56	57	98.2
branch	21	24	87.5
condition	19	20	95.0
subroutine	9	9	100.0
pod			n/a
total	105	110	95.4

package Class::XSAccessor::Array;
use 5.008;
use strict;
use warnings;
use Carp qw/croak/;
use Class::XSAccessor;
use Class::XSAccessor::Heavy;

our $VERSION = '1.19';

sub import {
  my $own_class = shift;
  my ($caller_pkg) = caller();

  # Support both { getters => ... } and plain getters => ...
  my %opts = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;

  $caller_pkg = $opts{class} if defined $opts{class};

  my $read_subs      = $opts{getters} || {};
  my $set_subs       = $opts{setters} || {};
  my $acc_subs       = $opts{accessors} || {};
  my $lvacc_subs     = $opts{lvalue_accessors} || {};
  my $pred_subs      = $opts{predicates} || {};
  my $construct_subs = $opts{constructors} || [defined($opts{constructor}) ? $opts{constructor} : ()];
  my $true_subs      = $opts{true} || [];
  my $false_subs     = $opts{false} || [];


  foreach my $subtype ( ["getter", $read_subs],
                        ["setter", $set_subs],
                        ["accessor", $acc_subs],
                        ["lvalue_accessor", $lvacc_subs],
                        ["pred_subs", $pred_subs] )
  {
    my $subs = $subtype->[1];
    foreach my $subname (keys %$subs) {
      my $array_index = $subs->{$subname};
      _generate_method($caller_pkg, $subname, $array_index, \%opts, $subtype->[0]);
    }
  }

  foreach my $subtype ( ["constructor", $construct_subs],
                        ["true", $true_subs],
                        ["false", $false_subs] )
  {
    foreach my $subname (@{$subtype->[1]}) {
      _generate_method($caller_pkg, $subname, "", \%opts, $subtype->[0]);
    }
  }
}

sub _generate_method {
  my ($caller_pkg, $subname, $array_index, $opts, $type) = @_;

  croak("Cannot use undef as a array index for generating an XS $type accessor. (Sub: $subname)")
    if not defined $array_index;

  $subname = "${caller_pkg}::$subname" if $subname !~ /::/;

  Class::XSAccessor::Heavy::check_sub_existence($subname) if not $opts->{replace};
  no warnings 'redefine'; # don't warn about an explicitly requested redefine

  if ($type eq 'getter') {
    newxs_getter($subname, $array_index);
  }
  if ($type eq 'lvalue_accessor') {
    newxs_lvalue_accessor($subname, $array_index);
  }
  elsif ($type eq 'setter') {
    newxs_setter($subname, $array_index, $opts->{chained}||0);
  }
  elsif ($type eq 'predicate') {
    newxs_predicate($subname, $array_index);
  }
  elsif ($type eq 'constructor') {
    newxs_constructor($subname);
  }
  elsif ($type eq 'true') {
    Class::XSAccessor::newxs_boolean($subname, 1);
  }
  elsif ($type eq 'false') {
    Class::XSAccessor::newxs_boolean($subname, 0);
  }
  else {
    newxs_accessor($subname, $array_index, $opts->{chained}||0);
  }
}

1;

__END__