diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tie/Handle.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Tie/Handle.pm | 234 |
1 files changed, 234 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tie/Handle.pm b/Master/tlpkg/tlperl/lib/Tie/Handle.pm new file mode 100644 index 00000000000..d8747f12af1 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tie/Handle.pm @@ -0,0 +1,234 @@ +package Tie::Handle; + +use 5.006_001; +our $VERSION = '4.1'; + +=head1 NAME + +Tie::Handle, 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 + +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"; +} + +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); + @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); +} + +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; |