diff options
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/Tie')
5 files changed, 107 insertions, 111 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/File.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/File.pm index 824789337b..13d4fa6839 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/File.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/File.pm @@ -11,7 +11,7 @@ use Fcntl 'O_CREAT', 'O_RDWR', 'LOCK_EX', 'LOCK_SH', 'O_WRONLY', 'O_RDONLY'; sub O_ACCMODE () { O_RDONLY | O_RDWR | O_WRONLY } -our $VERSION = "1.06"; +our $VERSION = "1.07"; my $DEFAULT_MEMORY_SIZE = 1<<21; # 2 megabytes my $DEFAULT_AUTODEFER_THRESHHOLD = 3; # 3 records my $DEFAULT_AUTODEFER_FILELEN_THRESHHOLD = 65536; # 16 disk blocksful diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Handle.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Handle.pm index 4e92f75a3d..e6aa34bc92 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Handle.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Handle.pm @@ -1,7 +1,7 @@ package Tie::Handle; use 5.006_001; -our $VERSION = '4.2'; +our $VERSION = '4.3'; # Tie::StdHandle used to be inside Tie::Handle. For backwards compatibility # loading Tie::Handle has to make Tie::StdHandle available. @@ -128,7 +128,7 @@ sub new { $pkg->TIEHANDLE(@_); } -# "Grandfather" the new, a la Tie::Hash +# Legacy support for new(), a la Tie::Hash sub TIEHANDLE { my $pkg = shift; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Hash.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Hash.pm index 89a6181a33..03493e0650 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Hash.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Hash.pm @@ -1,6 +1,6 @@ package Tie::Hash; -our $VERSION = '1.05'; +our $VERSION = '1.06'; =head1 NAME @@ -60,7 +60,7 @@ as methods C<TIEHASH>, C<EXISTS> and C<CLEAR>. The B<Tie::StdHash> and B<Tie::ExtraHash> packages provide most methods for hashes described in L<perltie> (the exceptions are C<UNTIE> and C<DESTROY>). They cause tied hashes to behave exactly like standard hashes, -and allow for selective overwriting of methods. B<Tie::Hash> grandfathers the +and allow for selective overwriting of methods. B<Tie::Hash> has legacy support for the C<new> method: it is used if C<TIEHASH> is not defined in the case a class forgets to include a C<TIEHASH> method. @@ -195,7 +195,7 @@ sub new { $pkg->TIEHASH(@_); } -# Grandfather "new" +# Legacy support for new() sub TIEHASH { my $pkg = shift; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Scalar.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Scalar.pm index 62f89f88c8..b8d6e8ffce 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Scalar.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/Scalar.pm @@ -1,6 +1,6 @@ package Tie::Scalar; -our $VERSION = '1.05'; +our $VERSION = '1.06'; =head1 NAME @@ -41,7 +41,7 @@ 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 +method is provided as a means of legacy support for classes that forget to provide their own C<TIESCALAR> method. For developers wishing to write their own tied-scalar classes, the methods @@ -101,7 +101,7 @@ sub new { $pkg->TIESCALAR(@_); } -# "Grandfather" the new, a la Tie::Hash +# Legacy support for new(), a la Tie::Hash sub TIESCALAR { my $pkg = shift; diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/SubstrHash.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/SubstrHash.pm index 476dd68678..f2677a616f 100644 --- a/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/SubstrHash.pm +++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/Tie/SubstrHash.pm @@ -1,6 +1,4 @@ -package Tie::SubstrHash; - -our $VERSION = '1.00'; +package Tie::SubstrHash 1.01; =head1 NAME @@ -39,114 +37,116 @@ The hash does not support exists(). =cut +use strict; +use warnings; +no warnings 'experimental::builtin'; + use Carp; sub TIEHASH { - my $pack = shift; - my ($klen, $vlen, $tsize) = @_; + my ($pack, $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]; + $tsize = [$tsize, findgteprime($tsize * 1.1)]; # Allow 10% empty. + my $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; + my ($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; + my ($self, $key) = @_; + my (undef, $klen, $vlen, $tsize, $rlen) = @$self; + my $hashbase = my $hash = hashkey($key, $klen, $tsize); + while (1) { + my $offset = $hash * $rlen; + my $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); + } + $hash = rehash($hash, $hashbase, $tsize); } } 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]; + my ($self, $key, $val) = @_; + my (undef, $klen, $vlen, $tsize, $rlen) = @$self; + 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; + 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; + my $hashbase = my $hash = hashkey($key, $klen, $tsize); + while (1) { + my $offset = $hash * $rlen; + my $record = substr($self->[0], $offset, $rlen); + if (ord($record) == 0) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + $writeoffset //= $offset; + substr($self->[0], $writeoffset, $rlen) = $record; + ++$self->[5]; + return; + } + elsif (ord($record) == 1) { + $writeoffset //= $offset; + } + elsif (substr($record, 1, $klen) eq $key) { + $record = "\2". $key . $val; + die "panic" unless length($record) == $rlen; + substr($self->[0], $offset, $rlen) = $record; + return; + } + $hash = rehash($hash, $hashbase, $tsize); } } 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; + my ($self, $key) = @_; + my (undef, $klen, $vlen, $tsize, $rlen) = @$self; + my $hashbase = my $hash = hashkey($key, $klen, $tsize); + while (1) { + my $offset = $hash * $rlen; + my $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]; + } + $hash = rehash($hash, $hashbase, $tsize); } } sub FIRSTKEY { - local($self) = @_; - $$self[6] = -1; - &NEXTKEY; + my ($self) = @_; + $self->[6] = -1; + goto &NEXTKEY; } sub NEXTKEY { - local($self) = @_; - local($klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self[1..6]; + my ($self) = @_; + my (undef, $klen, $vlen, $tsize, $rlen, $entries, $iterix) = @$self; 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); + next unless substr($self->[0], $iterix * $rlen, 1) eq "\2"; + $self->[6] = $iterix; + return substr($self->[0], $iterix * $rlen + 1, $klen); } - $$self[6] = -1; + $self->[6] = -1; undef; } @@ -155,32 +155,29 @@ sub EXISTS { } sub hashkey { + my ($key, $klen, $tsize) = @_; croak(qq/Key "$key" is not $klen characters long/) - if length($key) != $klen; - $hash = 2; + if length($key) != $klen; + my $hash = 2; for (unpack('C*', $key)) { - $hash = $hash * 33 + $_; - &_hashwrap if $hash >= 1e13; + $hash = $hash * 33 + $_; + $hash = _hashwrap($hash, $tsize) if $hash >= 1e13; } - &_hashwrap if $hash >= $tsize->[1]; - $hash = 1 unless $hash; - $hashbase = $hash; + $hash = _hashwrap($hash, $tsize) if $hash >= $tsize->[1]; + $hash ||= 1; + return $hash; } sub _hashwrap { - $hash -= int($hash / $tsize->[1]) * $tsize->[1]; + my ($hash, $tsize) = @_; + return $hash - int($hash / $tsize->[1]) * $tsize->[1]; } sub rehash { + my ($hash, $hashbase, $tsize) = @_; $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; + return $hash; } # See: @@ -191,21 +188,20 @@ sub ceil { sub findgteprime { # find the smallest prime integer greater than or equal to use integer; - my $num = ceil(shift); + my $num = builtin::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) { + if ($sqrtnumsquared < $num) { + $sqrtnum++; + $sqrtnumsquared = $sqrtnum * $sqrtnum; + } + for (my $i = 3; $i <= $sqrtnum; $i += 2) { next NUM unless $num % $i; } return $num; |