diff options
Diffstat (limited to 'contrib/perl5/lib/Tie')
| -rw-r--r-- | contrib/perl5/lib/Tie/Array.pm | 48 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Handle.pm | 89 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Hash.pm | 7 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/RefHash.pm | 7 | ||||
| -rw-r--r-- | contrib/perl5/lib/Tie/Scalar.pm | 23 |
5 files changed, 137 insertions, 37 deletions
diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm index 3f34c3b..eb83aae 100644 --- a/contrib/perl5/lib/Tie/Array.pm +++ b/contrib/perl5/lib/Tie/Array.pm @@ -1,7 +1,9 @@ package Tie::Array; -use vars qw($VERSION); + +use 5.005_64; use strict; -$VERSION = '1.00'; +use Carp; +our $VERSION = '1.01'; # Pod documentation after __END__ below. @@ -74,6 +76,16 @@ sub SPLICE return @result; } +sub EXISTS { + my $pkg = ref $_[0]; + croak "$pkg dosn't define an EXISTS method"; +} + +sub DELETE { + my $pkg = ref $_[0]; + croak "$pkg dosn't define a DELETE method"; +} + package Tie::StdArray; use vars qw(@ISA); @ISA = 'Tie::Array'; @@ -88,6 +100,8 @@ 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 { @@ -112,15 +126,17 @@ Tie::Array - base class for tied arrays package 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 { ... } @@ -133,7 +149,7 @@ Tie::Array - base class for tied arrays package NewStdArray; use Tie::Array; - + @ISA = ('Tie::StdArray'); # all methods provided by default @@ -150,9 +166,11 @@ Tie::Array - base class for tied arrays 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<DELETE> -and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, -C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, +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 @@ -203,6 +221,18 @@ deleted. 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 diff --git a/contrib/perl5/lib/Tie/Handle.pm b/contrib/perl5/lib/Tie/Handle.pm index c755053..588ecea 100644 --- a/contrib/perl5/lib/Tie/Handle.pm +++ b/contrib/perl5/lib/Tie/Handle.pm @@ -1,22 +1,25 @@ package Tie::Handle; +use 5.005_64; +our $VERSION = '1.0'; + =head1 NAME -Tie::Handle - base class definitions for tied handles +Tie::Handle, Tie::StdHandle - base class definitions for tied handles =head1 SYNOPSIS package NewHandle; require Tie::Handle; - + @ISA = (Tie::Handle); - + sub READ { ... } # Provide a needed method sub TIEHANDLE { ... } # Overrides inherited method - - + + package main; - + tie *FH, 'NewHandle'; =head1 DESCRIPTION @@ -24,9 +27,7 @@ Tie::Handle - base class definitions for tied handles 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<TIESCALAR>, C<FETCH> and C<STORE>. The C<new> method is provided as a means -of grandfathering, for classes that forget to provide their own C<TIESCALAR> -method. +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 @@ -65,6 +66,32 @@ Read a single line 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>. @@ -81,6 +108,7 @@ The L<perltie> section contains an example of tying handles. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -92,8 +120,8 @@ sub new { sub TIEHANDLE { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" + if warnings::enabled(); $pkg->new(@_); } else { @@ -117,7 +145,7 @@ sub PRINTF { my $self = shift; if($self->can('WRITE') != \&WRITE) { - my $buf = sprintf(@_); + my $buf = sprintf(shift,@_); $self->WRITE($buf,length($buf),0); } else { @@ -156,6 +184,43 @@ sub WRITE { sub CLOSE { my $pkg = ref $_[0]; croak "$pkg doesn't define a CLOSE method"; +} + +package Tie::StdHandle; +our @ISA = 'Tie::Handle'; +use Carp; + +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); + open($_[0],$_[1]); +} + +sub READ { read($_[0],$_[1],$_[2]) } +sub READLINE { my $fh = $_[0]; <$fh> } +sub GETC { getc($_[0]) } + +sub WRITE +{ + my $fh = $_[0]; + print $fh substr($_[1],0,$_[2]) } + 1; diff --git a/contrib/perl5/lib/Tie/Hash.pm b/contrib/perl5/lib/Tie/Hash.pm index 2902efb..c6ec3d4 100644 --- a/contrib/perl5/lib/Tie/Hash.pm +++ b/contrib/perl5/lib/Tie/Hash.pm @@ -73,6 +73,8 @@ Return the next key for the hash. Verify that I<key> exists with the tied hash I<this>. +The B<Tie::Hash> implementation is a stub that simply croaks. + =item DELETE this, key Delete the key I<key> from the tied hash I<this>. @@ -100,6 +102,7 @@ good working examples. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -111,8 +114,8 @@ sub new { sub TIEHASH { my $pkg = shift; if (defined &{"${pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing" + if warnings::enabled(); $pkg->new(@_); } else { diff --git a/contrib/perl5/lib/Tie/RefHash.pm b/contrib/perl5/lib/Tie/RefHash.pm index 66de257..ffa9eb2 100644 --- a/contrib/perl5/lib/Tie/RefHash.pm +++ b/contrib/perl5/lib/Tie/RefHash.pm @@ -39,11 +39,11 @@ see the C<tie> entry in perlfunc(1) and perltie(1) for more information. =head1 AUTHOR -Gurusamy Sarathy gsar@umich.edu +Gurusamy Sarathy gsar@activestate.com =head1 VERSION -Version 1.2 15 Dec 1996 +Version 1.21 22 Jun 1999 =head1 SEE ALSO @@ -94,7 +94,8 @@ sub EXISTS { sub FIRSTKEY { my $s = shift; - my $a = scalar(keys %{$s->[0]}) + scalar(keys %{$s->[1]}); + keys %{$s->[0]}; # reset iterator + keys %{$s->[1]}; # reset iterator $s->[2] = 0; $s->NEXTKEY; } diff --git a/contrib/perl5/lib/Tie/Scalar.pm b/contrib/perl5/lib/Tie/Scalar.pm index ef27dc1..0c67590 100644 --- a/contrib/perl5/lib/Tie/Scalar.pm +++ b/contrib/perl5/lib/Tie/Scalar.pm @@ -8,24 +8,24 @@ Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars package NewScalar; require Tie::Scalar; - + @ISA = (Tie::Scalar); - + sub FETCH { ... } # Provide a needed method sub TIESCALAR { ... } # Overrides inherited method - - + + package NewStdScalar; require Tie::Scalar; - + @ISA = (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'; @@ -79,6 +79,7 @@ process IDs with priority. =cut use Carp; +use warnings::register; sub new { my $pkg = shift; @@ -90,8 +91,8 @@ sub new { sub TIESCALAR { my $pkg = shift; if (defined &{"{$pkg}::new"}) { - carp "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" - if $^W; + warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing" + if warnings::enabled(); $pkg->new(@_); } else { |
