| Server IP : 170.10.162.208 / Your IP : 216.73.216.181 Web Server : LiteSpeed System : Linux altar19.supremepanel19.com 4.18.0-553.69.1.lve.el8.x86_64 #1 SMP Wed Aug 13 19:53:59 UTC 2025 x86_64 User : deltahospital ( 1806) PHP Version : 7.4.33 Disable Function : NONE MySQL : OFF | cURL : ON | WGET : ON | Perl : ON | Python : ON | Sudo : OFF | Pkexec : OFF Directory : /home/deltahospital/test.delta-hospital.com/ |
Upload File : |
RefHash.pm 0000644 00000014135 15051126340 0006423 0 ustar 00 package Tie::RefHash;
use vars qw/$VERSION/;
$VERSION = "1.39";
use 5.005;
=head1 NAME
Tie::RefHash - use references as hash keys
=head1 SYNOPSIS
require 5.004;
use Tie::RefHash;
tie HASHVARIABLE, 'Tie::RefHash', LIST;
tie HASHVARIABLE, 'Tie::RefHash::Nestable', LIST;
untie HASHVARIABLE;
=head1 DESCRIPTION
This module provides the ability to use references as hash keys if you
first C<tie> the hash variable to this module. Normally, only the
keys of the tied hash itself are preserved as references; to use
references as keys in hashes-of-hashes, use Tie::RefHash::Nestable,
included as part of Tie::RefHash.
It is implemented using the standard perl TIEHASH interface. Please
see the C<tie> entry in perlfunc(1) and perltie(1) for more information.
The Nestable version works by looking for hash references being stored
and converting them to tied hashes so that they too can have
references as keys. This will happen without warning whenever you
store a reference to one of your own hashes in the tied hash.
=head1 EXAMPLE
use Tie::RefHash;
tie %h, 'Tie::RefHash';
$a = [];
$b = {};
$c = \*main;
$d = \"gunk";
$e = sub { 'foo' };
%h = ($a => 1, $b => 2, $c => 3, $d => 4, $e => 5);
$a->[0] = 'foo';
$b->{foo} = 'bar';
for (keys %h) {
print ref($_), "\n";
}
tie %h, 'Tie::RefHash::Nestable';
$h{$a}->{$b} = 1;
for (keys %h, keys %{$h{$a}}) {
print ref($_), "\n";
}
=head1 THREAD SUPPORT
L<Tie::RefHash> fully supports threading using the C<CLONE> method.
=head1 STORABLE SUPPORT
L<Storable> hooks are provided for semantically correct serialization and
cloning of tied refhashes.
=head1 RELIC SUPPORT
This version of Tie::RefHash seems to no longer work with 5.004. This has not
been throughly investigated. Patches welcome ;-)
=head1 LICENSE
This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself
=head1 MAINTAINER
Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
=head1 AUTHOR
Gurusamy Sarathy gsar@activestate.com
'Nestable' by Ed Avis ed@membled.com
=head1 SEE ALSO
perl(1), perlfunc(1), perltie(1)
=cut
use Tie::Hash;
use vars '@ISA';
@ISA = qw(Tie::Hash);
use strict;
use Carp qw/croak/;
BEGIN {
local $@;
# determine whether we need to take care of threads
use Config ();
my $usethreads = $Config::Config{usethreads}; # && exists $INC{"threads.pm"}
*_HAS_THREADS = $usethreads ? sub () { 1 } : sub () { 0 };
*_HAS_SCALAR_UTIL = eval { require Scalar::Util; 1 } ? sub () { 1 } : sub () { 0 };
*_HAS_WEAKEN = defined(&Scalar::Util::weaken) ? sub () { 1 } : sub () { 0 };
}
BEGIN {
# create a refaddr function
local $@;
if ( _HAS_SCALAR_UTIL ) {
Scalar::Util->import("refaddr");
} else {
require overload;
*refaddr = sub {
if ( overload::StrVal($_[0]) =~ /\( 0x ([a-zA-Z0-9]+) \)$/x) {
return $1;
} else {
die "couldn't parse StrVal: " . overload::StrVal($_[0]);
}
};
}
}
my (@thread_object_registry, $count); # used by the CLONE method to rehash the keys after their refaddr changed
sub TIEHASH {
my $c = shift;
my $s = [];
bless $s, $c;
while (@_) {
$s->STORE(shift, shift);
}
if (_HAS_THREADS ) {
if ( _HAS_WEAKEN ) {
# remember the object so that we can rekey it on CLONE
push @thread_object_registry, $s;
# but make this a weak reference, so that there are no leaks
Scalar::Util::weaken( $thread_object_registry[-1] );
if ( ++$count > 1000 ) {
# this ensures we don't fill up with a huge array dead weakrefs
@thread_object_registry = grep { defined } @thread_object_registry;
$count = 0;
}
} else {
$count++; # used in the warning
}
}
return $s;
}
my $storable_format_version = join("/", __PACKAGE__, "0.01");
sub STORABLE_freeze {
my ( $self, $is_cloning ) = @_;
my ( $refs, $reg ) = @$self;
return ( $storable_format_version, [ values %$refs ], $reg || {} );
}
sub STORABLE_thaw {
my ( $self, $is_cloning, $version, $refs, $reg ) = @_;
croak "incompatible versions of Tie::RefHash between freeze and thaw"
unless $version eq $storable_format_version;
@$self = ( {}, $reg );
$self->_reindex_keys( $refs );
}
sub CLONE {
my $pkg = shift;
if ( $count and not _HAS_WEAKEN ) {
warn "Tie::RefHash is not threadsafe without Scalar::Util::weaken";
}
# when the thread has been cloned all the objects need to be updated.
# dead weakrefs are undefined, so we filter them out
@thread_object_registry = grep { defined && do { $_->_reindex_keys; 1 } } @thread_object_registry;
$count = 0; # we just cleaned up
}
sub _reindex_keys {
my ( $self, $extra_keys ) = @_;
# rehash all the ref keys based on their new StrVal
%{ $self->[0] } = map { refaddr($_->[0]) => $_ } (values(%{ $self->[0] }), @{ $extra_keys || [] });
}
sub FETCH {
my($s, $k) = @_;
if (ref $k) {
my $kstr = refaddr($k);
if (defined $s->[0]{$kstr}) {
$s->[0]{$kstr}[1];
}
else {
undef;
}
}
else {
$s->[1]{$k};
}
}
sub STORE {
my($s, $k, $v) = @_;
if (ref $k) {
$s->[0]{refaddr($k)} = [$k, $v];
}
else {
$s->[1]{$k} = $v;
}
$v;
}
sub DELETE {
my($s, $k) = @_;
(ref $k)
? (delete($s->[0]{refaddr($k)}) || [])->[1]
: delete($s->[1]{$k});
}
sub EXISTS {
my($s, $k) = @_;
(ref $k) ? exists($s->[0]{refaddr($k)}) : exists($s->[1]{$k});
}
sub FIRSTKEY {
my $s = shift;
keys %{$s->[0]}; # reset iterator
keys %{$s->[1]}; # reset iterator
$s->[2] = 0; # flag for iteration, see NEXTKEY
$s->NEXTKEY;
}
sub NEXTKEY {
my $s = shift;
my ($k, $v);
if (!$s->[2]) {
if (($k, $v) = each %{$s->[0]}) {
return $v->[0];
}
else {
$s->[2] = 1;
}
}
return each %{$s->[1]};
}
sub CLEAR {
my $s = shift;
$s->[2] = 0;
%{$s->[0]} = ();
%{$s->[1]} = ();
}
package Tie::RefHash::Nestable;
use vars '@ISA';
@ISA = 'Tie::RefHash';
sub STORE {
my($s, $k, $v) = @_;
if (ref($v) eq 'HASH' and not tied %$v) {
my @elems = %$v;
tie %$v, ref($s), @elems;
}
$s->SUPER::STORE($k, $v);
}
1;
Handle.pm 0000644 00000010152 15051126340 0006271 0 ustar 00 package Tie::Handle;
use 5.006_001;
our $VERSION = '4.2';
# Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility
# loading Tie::Handle has to make Tie::StdHandle available.
use Tie::StdHandle;
=head1 NAME
Tie::Handle - base class definitions for tied handles
=head1 SYNOPSIS
package NewHandle;
require Tie::Handle;
@ISA = qw(Tie::Handle);
sub READ { ... } # Provide a needed method
sub TIEHANDLE { ... } # Overrides inherited method
package main;
tie *FH, 'NewHandle';
=head1 DESCRIPTION
This module provides some skeletal methods for handle-tying classes. See
L<perltie> for a list of the functions required in tying a handle to a package.
The basic B<Tie::Handle> package provides a C<new> method, as well as methods
C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>.
For developers wishing to write their own tied-handle classes, the methods
are summarized below. The L<perltie> section not only documents these, but
has sample code as well:
=over 4
=item TIEHANDLE classname, LIST
The method invoked by the command C<tie *glob, classname>. Associates a new
glob instance with the specified class. C<LIST> would represent additional
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
complete the association.
=item WRITE this, scalar, length, offset
Write I<length> bytes of data from I<scalar> starting at I<offset>.
=item PRINT this, LIST
Print the values in I<LIST>
=item PRINTF this, format, LIST
Print the values in I<LIST> using I<format>
=item READ this, scalar, length, offset
Read I<length> bytes of data into I<scalar> starting at I<offset>.
=item READLINE this
Read a single line
=item GETC this
Get a single character
=item CLOSE this
Close the handle
=item OPEN this, filename
(Re-)open the handle
=item BINMODE this
Specify content is binary
=item EOF this
Test for end of file.
=item TELL this
Return position in the file.
=item SEEK this, offset, whence
Position the file.
Test for end of file.
=item DESTROY this
Free the storage associated with the tied handle referenced by I<this>.
This is rarely needed, as Perl manages its memory quite well. But the
option exists, should a class wish to perform specific actions upon the
destruction of an instance.
=back
=head1 MORE INFORMATION
The L<perltie> section contains an example of tying handles.
=head1 COMPATIBILITY
This version of Tie::Handle is neither related to nor compatible with
the Tie::Handle (3.0) module available on CPAN. It was due to an
accident that two modules with the same name appeared. The namespace
clash has been cleared in favor of this module that comes with the
perl core in September 2000 and accordingly the version number has
been bumped up to 4.0.
=cut
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIEHANDLE(@_);
}
# "Grandfather" the new, a la Tie::Hash
sub TIEHANDLE {
my $pkg = shift;
if (defined &{"{$pkg}::new"}) {
warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing");
$pkg->new(@_);
}
else {
croak "$pkg doesn't define a TIEHANDLE method";
}
}
sub PRINT {
my $self = shift;
if($self->can('WRITE') != \&WRITE) {
my $buf = join(defined $, ? $, : "",@_);
$buf .= $\ if defined $\;
$self->WRITE($buf,length($buf),0);
}
else {
croak ref($self)," doesn't define a PRINT method";
}
}
sub PRINTF {
my $self = shift;
if($self->can('WRITE') != \&WRITE) {
my $buf = sprintf(shift,@_);
$self->WRITE($buf,length($buf),0);
}
else {
croak ref($self)," doesn't define a PRINTF method";
}
}
sub READLINE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a READLINE method";
}
sub GETC {
my $self = shift;
if($self->can('READ') != \&READ) {
my $buf;
$self->READ($buf,1);
return $buf;
}
else {
croak ref($self)," doesn't define a GETC method";
}
}
sub READ {
my $pkg = ref $_[0];
croak "$pkg doesn't define a READ method";
}
sub WRITE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a WRITE method";
}
sub CLOSE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a CLOSE method";
}
1;
SubstrHash.pm 0000644 00000012434 15051126340 0007171 0 ustar 00 package Tie::SubstrHash;
our $VERSION = '1.00';
=head1 NAME
Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
=head1 SYNOPSIS
require Tie::SubstrHash;
tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
=head1 DESCRIPTION
The B<Tie::SubstrHash> package provides a hash-table-like interface to
an array of determinate size, with constant key size and record size.
Upon tying a new hash to this package, the developer must specify the
size of the keys that will be used, the size of the value fields that the
keys will index, and the size of the overall table (in terms of key-value
pairs, not size in hard memory). I<These values will not change for the
duration of the tied hash>. The newly-allocated hash table may now have
data stored and retrieved. Efforts to store more than C<$table_size>
elements will result in a fatal error, as will efforts to store a value
not exactly C<$value_len> characters in length, or reference through a
key not exactly C<$key_len> characters in length. While these constraints
may seem excessive, the result is a hash table using much less internal
memory than an equivalent freely-allocated hash table.
=head1 CAVEATS
Because the current implementation uses the table and key sizes for the
hashing algorithm, there is no means by which to dynamically change the
value of any of the initialization parameters.
The hash does not support exists().
=cut
use Carp;
sub TIEHASH {
my $pack = shift;
my ($klen, $vlen, $tsize) = @_;
my $rlen = 1 + $klen + $vlen;
$tsize = [$tsize,
findgteprime($tsize * 1.1)]; # Allow 10% empty.
local $self = bless ["\0", $klen, $vlen, $tsize, $rlen, 0, -1];
$$self[0] x= $rlen * $tsize->[1];
$self;
}
sub CLEAR {
local($self) = @_;
$$self[0] = "\0" x ($$self[4] * $$self[3]->[1]);
$$self[5] = 0;
$$self[6] = -1;
}
sub FETCH {
local($self,$key) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
return undef;
}
elsif (ord($record) == 1) {
}
elsif (substr($record, 1, $klen) eq $key) {
return substr($record, 1+$klen, $vlen);
}
&rehash;
}
}
sub STORE {
local($self,$key,$val) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
croak("Table is full ($tsize->[0] elements)") if $$self[5] > $tsize->[0];
croak(qq/Value "$val" is not $vlen characters long/)
if length($val) != $vlen;
my $writeoffset;
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
$record = "\2". $key . $val;
die "panic" unless length($record) == $rlen;
$writeoffset = $offset unless defined $writeoffset;
substr($$self[0], $writeoffset, $rlen) = $record;
++$$self[5];
return;
}
elsif (ord($record) == 1) {
$writeoffset = $offset unless defined $writeoffset;
}
elsif (substr($record, 1, $klen) eq $key) {
$record = "\2". $key . $val;
die "panic" unless length($record) == $rlen;
substr($$self[0], $offset, $rlen) = $record;
return;
}
&rehash;
}
}
sub DELETE {
local($self,$key) = @_;
local($klen, $vlen, $tsize, $rlen) = @$self[1..4];
&hashkey;
for (;;) {
$offset = $hash * $rlen;
$record = substr($$self[0], $offset, $rlen);
if (ord($record) == 0) {
return undef;
}
elsif (ord($record) == 1) {
}
elsif (substr($record, 1, $klen) eq $key) {
substr($$self[0], $offset, 1) = "\1";
return substr($record, 1+$klen, $vlen);
--$$self[5];
}
&rehash;
}
}
sub FIRSTKEY {
local($self) = @_;
$$self[6] = -1;
&NEXTKEY;
}
sub NEXTKEY {
local($self) = @_;
local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6];
for (++$iterix; $iterix < $tsize->[1]; ++$iterix) {
next unless substr($$self[0], $iterix * $rlen, 1) eq "\2";
$$self[6] = $iterix;
return substr($$self[0], $iterix * $rlen + 1, $klen);
}
$$self[6] = -1;
undef;
}
sub EXISTS {
croak "Tie::SubstrHash does not support exists()";
}
sub hashkey {
croak(qq/Key "$key" is not $klen characters long/)
if length($key) != $klen;
$hash = 2;
for (unpack('C*', $key)) {
$hash = $hash * 33 + $_;
&_hashwrap if $hash >= 1e13;
}
&_hashwrap if $hash >= $tsize->[1];
$hash = 1 unless $hash;
$hashbase = $hash;
}
sub _hashwrap {
$hash -= int($hash / $tsize->[1]) * $tsize->[1];
}
sub rehash {
$hash += $hashbase;
$hash -= $tsize->[1] if $hash >= $tsize->[1];
}
# using POSIX::ceil() would be too heavy, and not all platforms have it.
sub ceil {
my $num = shift;
$num = int($num + 1) unless $num == int $num;
return $num;
}
# See:
#
# http://www-groups.dcs.st-andrews.ac.uk/~history/HistTopics/Prime_numbers.html
#
sub findgteprime { # find the smallest prime integer greater than or equal to
use integer;
my $num = ceil(shift);
return 2 if $num <= 2;
$num++ unless $num % 2;
my $i;
my $sqrtnum = int sqrt $num;
my $sqrtnumsquared = $sqrtnum * $sqrtnum;
NUM:
for (;; $num += 2) {
if ($sqrtnumsquared < $num) {
$sqrtnum++;
$sqrtnumsquared = $sqrtnum * $sqrtnum;
}
for ($i = 3; $i <= $sqrtnum; $i += 2) {
next NUM unless $num % $i;
}
return $num;
}
}
1;
Array.pm 0000644 00000016226 15051126340 0006164 0 ustar 00 package Tie::Array;
use 5.006_001;
use strict;
use Carp;
our $VERSION = '1.06';
# Pod documentation after __END__ below.
sub DESTROY { }
sub EXTEND { }
sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
sub SHIFT { shift->SPLICE(0,1) }
sub CLEAR { shift->STORESIZE(0) }
sub PUSH
{
my $obj = shift;
my $i = $obj->FETCHSIZE;
$obj->STORE($i++, shift) while (@_);
}
sub POP
{
my $obj = shift;
my $newsize = $obj->FETCHSIZE - 1;
my $val;
if ($newsize >= 0)
{
$val = $obj->FETCH($newsize);
$obj->STORESIZE($newsize);
}
$val;
}
sub SPLICE {
my $obj = shift;
my $sz = $obj->FETCHSIZE;
my $off = (@_) ? shift : 0;
$off += $sz if ($off < 0);
my $len = (@_) ? shift : $sz - $off;
$len += $sz - $off if $len < 0;
my @result;
for (my $i = 0; $i < $len; $i++) {
push(@result,$obj->FETCH($off+$i));
}
$off = $sz if $off > $sz;
$len -= $off + $len - $sz if $off + $len > $sz;
if (@_ > $len) {
# Move items up to make room
my $d = @_ - $len;
my $e = $off+$len;
$obj->EXTEND($sz+$d);
for (my $i=$sz-1; $i >= $e; $i--) {
my $val = $obj->FETCH($i);
$obj->STORE($i+$d,$val);
}
}
elsif (@_ < $len) {
# Move items down to close the gap
my $d = $len - @_;
my $e = $off+$len;
for (my $i=$off+$len; $i < $sz; $i++) {
my $val = $obj->FETCH($i);
$obj->STORE($i-$d,$val);
}
$obj->STORESIZE($sz-$d);
}
for (my $i=0; $i < @_; $i++) {
$obj->STORE($off+$i,$_[$i]);
}
return wantarray ? @result : pop @result;
}
sub EXISTS {
my $pkg = ref $_[0];
croak "$pkg doesn't define an EXISTS method";
}
sub DELETE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a DELETE method";
}
package Tie::StdArray;
use vars qw(@ISA);
@ISA = 'Tie::Array';
sub TIEARRAY { bless [], $_[0] }
sub FETCHSIZE { scalar @{$_[0]} }
sub STORESIZE { $#{$_[0]} = $_[1]-1 }
sub STORE { $_[0]->[$_[1]] = $_[2] }
sub FETCH { $_[0]->[$_[1]] }
sub CLEAR { @{$_[0]} = () }
sub POP { pop(@{$_[0]}) }
sub PUSH { my $o = shift; push(@$o,@_) }
sub SHIFT { shift(@{$_[0]}) }
sub UNSHIFT { my $o = shift; unshift(@$o,@_) }
sub EXISTS { exists $_[0]->[$_[1]] }
sub DELETE { delete $_[0]->[$_[1]] }
sub SPLICE
{
my $ob = shift;
my $sz = $ob->FETCHSIZE;
my $off = @_ ? shift : 0;
$off += $sz if $off < 0;
my $len = @_ ? shift : $sz-$off;
return splice(@$ob,$off,$len,@_);
}
1;
__END__
=head1 NAME
Tie::Array - base class for tied arrays
=head1 SYNOPSIS
package Tie::NewArray;
use Tie::Array;
@ISA = ('Tie::Array');
# mandatory methods
sub TIEARRAY { ... }
sub FETCH { ... }
sub FETCHSIZE { ... }
sub STORE { ... } # mandatory if elements writeable
sub STORESIZE { ... } # mandatory if elements can be added/deleted
sub EXISTS { ... } # mandatory if exists() expected to work
sub DELETE { ... } # mandatory if delete() expected to work
# optional methods - for efficiency
sub CLEAR { ... }
sub PUSH { ... }
sub POP { ... }
sub SHIFT { ... }
sub UNSHIFT { ... }
sub SPLICE { ... }
sub EXTEND { ... }
sub DESTROY { ... }
package Tie::NewStdArray;
use Tie::Array;
@ISA = ('Tie::StdArray');
# all methods provided by default
package main;
$object = tie @somearray,'Tie::NewArray';
$object = tie @somearray,'Tie::StdArray';
$object = tie @somearray,'Tie::NewStdArray';
=head1 DESCRIPTION
This module provides methods for array-tying classes. See
L<perltie> for a list of the functions required in order to tie an array
to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
methods that croak() if the delete() or exists() builtins are ever called
on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
C<FETCHSIZE>, C<STORESIZE>.
The B<Tie::StdArray> package provides efficient methods required for tied arrays
which are implemented as blessed references to an "inner" perl array.
It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
like standard arrays, allowing for selective overloading of methods.
For developers wishing to write their own tied arrays, the required methods
are briefly defined below. See the L<perltie> section for more detailed
descriptive, as well as example code:
=over 4
=item TIEARRAY classname, LIST
The class method is invoked by the command C<tie @array, classname>. Associates
an array instance with the specified class. C<LIST> would represent
additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
to complete the association. The method should return an object of a class which
provides the methods below.
=item STORE this, index, value
Store datum I<value> into I<index> for the tied array associated with
object I<this>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.
=item FETCH this, index
Retrieve the datum in I<index> for the tied array associated with
object I<this>.
=item FETCHSIZE this
Returns the total number of items in the tied array associated with
object I<this>. (Equivalent to C<scalar(@array)>).
=item STORESIZE this, count
Sets the total number of items in the tied array associated with
object I<this> to be I<count>. If this makes the array larger then
class's mapping of C<undef> should be returned for new positions.
If the array becomes smaller then entries beyond count should be
deleted.
=item EXTEND this, count
Informative call that array is likely to grow to have I<count> entries.
Can be used to optimize allocation. This method need do nothing.
=item EXISTS this, key
Verify that the element at index I<key> exists in the tied array I<this>.
The B<Tie::Array> implementation is a stub that simply croaks.
=item DELETE this, key
Delete the element at index I<key> from the tied array I<this>.
The B<Tie::Array> implementation is a stub that simply croaks.
=item CLEAR this
Clear (remove, delete, ...) all values from the tied array associated with
object I<this>.
=item DESTROY this
Normal object destructor method.
=item PUSH this, LIST
Append elements of LIST to the array.
=item POP this
Remove last element of the array and return it.
=item SHIFT this
Remove the first element of the array (shifting other elements down)
and return it.
=item UNSHIFT this, LIST
Insert LIST elements at the beginning of the array, moving existing elements
up to make room.
=item SPLICE this, offset, length, LIST
Perform the equivalent of C<splice> on the array.
I<offset> is optional and defaults to zero, negative values count back
from the end of the array.
I<length> is optional and defaults to rest of the array.
I<LIST> may be empty.
Returns a list of the original I<length> elements at I<offset>.
=back
=head1 CAVEATS
There is no support at present for tied @ISA. There is a potential conflict
between magic entries needed to notice setting of @ISA, and those needed to
implement 'tie'.
=head1 AUTHOR
Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
=cut
Scalar.pm 0000644 00000010104 15051126340 0006300 0 ustar 00 package Tie::Scalar;
our $VERSION = '1.04';
=head1 NAME
Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
=head1 SYNOPSIS
package NewScalar;
require Tie::Scalar;
@ISA = qw(Tie::Scalar);
sub FETCH { ... } # Provide a needed method
sub TIESCALAR { ... } # Overrides inherited method
package NewStdScalar;
require Tie::Scalar;
@ISA = qw(Tie::StdScalar);
# All methods provided by default, so define
# only what needs be overridden
sub FETCH { ... }
package main;
tie $new_scalar, 'NewScalar';
tie $new_std_scalar, 'NewStdScalar';
=head1 DESCRIPTION
This module provides some skeletal methods for scalar-tying classes. See
L<perltie> for a list of the functions required in tying a scalar to a
package. The basic B<Tie::Scalar> package provides a C<new> method, as well
as methods C<TIESCALAR>, C<FETCH> and C<STORE>. The B<Tie::StdScalar>
package provides all the methods specified in L<perltie>. It inherits from
B<Tie::Scalar> and causes scalars tied to it to behave exactly like the
built-in scalars, allowing for selective overloading of methods. The C<new>
method is provided as a means of grandfathering, for classes that forget to
provide their own C<TIESCALAR> method.
For developers wishing to write their own tied-scalar classes, the methods
are summarized below. The L<perltie> section not only documents these, but
has sample code as well:
=over 4
=item TIESCALAR classname, LIST
The method invoked by the command C<tie $scalar, classname>. Associates a new
scalar instance with the specified class. C<LIST> would represent additional
arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
complete the association.
=item FETCH this
Retrieve the value of the tied scalar referenced by I<this>.
=item STORE this, value
Store data I<value> in the tied scalar referenced by I<this>.
=item DESTROY this
Free the storage associated with the tied scalar referenced by I<this>.
This is rarely needed, as Perl manages its memory quite well. But the
option exists, should a class wish to perform specific actions upon the
destruction of an instance.
=back
=head2 Tie::Scalar vs Tie::StdScalar
C<< Tie::Scalar >> provides all the necessary methods, but one should realize
they do not do anything useful. Calling C<< Tie::Scalar::FETCH >> or
C<< Tie::Scalar::STORE >> results in a (trappable) croak. And if you inherit
from C<< Tie::Scalar >>, you I<must> provide either a C<< new >> or a
C<< TIESCALAR >> method.
If you are looking for a class that does everything for you you don't
define yourself, use the C<< Tie::StdScalar >> class, not the
C<< Tie::Scalar >> one.
=head1 MORE INFORMATION
The L<perltie> section uses a good example of tying scalars by associating
process IDs with priority.
=cut
use Carp;
use warnings::register;
sub new {
my $pkg = shift;
$pkg->TIESCALAR(@_);
}
# "Grandfather" the new, a la Tie::Hash
sub TIESCALAR {
my $pkg = shift;
my $pkg_new = $pkg -> can ('new');
if ($pkg_new and $pkg ne __PACKAGE__) {
my $my_new = __PACKAGE__ -> can ('new');
if ($pkg_new == $my_new) {
#
# Prevent recursion
#
croak "$pkg must define either a TIESCALAR() or a new() method";
}
warnings::warnif ("WARNING: calling ${pkg}->new since " .
"${pkg}->TIESCALAR is missing");
$pkg -> new (@_);
}
else {
croak "$pkg doesn't define a TIESCALAR method";
}
}
sub FETCH {
my $pkg = ref $_[0];
croak "$pkg doesn't define a FETCH method";
}
sub STORE {
my $pkg = ref $_[0];
croak "$pkg doesn't define a STORE method";
}
#
# The Tie::StdScalar package provides scalars that behave exactly like
# Perl's built-in scalars. Good base to inherit from, if you're only going to
# tweak a small bit.
#
package Tie::StdScalar;
@ISA = qw(Tie::Scalar);
sub TIESCALAR {
my $class = shift;
my $instance = @_ ? shift : undef;
return bless \$instance => $class;
}
sub FETCH {
return ${$_[0]};
}
sub STORE {
${$_[0]} = $_[1];
}
sub DESTROY {
undef ${$_[0]};
}
1;
StdHandle.pm 0000644 00000002566 15051126340 0006756 0 ustar 00 package Tie::StdHandle;
use strict;
use Tie::Handle;
use vars qw(@ISA $VERSION);
@ISA = 'Tie::Handle';
$VERSION = '4.4';
=head1 NAME
Tie::StdHandle - base class definitions for tied handles
=head1 SYNOPSIS
package NewHandle;
require Tie::Handle;
@ISA = qw(Tie::Handle);
sub READ { ... } # Provide a needed method
sub TIEHANDLE { ... } # Overrides inherited method
package main;
tie *FH, 'NewHandle';
=head1 DESCRIPTION
The B<Tie::StdHandle> package provide most methods for file handles described
in L<perltie> (the exceptions are C<UNTIE> and C<DESTROY>). It causes tied
file handles to behave exactly like standard file handles and allow for
selective overwriting of methods.
=cut
sub TIEHANDLE
{
my $class = shift;
my $fh = \do { local *HANDLE};
bless $fh,$class;
$fh->OPEN(@_) if (@_);
return $fh;
}
sub EOF { eof($_[0]) }
sub TELL { tell($_[0]) }
sub FILENO { fileno($_[0]) }
sub SEEK { seek($_[0],$_[1],$_[2]) }
sub CLOSE { close($_[0]) }
sub BINMODE { binmode($_[0]) }
sub OPEN
{
$_[0]->CLOSE if defined($_[0]->FILENO);
@_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
}
sub READ { &CORE::read(shift, \shift, @_) }
sub READLINE { my $fh = $_[0]; <$fh> }
sub GETC { getc($_[0]) }
sub WRITE
{
my $fh = $_[0];
local $\; # don't print any line terminator
print $fh substr($_[1], $_[3], $_[2]);
}
1;
File.pm 0000644 00000227204 15051126340 0005765 0 ustar 00
package Tie::File;
require 5.005;
use Carp ':DEFAULT', 'confess';
use POSIX 'SEEK_SET';
use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY';
sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY }
$VERSION = "1.02";
my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes
my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records
my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful
my %good_opt = map {$_ => 1, "-$_" => 1}
qw(memory dw_size mode recsep discipline
autodefer autochomp autodefer_threshhold concurrent);
sub TIEARRAY {
if (@_ % 2 != 0) {
croak "usage: tie \@array, $_[0], filename, [option => value]...";
}
my ($pack, $file, %opts) = @_;
# transform '-foo' keys into 'foo' keys
for my $key (keys %opts) {
unless ($good_opt{$key}) {
croak("$pack: Unrecognized option '$key'\n");
}
my $okey = $key;
if ($key =~ s/^-+//) {
$opts{$key} = delete $opts{$okey};
}
}
if ($opts{concurrent}) {
croak("$pack: concurrent access not supported yet\n");
}
unless (defined $opts{memory}) {
# default is the larger of the default cache size and the
# deferred-write buffer size (if specified)
$opts{memory} = $DEFAULT_MEMORY_SIZE;
$opts{memory} = $opts{dw_size}
if defined $opts{dw_size} && $opts{dw_size} > $DEFAULT_MEMORY_SIZE;
# Dora Winifred Read
}
$opts{dw_size} = $opts{memory} unless defined $opts{dw_size};
if ($opts{dw_size} > $opts{memory}) {
croak("$pack: dw_size may not be larger than total memory allocation\n");
}
# are we in deferred-write mode?
$opts{defer} = 0 unless defined $opts{defer};
$opts{deferred} = {}; # no records are presently deferred
$opts{deferred_s} = 0; # count of total bytes in ->{deferred}
$opts{deferred_max} = -1; # empty
# What's a good way to arrange that this class can be overridden?
$opts{cache} = Tie::File::Cache->new($opts{memory});
# autodeferment is enabled by default
$opts{autodefer} = 1 unless defined $opts{autodefer};
$opts{autodeferring} = 0; # but is not initially active
$opts{ad_history} = [];
$opts{autodefer_threshhold} = $DEFAULT_AUTODEFER_THRESHHOLD
unless defined $opts{autodefer_threshhold};
$opts{autodefer_filelen_threshhold} = $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD
unless defined $opts{autodefer_filelen_threshhold};
$opts{offsets} = [0];
$opts{filename} = $file;
unless (defined $opts{recsep}) {
$opts{recsep} = _default_recsep();
}
$opts{recseplen} = length($opts{recsep});
if ($opts{recseplen} == 0) {
croak "Empty record separator not supported by $pack";
}
$opts{autochomp} = 1 unless defined $opts{autochomp};
$opts{mode} = O_CREAT|O_RDWR unless defined $opts{mode};
$opts{rdonly} = (($opts{mode} & O_ACCMODE) == O_RDONLY);
$opts{sawlastrec} = undef;
my $fh;
if (UNIVERSAL::isa($file, 'GLOB')) {
# We use 1 here on the theory that some systems
# may not indicate failure if we use 0.
# MSWin32 does not indicate failure with 0, but I don't know if
# it will indicate failure with 1 or not.
unless (seek $file, 1, SEEK_SET) {
croak "$pack: your filehandle does not appear to be seekable";
}
seek $file, 0, SEEK_SET; # put it back
$fh = $file; # setting binmode is the user's problem
} elsif (ref $file) {
croak "usage: tie \@array, $pack, filename, [option => value]...";
} else {
# $fh = \do { local *FH }; # XXX this is buggy
if ($] < 5.006) {
# perl 5.005 and earlier don't autovivify filehandles
require Symbol;
$fh = Symbol::gensym();
}
sysopen $fh, $file, $opts{mode}, 0666 or return;
binmode $fh;
++$opts{ourfh};
}
{ my $ofh = select $fh; $| = 1; select $ofh } # autoflush on write
if (defined $opts{discipline} && $] >= 5.006) {
# This avoids a compile-time warning under 5.005
eval 'binmode($fh, $opts{discipline})';
croak $@ if $@ =~ /unknown discipline/i;
die if $@;
}
$opts{fh} = $fh;
bless \%opts => $pack;
}
sub FETCH {
my ($self, $n) = @_;
my $rec;
# check the defer buffer
$rec = $self->{deferred}{$n} if exists $self->{deferred}{$n};
$rec = $self->_fetch($n) unless defined $rec;
# inlined _chomp1
substr($rec, - $self->{recseplen}) = ""
if defined $rec && $self->{autochomp};
$rec;
}
# Chomp many records in-place; return nothing useful
sub _chomp {
my $self = shift;
return unless $self->{autochomp};
if ($self->{autochomp}) {
for (@_) {
next unless defined;
substr($_, - $self->{recseplen}) = "";
}
}
}
# Chomp one record in-place; return modified record
sub _chomp1 {
my ($self, $rec) = @_;
return $rec unless $self->{autochomp};
return unless defined $rec;
substr($rec, - $self->{recseplen}) = "";
$rec;
}
sub _fetch {
my ($self, $n) = @_;
# check the record cache
{ my $cached = $self->{cache}->lookup($n);
return $cached if defined $cached;
}
if ($#{$self->{offsets}} < $n) {
return if $self->{eof}; # request for record beyond end of file
my $o = $self->_fill_offsets_to($n);
# If it's still undefined, there is no such record, so return 'undef'
return unless defined $o;
}
my $fh = $self->{FH};
$self->_seek($n); # we can do this now that offsets is populated
my $rec = $self->_read_record;
# If we happen to have just read the first record, check to see if
# the length of the record matches what 'tell' says. If not, Tie::File
# won't work, and should drop dead.
#
# if ($n == 0 && defined($rec) && tell($self->{fh}) != length($rec)) {
# if (defined $self->{discipline}) {
# croak "I/O discipline $self->{discipline} not supported";
# } else {
# croak "File encoding not supported";
# }
# }
$self->{cache}->insert($n, $rec) if defined $rec && not $self->{flushing};
$rec;
}
sub STORE {
my ($self, $n, $rec) = @_;
die "STORE called from _check_integrity!" if $DIAGNOSTIC;
$self->_fixrecs($rec);
if ($self->{autodefer}) {
$self->_annotate_ad_history($n);
}
return $self->_store_deferred($n, $rec) if $self->_is_deferring;
# We need this to decide whether the new record will fit
# It incidentally populates the offsets table
# Note we have to do this before we alter the cache
# 20020324 Wait, but this DOES alter the cache. TODO BUG?
my $oldrec = $self->_fetch($n);
if (not defined $oldrec) {
# We're storing a record beyond the end of the file
$self->_extend_file_to($n+1);
$oldrec = $self->{recsep};
}
# return if $oldrec eq $rec; # don't bother
my $len_diff = length($rec) - length($oldrec);
# length($oldrec) here is not consistent with text mode TODO XXX BUG
$self->_mtwrite($rec, $self->{offsets}[$n], length($oldrec));
$self->_oadjust([$n, 1, $rec]);
$self->{cache}->update($n, $rec);
}
sub _store_deferred {
my ($self, $n, $rec) = @_;
$self->{cache}->remove($n);
my $old_deferred = $self->{deferred}{$n};
if (defined $self->{deferred_max} && $n > $self->{deferred_max}) {
$self->{deferred_max} = $n;
}
$self->{deferred}{$n} = $rec;
my $len_diff = length($rec);
$len_diff -= length($old_deferred) if defined $old_deferred;
$self->{deferred_s} += $len_diff;
$self->{cache}->adj_limit(-$len_diff);
if ($self->{deferred_s} > $self->{dw_size}) {
$self->_flush;
} elsif ($self->_cache_too_full) {
$self->_cache_flush;
}
}
# Remove a single record from the deferred-write buffer without writing it
# The record need not be present
sub _delete_deferred {
my ($self, $n) = @_;
my $rec = delete $self->{deferred}{$n};
return unless defined $rec;
if (defined $self->{deferred_max}
&& $n == $self->{deferred_max}) {
undef $self->{deferred_max};
}
$self->{deferred_s} -= length $rec;
$self->{cache}->adj_limit(length $rec);
}
sub FETCHSIZE {
my $self = shift;
my $n = $self->{eof} ? $#{$self->{offsets}} : $self->_fill_offsets;
my $top_deferred = $self->_defer_max;
$n = $top_deferred+1 if defined $top_deferred && $n < $top_deferred+1;
$n;
}
sub STORESIZE {
my ($self, $len) = @_;
if ($self->{autodefer}) {
$self->_annotate_ad_history('STORESIZE');
}
my $olen = $self->FETCHSIZE;
return if $len == $olen; # Woo-hoo!
# file gets longer
if ($len > $olen) {
if ($self->_is_deferring) {
for ($olen .. $len-1) {
$self->_store_deferred($_, $self->{recsep});
}
} else {
$self->_extend_file_to($len);
}
return;
}
# file gets shorter
if ($self->_is_deferring) {
# TODO maybe replace this with map-plus-assignment?
for (grep $_ >= $len, keys %{$self->{deferred}}) {
$self->_delete_deferred($_);
}
$self->{deferred_max} = $len-1;
}
$self->_seek($len);
$self->_chop_file;
$#{$self->{offsets}} = $len;
# $self->{offsets}[0] = 0; # in case we just chopped this
$self->{cache}->remove(grep $_ >= $len, $self->{cache}->ckeys);
}
### OPTIMIZE ME
### It should not be necessary to do FETCHSIZE
### Just seek to the end of the file.
sub PUSH {
my $self = shift;
$self->SPLICE($self->FETCHSIZE, scalar(@_), @_);
# No need to return:
# $self->FETCHSIZE; # because av.c takes care of this for me
}
sub POP {
my $self = shift;
my $size = $self->FETCHSIZE;
return if $size == 0;
# print STDERR "# POPPITY POP POP POP\n";
scalar $self->SPLICE($size-1, 1);
}
sub SHIFT {
my $self = shift;
scalar $self->SPLICE(0, 1);
}
sub UNSHIFT {
my $self = shift;
$self->SPLICE(0, 0, @_);
# $self->FETCHSIZE; # av.c takes care of this for me
}
sub CLEAR {
my $self = shift;
if ($self->{autodefer}) {
$self->_annotate_ad_history('CLEAR');
}
$self->_seekb(0);
$self->_chop_file;
$self->{cache}->set_limit($self->{memory});
$self->{cache}->empty;
@{$self->{offsets}} = (0);
%{$self->{deferred}}= ();
$self->{deferred_s} = 0;
$self->{deferred_max} = -1;
}
sub EXTEND {
my ($self, $n) = @_;
# No need to pre-extend anything in this case
return if $self->_is_deferring;
$self->_fill_offsets_to($n);
$self->_extend_file_to($n);
}
sub DELETE {
my ($self, $n) = @_;
if ($self->{autodefer}) {
$self->_annotate_ad_history('DELETE');
}
my $lastrec = $self->FETCHSIZE-1;
my $rec = $self->FETCH($n);
$self->_delete_deferred($n) if $self->_is_deferring;
if ($n == $lastrec) {
$self->_seek($n);
$self->_chop_file;
$#{$self->{offsets}}--;
$self->{cache}->remove($n);
# perhaps in this case I should also remove trailing null records?
# 20020316
# Note that delete @a[-3..-1] deletes the records in the wrong order,
# so we only chop the very last one out of the file. We could repair this
# by tracking deleted records inside the object.
} elsif ($n < $lastrec) {
$self->STORE($n, "");
}
$rec;
}
sub EXISTS {
my ($self, $n) = @_;
return 1 if exists $self->{deferred}{$n};
$n < $self->FETCHSIZE;
}
sub SPLICE {
my $self = shift;
if ($self->{autodefer}) {
$self->_annotate_ad_history('SPLICE');
}
$self->_flush if $self->_is_deferring; # move this up?
if (wantarray) {
$self->_chomp(my @a = $self->_splice(@_));
@a;
} else {
$self->_chomp1(scalar $self->_splice(@_));
}
}
sub DESTROY {
my $self = shift;
$self->flush if $self->_is_deferring;
$self->{cache}->delink if defined $self->{cache}; # break circular link
if ($self->{fh} and $self->{ourfh}) {
delete $self->{ourfh};
close delete $self->{fh};
}
}
sub _splice {
my ($self, $pos, $nrecs, @data) = @_;
my @result;
$pos = 0 unless defined $pos;
# Deal with negative and other out-of-range positions
# Also set default for $nrecs
{
my $oldsize = $self->FETCHSIZE;
$nrecs = $oldsize unless defined $nrecs;
my $oldpos = $pos;
if ($pos < 0) {
$pos += $oldsize;
if ($pos < 0) {
croak "Modification of non-creatable array value attempted, " .
"subscript $oldpos";
}
}
if ($pos > $oldsize) {
return unless @data;
$pos = $oldsize; # This is what perl does for normal arrays
}
# The manual is very unclear here
if ($nrecs < 0) {
$nrecs = $oldsize - $pos + $nrecs;
$nrecs = 0 if $nrecs < 0;
}
# nrecs is too big---it really means "until the end"
# 20030507
if ($nrecs + $pos > $oldsize) {
$nrecs = $oldsize - $pos;
}
}
$self->_fixrecs(@data);
my $data = join '', @data;
my $datalen = length $data;
my $oldlen = 0;
# compute length of data being removed
for ($pos .. $pos+$nrecs-1) {
last unless defined $self->_fill_offsets_to($_);
my $rec = $self->_fetch($_);
last unless defined $rec;
push @result, $rec;
# Why don't we just use length($rec) here?
# Because that record might have come from the cache. _splice
# might have been called to flush out the deferred-write records,
# and in this case length($rec) is the length of the record to be
# *written*, not the length of the actual record in the file. But
# the offsets are still true. 20020322
$oldlen += $self->{offsets}[$_+1] - $self->{offsets}[$_]
if defined $self->{offsets}[$_+1];
}
$self->_fill_offsets_to($pos+$nrecs);
# Modify the file
$self->_mtwrite($data, $self->{offsets}[$pos], $oldlen);
# Adjust the offsets table
$self->_oadjust([$pos, $nrecs, @data]);
{ # Take this read cache stuff out into a separate function
# You made a half-attempt to put it into _oadjust.
# Finish something like that up eventually.
# STORE also needs to do something similarish
# update the read cache, part 1
# modified records
for ($pos .. $pos+$nrecs-1) {
my $new = $data[$_-$pos];
if (defined $new) {
$self->{cache}->update($_, $new);
} else {
$self->{cache}->remove($_);
}
}
# update the read cache, part 2
# moved records - records past the site of the change
# need to be renumbered
# Maybe merge this with the previous block?
{
my @oldkeys = grep $_ >= $pos + $nrecs, $self->{cache}->ckeys;
my @newkeys = map $_-$nrecs+@data, @oldkeys;
$self->{cache}->rekey(\@oldkeys, \@newkeys);
}
# Now there might be too much data in the cache, if we spliced out
# some short records and spliced in some long ones. If so, flush
# the cache.
$self->_cache_flush;
}
# Yes, the return value of 'splice' *is* actually this complicated
wantarray ? @result : @result ? $result[-1] : undef;
}
# write data into the file
# $data is the data to be written.
# it should be written at position $pos, and should overwrite
# exactly $len of the following bytes.
# Note that if length($data) > $len, the subsequent bytes will have to
# be moved up, and if length($data) < $len, they will have to
# be moved down
sub _twrite {
my ($self, $data, $pos, $len) = @_;
unless (defined $pos) {
die "\$pos was undefined in _twrite";
}
my $len_diff = length($data) - $len;
if ($len_diff == 0) { # Woo-hoo!
my $fh = $self->{fh};
$self->_seekb($pos);
$self->_write_record($data);
return; # well, that was easy.
}
# the two records are of different lengths
# our strategy here: rewrite the tail of the file,
# reading ahead one buffer at a time
# $bufsize is required to be at least as large as the data we're overwriting
my $bufsize = _bufsize($len_diff);
my ($writepos, $readpos) = ($pos, $pos+$len);
my $next_block;
my $more_data;
# Seems like there ought to be a way to avoid the repeated code
# and the special case here. The read(1) is also a little weird.
# Think about this.
do {
$self->_seekb($readpos);
my $br = read $self->{fh}, $next_block, $bufsize;
$more_data = read $self->{fh}, my($dummy), 1;
$self->_seekb($writepos);
$self->_write_record($data);
$readpos += $br;
$writepos += length $data;
$data = $next_block;
} while $more_data;
$self->_seekb($writepos);
$self->_write_record($next_block);
# There might be leftover data at the end of the file
$self->_chop_file if $len_diff < 0;
}
# _iwrite(D, S, E)
# Insert text D at position S.
# Let C = E-S-|D|. If C < 0; die.
# Data in [S,S+C) is copied to [S+D,S+D+C) = [S+D,E).
# Data in [S+C = E-D, E) is returned. Data in [E, oo) is untouched.
#
# In a later version, don't read the entire intervening area into
# memory at once; do the copying block by block.
sub _iwrite {
my $self = shift;
my ($D, $s, $e) = @_;
my $d = length $D;
my $c = $e-$s-$d;
local *FH = $self->{fh};
confess "Not enough space to insert $d bytes between $s and $e"
if $c < 0;
confess "[$s,$e) is an invalid insertion range" if $e < $s;
$self->_seekb($s);
read FH, my $buf, $e-$s;
$D .= substr($buf, 0, $c, "");
$self->_seekb($s);
$self->_write_record($D);
return $buf;
}
# Like _twrite, but the data-pos-len triple may be repeated; you may
# write several chunks. All the writing will be done in
# one pass. Chunks SHALL be in ascending order and SHALL NOT overlap.
sub _mtwrite {
my $self = shift;
my $unwritten = "";
my $delta = 0;
@_ % 3 == 0
or die "Arguments to _mtwrite did not come in groups of three";
while (@_) {
my ($data, $pos, $len) = splice @_, 0, 3;
my $end = $pos + $len; # The OLD end of the segment to be replaced
$data = $unwritten . $data;
$delta -= length($unwritten);
$unwritten = "";
$pos += $delta; # This is where the data goes now
my $dlen = length $data;
$self->_seekb($pos);
if ($len >= $dlen) { # the data will fit
$self->_write_record($data);
$delta += ($dlen - $len); # everything following moves down by this much
$data = ""; # All the data in the buffer has been written
} else { # won't fit
my $writable = substr($data, 0, $len - $delta, "");
$self->_write_record($writable);
$delta += ($dlen - $len); # everything following moves down by this much
}
# At this point we've written some but maybe not all of the data.
# There might be a gap to close up, or $data might still contain a
# bunch of unwritten data that didn't fit.
my $ndlen = length $data;
if ($delta == 0) {
$self->_write_record($data);
} elsif ($delta < 0) {
# upcopy (close up gap)
if (@_) {
$self->_upcopy($end, $end + $delta, $_[1] - $end);
} else {
$self->_upcopy($end, $end + $delta);
}
} else {
# downcopy (insert data that didn't fit; replace this data in memory
# with _later_ data that doesn't fit)
if (@_) {
$unwritten = $self->_downcopy($data, $end, $_[1] - $end);
} else {
# Make the file longer to accommodate the last segment that doesn't
$unwritten = $self->_downcopy($data, $end);
}
}
}
}
# Copy block of data of length $len from position $spos to position $dpos
# $dpos must be <= $spos
#
# If $len is undefined, go all the way to the end of the file
# and then truncate it ($spos - $dpos bytes will be removed)
sub _upcopy {
my $blocksize = 8192;
my ($self, $spos, $dpos, $len) = @_;
if ($dpos > $spos) {
die "source ($spos) was upstream of destination ($dpos) in _upcopy";
} elsif ($dpos == $spos) {
return;
}
while (! defined ($len) || $len > 0) {
my $readsize = ! defined($len) ? $blocksize
: $len > $blocksize ? $blocksize
: $len;
my $fh = $self->{fh};
$self->_seekb($spos);
my $bytes_read = read $fh, my($data), $readsize;
$self->_seekb($dpos);
if ($data eq "") {
$self->_chop_file;
last;
}
$self->_write_record($data);
$spos += $bytes_read;
$dpos += $bytes_read;
$len -= $bytes_read if defined $len;
}
}
# Write $data into a block of length $len at position $pos,
# moving everything in the block forwards to make room.
# Instead of writing the last length($data) bytes from the block
# (because there isn't room for them any longer) return them.
#
# Undefined $len means 'until the end of the file'
sub _downcopy {
my $blocksize = 8192;
my ($self, $data, $pos, $len) = @_;
my $fh = $self->{fh};
while (! defined $len || $len > 0) {
my $readsize = ! defined($len) ? $blocksize
: $len > $blocksize? $blocksize : $len;
$self->_seekb($pos);
read $fh, my($old), $readsize;
my $last_read_was_short = length($old) < $readsize;
$data .= $old;
my $writable;
if ($last_read_was_short) {
# If last read was short, then $data now contains the entire rest
# of the file, so there's no need to write only one block of it
$writable = $data;
$data = "";
} else {
$writable = substr($data, 0, $readsize, "");
}
last if $writable eq "";
$self->_seekb($pos);
$self->_write_record($writable);
last if $last_read_was_short && $data eq "";
$len -= $readsize if defined $len;
$pos += $readsize;
}
return $data;
}
# Adjust the object data structures following an '_mtwrite'
# Arguments are
# [$pos, $nrecs, @length] items
# indicating that $nrecs records were removed at $recpos (a record offset)
# and replaced with records of length @length...
# Arguments guarantee that $recpos is strictly increasing.
# No return value
sub _oadjust {
my $self = shift;
my $delta = 0;
my $delta_recs = 0;
my $prev_end = -1;
my %newkeys;
for (@_) {
my ($pos, $nrecs, @data) = @$_;
$pos += $delta_recs;
# Adjust the offsets of the records after the previous batch up
# to the first new one of this batch
for my $i ($prev_end+2 .. $pos - 1) {
$self->{offsets}[$i] += $delta;
$newkey{$i} = $i + $delta_recs;
}
$prev_end = $pos + @data - 1; # last record moved on this pass
# Remove the offsets for the removed records;
# replace with the offsets for the inserted records
my @newoff = ($self->{offsets}[$pos] + $delta);
for my $i (0 .. $#data) {
my $newlen = length $data[$i];
push @newoff, $newoff[$i] + $newlen;
$delta += $newlen;
}
for my $i ($pos .. $pos+$nrecs-1) {
last if $i+1 > $#{$self->{offsets}};
my $oldlen = $self->{offsets}[$i+1] - $self->{offsets}[$i];
$delta -= $oldlen;
}
# # also this data has changed, so update it in the cache
# for (0 .. $#data) {
# $self->{cache}->update($pos + $_, $data[$_]);
# }
# if ($delta_recs) {
# my @oldkeys = grep $_ >= $pos + @data, $self->{cache}->ckeys;
# my @newkeys = map $_ + $delta_recs, @oldkeys;
# $self->{cache}->rekey(\@oldkeys, \@newkeys);
# }
# replace old offsets with new
splice @{$self->{offsets}}, $pos, $nrecs+1, @newoff;
# What if we just spliced out the end of the offsets table?
# shouldn't we clear $self->{eof}? Test for this XXX BUG TODO
$delta_recs += @data - $nrecs; # net change in