File Coverage

blib/lib/Class/XSAccessor.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	31	32	96.8
condition	25	26	96.1
subroutine	10	10	100.0
pod			n/a
total	134	136	98.5

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

our $VERSION = '1.19';

XSLoader::load('Class::XSAccessor', $VERSION);

sub _make_hash {
  my $ref = shift;

  if (ref ($ref)) {
    if (ref($ref) eq 'ARRAY') {
      $ref = { map { $_ => $_ } @$ref }
    }
  } else {
    $ref = { $ref, $ref };
  }

  return $ref;
}

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};

  # TODO: Refactor. Move more duplicated code to ::Heavy
  my $read_subs      = _make_hash($opts{getters} || {});
  my $set_subs       = _make_hash($opts{setters} || {});
  my $acc_subs       = _make_hash($opts{accessors} || {});
  my $lvacc_subs     = _make_hash($opts{lvalue_accessors} || {});
  my $pred_subs      = _make_hash($opts{predicates} || {});
  my $ex_pred_subs   = _make_hash($opts{exists_predicates} || {});
  my $def_pred_subs  = _make_hash($opts{defined_predicates} || {});
  my $test_subs      = _make_hash($opts{__tests__} || {});
  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],
                        ["test", $test_subs],
                        ["ex_predicate", $ex_pred_subs],
                        ["def_predicate", $def_pred_subs],
                        ["def_predicate", $pred_subs] )
  {
    my $subs = $subtype->[1];
    foreach my $subname (keys %$subs) {
      my $hashkey = $subs->{$subname};
      _generate_method($caller_pkg, $subname, $hashkey, \%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, $hashkey, $opts, $type) = @_;

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

  $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, $hashkey);
  }
  elsif ($type eq 'lvalue_accessor') {
    newxs_lvalue_accessor($subname, $hashkey);
  }
  elsif ($type eq 'setter') {
    newxs_setter($subname, $hashkey, $opts->{chained}||0);
  }
  elsif ($type eq 'def_predicate') {
    newxs_defined_predicate($subname, $hashkey);
  }
  elsif ($type eq 'ex_predicate') {
    newxs_exists_predicate($subname, $hashkey);
  }
  elsif ($type eq 'constructor') {
    newxs_constructor($subname);
  }
  elsif ($type eq 'true') {
    newxs_boolean($subname, 1);
  }
  elsif ($type eq 'false') {
    newxs_boolean($subname, 0);
  }
  elsif ($type eq 'test') {
    newxs_test($subname, $hashkey);
  }
  else {
    newxs_accessor($subname, $hashkey, $opts->{chained}||0);
  }
}

1;

__END__