File Coverage

blib/lib/Tie/Array/PackedC.pm

Criterion	Covered	Total	%
statement	156	245	63.6
branch	33	80	41.2
condition	4	12	33.3
subroutine	38	61	62.3
pod	5	6	83.3
total	236	404	58.4

package Tie::Array::PackedC;
use constant ALLOC=>1024;
use constant PACK=>'l!*';
no warnings;
use constant NULL=>pack PACK,"";
use constant SIZE=>length NULL;
use base qw(Tie::Array);
use strict;
use warnings;
our $DEBUG;

sub import {
	if (@_>1 and $_[1]=~/[A-Z]/ and $_[0] eq __PACKAGE__) {
		my ($class,$name,$format,%args)=@_;
		$format.="*" unless $format=~/\*$/;
		my $new=$class."::".$name;
                open my $f,"<",__FILE__ or die __FILE__ . "$!";
		local $_=do {local $/="\n__END__\n"; scalar <$f>};
		close $f;
		s/(?<=package )\w+(::\w+)*;/$new;/;
		s/(?<=PACK)\s*=>'.+';/=>'$format';/;
		s/(?<=ALLOC)\s*=>.+;/=>$args{ALLOC};/ if $args{ALLOC};
		s/(?<=SIZE)\s*=>.+;/=>$args{SIZE};/ if $args{SIZE};
		eval "no warnings; $_";
		warn $_ if $args{DEBUG};
		$@ and die "Failed to build package $new!\n$@\n$_"
	} else {
		__PACKAGE__->export_to_level(1,@_);
	}
}


our @ISA=qw(Exporter);
our $VERSION=0.03;
our @EXPORT_OK=qw(packed_array packed_array_string $DEBUG);

my %count;
my %type;

sub packed_array {
	my (@a,$s);
	tie @a,__PACKAGE__,$s,@_;
	return \@a;
}

sub packed_array_string {
	my @a;
	tie @a,__PACKAGE__,@_;
	return \@a;
}


sub string     { return substr ${$_[0]},0,$count{$_[0]}*SIZE };

sub trim       {
                 #printf STDERR "%d %d %d\n",$count{$_[0]},$count{$_[0]}*SIZE,length(${$_[0]});
                 substr ${$_[0]}, $count{$_[0]}*SIZE, length(${$_[0]}) - ($count{$_[0]}*SIZE), "";
                 return $_[0];
               }

sub reallen    { return $count{$_[0]}*SIZE };

sub hex_dump {
	my @words=map { sprintf "%02x " x SIZE,unpack "C*",pack PACK,$_; }  unpack PACK,${$_[0]};
	for (my $ofs=0;$ofs<@words;$ofs+=4) {
		printf "#%4d : %5d : %s\n",$ofs,$ofs*SIZE,join"| ",grep defined $_,@words[$ofs..$ofs+3]
	}
}


sub DESTROY {
	my $self=shift;
	delete $count{$self};
	delete $type{$self};
}

sub _alloc {
	my ($self,$size)=@_;
	return if $size<$count{$self};
	my $before=length($$self);
	$count{$self}=$size;
	my $alloc=int ($size * 1.2);
	$alloc+=ALLOC - ($alloc % ALLOC);
	$$self.=NULL x ( $alloc - length($$self)/SIZE );
	my $after=length($$self);
	warn "Resize. Reallen:".$self->reallen()." Len: $before -> $after\n" if $DEBUG;
	$self;
}


sub TIEARRAY {
	my ($class,$str,@args)=@_;
	my $strref=@_>1 ? \$_[1] : \do{my $x};
	$$strref="" unless defined $$strref;
	my $self=bless $strref,$class;


	length($$strref) % SIZE and Carp::confess <
Initialized with bad string length! Expecting multiples of @{[SIZE]} bytes,
got @{[length($$strref) % SIZE]} bytes extra.
BAD_LENGTH
	$count{$self}=int length($$strref)/SIZE;
	#preallocate a chunk of memory
	$self->_alloc(scalar @args);
	substr($$self,0,@args*SIZE,pack(PACK,@args));
	$self;
}

sub FETCH {
	my ($s,$o)=@_;
	return undef if $o>=$count{$s};
	return unpack(PACK,substr($$s,$o * SIZE,SIZE));
}

sub STORE {
	my ($s,$o,$v)=@_;
	$s->_alloc($o+1) if length($$s)<($o+1)*SIZE;
	$count{$s}=$o+1 if $count{$s}<=$o;
	substr($$s,$o * SIZE,SIZE)=pack(PACK,$v);
	$v
}

sub FETCHSIZE {$count{shift(@_)}}

sub STORESIZE {
	my ($s,$l)=@_;
	#print "STORESIZE $l\n";
	$s->_alloc($l+1);
	substr($$s,int($l*SIZE/ALLOC+1)*ALLOC)='';
	$s
}

sub EXTEND {
	my ($s,$l)=@_;
	$s->STORESIZE($l);
}

sub POP{
	my ($s)=@_;
	length($$s) ? unpack PACK,substr($$s,--$count{$s}*SIZE,SIZE,NULL) : undef
}

sub PUSH{
	my ($s,@args)=@_;
	return unless @args;
	my $tail=$count{$s}*SIZE;
	if (($count{$s}+@args)*SIZE>length($$s)) {
		$s->_alloc($count{$s}+@args);
	} else {
		$count{$s}+=@args;
	}
	substr($$s,$tail,@args*SIZE)=pack(PACK,@args);

}

sub CLEAR { ${$_[0]}=NULL x (ALLOC/SIZE); $count{$_[0]}=0 }

sub SHIFT {
	my ($s)=@_;
	length($$s) ? unpack PACK,substr($$s,0,SIZE,'') : undef
}
sub UNSHIFT {
	my ($s,@args)=@_;
	$$s=pack(PACK,@args).$$s;
}

sub EXISTS { $_[1] < $count{$_[0]}  }
sub DELETE {
	my ($s,$o)=@_;
	return unless $o < $count{$s};
	my $v=unpack PACK,substr($$s,$o * SIZE,SIZE);
	substr($$s,$o * SIZE,SIZE,NULL);
	return $v
}

#sub SPLICE {
#
#}

1;


__END__