File Coverage

blib/lib/Class/Accessor/PackedString.pm

Criterion	Covered	Total	%
statement	92	124	74.1
branch	17	40	42.5
condition	2	2	100.0
subroutine	5	6	83.3
pod			n/a
total	116	172	67.4

package Class::Accessor::PackedString;

our $DATE = '2017-09-01'; # DATE
our $VERSION = '0.001'; # VERSION

#IFUNBUILT
# use strict 'subs', 'vars';
# use warnings;
#END IFUNBUILT

sub import {
    my ($class0, $spec) = @_;
    my $caller = caller();

    my $class = $caller;

#IFUNBUILT
#     no warnings 'redefine';
#END IFUNBUILT

    my $attrs = $spec->{accessors};

    # store list of accessors in the package
    {
#IFUNBUILT
#         no warnings 'once';
#END IFUNBUILT
        %{"$class\::HAS_PACKED"} = %$attrs;
    }

    # generate accessors
    my %idx; # key = attribute name, value = index
    my $pack_template = "";
    for my $attr (sort keys %$attrs) {
        $idx{$attr} = keys(%idx);
        $pack_template .= $attrs->{$attr};
    }
    my $num_attrs = keys %$attrs;

    for my $attr (keys %$attrs) {
        my $idx = $idx{$attr};
        my $code_str = 'sub (;$) {';
        $code_str .= qq( my \$self = shift;);
        $code_str .= qq( my \@attrs = unpack("$pack_template", \$\$self););
        $code_str .= qq( if (\@_) { \$attrs[$idx] = \$_[0]; \$\$self = pack("$pack_template", \@attrs) });
        $code_str .= qq( return \$attrs[$idx];);
        $code_str .= " }";
        #print "D:accessor code for $attr: ", $code_str, "\n";
        *{"$class\::$attr"} = eval $code_str;
        die if $@;
    }

    # generate constructor
    {
        my $code_str;
        $code_str  = 'sub { my ($class, %args) = @_;';
        $code_str .= qq( no warnings 'uninitialized';);
        $code_str .= qq( my \@attrs = map { undef } 1..$num_attrs;);
        for my $attr (sort keys %$attrs) {
            my $idx = $idx{$attr};
            $code_str .= qq( if (exists \$args{'$attr'}) { \$attrs[$idx] = delete \$args{'$attr'} });
        }
        $code_str .= ' die "Unknown $class attributes in constructor: ".join(", ", sort keys %args) if keys %args;';
        $code_str .= qq( my \$self = pack('$pack_template', \@attrs); bless \\\$self, '$class';);
        $code_str .= ' }';

        #print "D:constructor code for class $class: ", $code_str, "\n";
        my $constructor = $spec->{constructor} || "new";
        unless (*{"$class\::$constructor"}{CODE}) {
            *{"$class\::$constructor"} = eval $code_str;
            die if $@;
        };
    }
}

1;
# ABSTRACT: Generate accessors/constructor for object that use pack()-ed string as storage backend

__END__