source: trunk/essentials/dev-lang/perl/lib/Tie/Handle.pm@ 3184

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;