summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tie/Handle.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tie/Handle.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tie/Handle.pm234
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;