File Coverage

blib/lib/Class/Accessor/PackedString/Set.pm

Criterion	Covered	Total	%
statement	136	219	62.1
branch	47	114	41.2
condition	8	23	34.7
subroutine	3	3	100.0
pod			n/a
total	194	359	54.0

package Class::Accessor::PackedString::Set;

our $DATE = '2017-10-15'; # 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 %tmpl    ; # key = attribute name, value = pack() template
    my %tmplsize; # key = attribute name, value = pack() data size
    my @attrs = @$attrs;
    while (my ($name, $template) = splice @attrs, 0, 2) {
        $idx{$name}      = keys %idx;
        $tmpl{$name}     = $template;
        $tmplsize{$name} = length(pack $template);
    }

    @attrs = @$attrs;
    while (my ($name, $template) = splice @attrs, 0, 2) {
        my $idx = $idx{$name};
        my $code_str = 'sub (;$) {' . "\n";
        $code_str .= qq(  my \$self = shift;\n);

        $code_str .= qq(  my \$val;\n  my \$pos = 0;\n  while (1) {\n    last if \$pos >= length(\$\$self);\n    my \$idx = ord(substr(\$\$self, \$pos++, 1));\n);
        for my $attr (sort {$idx{$a} <=> $idx{$b}} keys %idx) {
            my $idx = $idx{$attr};
            $code_str .= qq|    |.($idx == 0 ? "if   " : "elsif").qq| (\$idx == $idx) { my \$v = unpack("| . $tmpl{$attr} . qq|", substr(\$\$self, \$pos, | . $tmplsize{$attr} . qq|));|;
            if ($attr eq $name) {
                $code_str .= qq| \$val = \$v; if (\@_ && defined \$_[0]) { substr(\$\$self, \$pos, | . $tmplsize{$attr} . qq|) = pack("| . $tmpl{$attr} . qq|", \$_[0]); return \$val } last|;
            } else {
                $code_str .= qq| \$pos += | . $tmplsize{$attr} . qq|; next|;
            }
            $code_str .= qq| }\n|;
        }
        $code_str .= qq(    else  { die "Invalid data in object \$self: invalid index \$idx" }\n);
        $code_str .= qq(  }\n);

        $code_str .= qq(  return \$val unless \@_;\n);
        $code_str .= qq(  if (defined \$_[0]) {\n); # set a newly set attribute, append
        $code_str .= qq|    \$\$self .= chr($idx) . pack("|. $tmpl{$name} . qq|", \$_[0]);\n|;
        $code_str .= qq(  } elsif (defined \$val) {\n); # delete unset attribute
        $code_str .= qq|    substr(\$\$self, \$pos-1, | . $tmplsize{$name} . qq|+1) = "";\n|;
        $code_str .= qq(  }\n);
        $code_str .= qq(  return \$val;\n);
        $code_str .= "}\n";
        #print "D:accessor code for $name: ", $code_str, "\n";
        *{"$class\::$name"} = eval $code_str;
        die if $@;
    }

    # generate constructor
    {
        my $code_str;

        $code_str = 'sub { my $o = ""; bless \$o, shift }';

        # TODO

        #$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: Like Class::Accessor::PackedString, but store attributes as they are set

__END__