File Coverage

blib/lib/Class/Accessor/Array/Slurpy.pm
Criterion Covered Total %
statement 62 68 91.1
branch 18 36 50.0
condition 7 10 70.0
subroutine 7 7 100.0
pod n/a
total 94 121 77.6


line stmt bran cond sub pod time code
1             package Class::Accessor::Array::Slurpy;
2              
3             our $DATE = '2017-09-13'; # DATE
4             our $VERSION = '0.020'; # VERSION
5              
6 1     1   58184 use 5.010001;
  1         3  
7 1     1   24 use strict 'subs', 'vars';
  1         2  
  1         26  
8 1     1   5 use warnings;
  1         4  
  1         47  
9              
10             sub import {
11 2     2   250 my ($class0, $spec) = @_;
12 2         5 my $caller = caller();
13              
14 1     1   6 no warnings 'redefine';
  1         2  
  1         261  
15              
16 2         2 my $max_idx;
17 2         3 for (values %{$spec->{accessors}}) {
  2         8  
18 8 100 66     44 $max_idx = $_ if !defined($max_idx) || $max_idx < $_;
19             }
20              
21 2         4 my $slurpy_attribute = $spec->{slurpy_attribute};
22              
23             # generate accessors
24 2         3 for my $meth (keys %{$spec->{accessors}}) {
  2         5  
25 8         15 my $idx = $spec->{accessors}{$meth};
26 8         10 my $is = 'rw';
27 8 50       16 my $code_str = $is eq 'rw' ? 'sub (;$) { ' : 'sub () { ';
28 8 100 100     32 if (defined($slurpy_attribute) && $slurpy_attribute eq $meth) {
29 1 50       4 die "Slurpy attribute must be put at the last index"
30             unless $idx == $max_idx;
31 1 50       5 $code_str .= "splice(\@{\$_[0]}, $idx, scalar(\@{\$_[0]}), \@{\$_[1]}) if \@_ > 1; "
32             if $is eq 'rw';
33 1         3 $code_str .= "[ \@{\$_[0]}[$idx .. \$#{\$_[0]}] ]; ";
34             } else {
35 7 50       19 $code_str .= "\$_[0][$idx] = \$_[1] if \@_ > 1; "
36             if $is eq 'rw';
37 7         10 $code_str .= "\$_[0][$idx]; ";
38             }
39 8         11 $code_str .= "}";
40             #say "D:accessor code for $meth: ", $code_str;
41 8 50   1   575 *{"$caller\::$meth"} = eval $code_str;
  8 50       37  
  1 50       23  
  1 50       4  
  1 0       2  
  1 0       4  
  1 50       3  
  1 0       4  
  1         3  
  1         56  
  1         5  
  1         23  
  1         3  
  1         27  
  1         3  
  0         0  
  0         0  
  0         0  
  0         0  
  1         35  
  1         3  
  0         0  
  0         0  
42 8 50       25 die if $@;
43             }
44              
45             # generate constructor
46             {
47 2 100 50     3 my $n = ($max_idx // 0) + 1; $n-- if defined $slurpy_attribute;
  2         5  
  2         5  
48 2         5 my $code_str = 'sub { my $class = shift; bless [(undef) x '.$n.'], $class }';
49              
50             #say "D:constructor code for class $caller: ", $code_str;
51 2   50     8 my $constructor = $spec->{constructor} || "new";
52 2 50       3 unless (*{"$caller\::$constructor"}{CODE}) {
  2         10  
53 2     1   115 *{"$caller\::$constructor"} = eval $code_str;
  2         7  
  1         111  
  1         6  
  1         1092  
  1         30  
54 2 50       38 die if $@;
55             };
56             }
57             }
58              
59             1;
60             # ABSTRACT: Generate accessors/constructor for array-based object (supports slurpy attribute)
61              
62             __END__