sub new_array { my @a; tie @a,shift,@_; return \@a; } sub TIEARRAY { my $class = shift; return $_[1] if @_ && !ref($_[0]) && $_[0] eq 'tie_to_object'; $class->new(@_); } sub EXTEND { my($self,$newsize) = @_; # do nothing return; } sub CLEAR { my($self) = @_; my $array = $self->{STRREF}; my $_off_packstr = $self->{OFFSET}; $$array .= "\0" x $_off_packstr if length($$array) < $_off_packstr; substr($$array,$_off_packstr) = ""; return; } sub FETCHSIZE { my($self) = @_; my $array = $self->{STRREF}; my $size; $size = int((length($$array) - $self->{OFFSET}) / 1); return $size; } sub STORESIZE { my($self,$newsize) = @_; my $array = $self->{STRREF}; my $_newlen_packstr = ($newsize * 1) + $self->{OFFSET}; my $_delta_packstr = $_newlen_packstr - length($$array); $$array .= "\0" x $_delta_packstr; substr($$array,$_newlen_packstr) = ""; return; } sub FETCH { my($self,$index) = @_; my $value; my $array = $self->{STRREF}; my $_idx_packstr = ($self->{OFFSET} + ($index * 1)); $value = ( $_idx_packstr >= length($$array) ? undef : unpack("C",substr($$array, $_idx_packstr ,1)) ); return $value; } sub STORE { my($self,$index,$value) = @_; my $array = $self->{STRREF}; my $size; $size = int((length($$array) - $self->{OFFSET}) / 1); if($index > $size) { my $sz = $index; $$array .= "\0" x ((($sz * 1) + $self->{OFFSET}) - length($$array)); } substr($$array,$self->{OFFSET} + ($index * 1),1) = pack("C",$value); return; } sub EXISTS { my($self,$index) = @_; my $exists; my $array = $self->{STRREF}; my $size; $size = int((length($$array) - $self->{OFFSET}) / 1); $exists = ($index >= -$size) && ($index < $size); return $exists; } sub DELETE { my($self,$index) = @_; my $value; confess(ref($self)." doesn't support DELETE"); return $value; } sub POP { my($self) = @_; my $value; my $size = $self->FETCHSIZE(); if($size >= 1) { $value = $self->FETCH($size -1); $self->STORESIZE($size -1); }; return $value; } sub SHIFT { my($self) = @_; my $value; ($value) = $self->SPLICE(0,1); return $value; } sub PUSH { my($self,@values) = @_; my $size = $self->FETCHSIZE(); my $_i = $size; $self->EXTEND($size + @values); foreach my $value (@values) { $self->STORE($_i++,$value); } return; } sub UNSHIFT { my($self,@values) = @_; $self->SPLICE(0,0,@values); return; } sub SPLICE { my $self = shift; my $index = @_ ? shift : 0; my $length = @_ ? shift : undef; my @values = @_; my @old_values; my $size = $self->FETCHSIZE(); $index += $size if ($index < 0); $length = $size - $index if !defined $length; $length += $size - $index if $length < 0; for (my $i = 0; $i < $length; $i++) { push(@old_values, $self->FETCH($index + $i)); } $index = $size if $index > $size; $length -= $index + $length - $size if $index + $length > $size; if (@values > $length) { # Move items up to make room my $d = @values - $length; my $e = $index+$length; $self->EXTEND($size + $d); for (my $i=$size-1; $i >= $e; $i--) { $self->STORE($i+$d, $self->FETCH($i)); } } elsif (@values < $length) { # Move items down to close the gap my $d = $length - @values; my $e = $index+$length; for (my $i=$index+$length; $i < $size; $i++) { $self->STORE($i-$d, $self->FETCH($i)); } $self->STORESIZE($size-$d); } for (my $i=0; $i < @values; $i++) { $self->STORE($index+$i, $values[$i]); } # return wantarray ? @old_values : pop @old_values; return wantarray ? @old_values : pop @old_values; }