Chapter 14: Tied Variables

14.4. Tying Filehandles

A class implementing a tied filehandle should define the following methods: TIEHANDLE and at least one of PRINT, PRINTF, WRITE, READLINE, GETC, and READ. The class can also provide a DESTROY method, and BINMODE, OPEN, CLOSE, EOF, FILENO, SEEK, TELL, READ, and WRITE methods to enable the corresponding Perl built-ins for the tied filehandle. (Well, that isn't quite true: WRITE corresponds to syswrite and has nothing to do with Perl's built-in write function for printing with format declarations.)

Tied filehandles are especially useful when Perl is embedded in another program (such as Apache or vi) and output to STDOUT or STDERR needs to be redirected in some special way.

But filehandles don't actually have to be tied to a file at all. You can use output statements to build up an in-memory data structure and input statements to read them back in. Here's an easy way to reverse a sequence of print and printf statements without reversing the individual lines:

package ReversePrint;
use strict;
sub TIEHANDLE {
    my $class = shift;
    bless [], $class;
}
sub PRINT {
    my $self = shift;
    push @$self, join '', @_;
}
sub PRINTF {
    my $self = shift;
    my $fmt = shift;
    push @$self, sprintf $fmt, @_;
}
sub READLINE {
    my $self = shift;
    pop @$self;
}
 
package main;
my $m = "--MORE--\n";
tie *REV, "ReversePrint";
 
# Do some prints and printfs.
print REV "The fox is now dead.$m";

printf REV <<"END", int rand 10000000;
The quick brown fox jumps over
over the lazy dog %d times!
END
 
print REV <<"END";
The quick brown fox jumps
over the lazy dog.
END
 
# Now read back from the same handle.
print while <REV>;

The quick brown fox jumps 
over the lazy dog.
The quick brown fox jumps over
over the lazy dog 3179357 times!
The fox is now dead.--MORE--

14.4.1. Filehandle-Tying Methods

For our extended example, we'll create a filehandle that uppercases strings printed to it. Just for kicks, we'll begin the file with <SHOUT> when it's opened and end with </SHOUT> when it's closed. That way we can rant in well-formed XML.

Here's the top of our Shout.pm file that will implement the class:

package Shout;
use Carp;                # So we can croak our errors

CLASSNAME->TIEHANDLE(LIST)

This is the constructor for the class, which as usual should return a blessed reference.

sub TIEHANDLE {
    my $class = shift;
    my $form = shift;
    open my $self, $form, @_   or croak "can't open $form@_: $!";
    if ($form =~ />/) {
        print $self  "<SHOUT>\n";
        $$self->{WRITING} = 1;     # Remember to do end tag
    }
    return bless $self, $class;    # $self is a glob ref
}

Here, we open a new filehandle according to the mode and filename passed to the tie operator, write <SHOUT> to the file, and return a blessed reference to it. There's a lot of stuff going on in that open statement, but we'll just point out that, in addition to the usual "open or die" idiom, the my $self furnishes an undefined scalar to open, which knows to autovivify it into a typeglob. The fact that it's a typeglob is also significant, because not only does the typeglob contain the real I/O object of the file, but it also contains various other handy data structures that come along for free, like a scalar ($$$self), an array (@$$self), and a hash (%$$self). (We won't mention the subroutine, &$$self.)

The $form is the filename-or-mode argument. If it's a filename, @_ is empty, so it behaves as a two-argument open. Otherwise, $form is the mode for the rest of the arguments.

After the open, we test to see whether we should write the beginning tag. If so, we do. And right away, we use one of those glob data structures we mentioned. That $$self->{WRITING} is an example of using the glob to store interesting information. In this case, we remember whether we did the beginning tag so we know whether to do the corresponding end tag. We're using the %$$self hash, so we can give the field a decent name. We could have used the scalar as $$$self, but that wouldn't be self-documenting. (Or it would only be self-documenting, depending on how you look at it.)

SELF->PRINT(LIST)

This method implements a print to the tied handle. The LIST is whatever was passed to print. Our method below uppercases each element of LIST:

sub PRINT {
    my $self = shift;
    print $self map {uc} @_;
}

SELF->READLINE

This method supplies the data when the filehandle is read from via the angle operator (<FH>) or readline. The method should return undef when there is no more data.

sub READLINE {
    my $self = shift;
    return <$self>;
}

Here, we simply return <$self> so that the method will behave appropriately depending on whether it was called in scalar or list context.

SELF->GETC

This method runs whenever getc is used on the tied filehandle.

sub GETC {
    my $self = shift;
    return getc($self);
}

Like several of the methods in our Shout class, the GETC method simply calls its corresponding Perl built-in and returns the result.

SELF->OPEN(LIST)

Our TIEHANDLE method itself opens a file, but a program using the Shout class that calls open afterward triggers this method.

sub OPEN {
    my $self = shift;
    my $form = shift;
    my $name = "$form@_";
    $self->CLOSE;
    open($self, $form, @_)      or croak "can't reopen $name: $!";
    if ($form =~ />/) {
        print $self "<SHOUT>\n" or croak "can't start print: $!";
        $$self->{WRITING} = 1;     # Remember to do end tag
    }
    else {
        $$self->{WRITING} = 0;     # Remember not to do end tag
    }
    return 1;
}

We invoke our own CLOSE method to explicitly close the file in case the user didn't bother to. Then we open a new file with whatever filename was specified in the open and shout at it.

SELF->CLOSE

This method deals with the request to close the handle. Here, we seek to the end of the file and, if that was successful, print </SHOUT> before using Perl's built-in close.

sub CLOSE {
    my $self = shift;
    if ($$self->{WRITING}) {
        $self->SEEK(0, 2)             or return;
        $self->PRINT("</SHOUT>\n")    or return;
    }
    return close $self;
}

SELF->SEEK(LIST)

When you seek on a tied filehandle, the SEEK method gets called.

sub SEEK {
    my $self = shift;
    my ($offset, $whence) = @_;
    return seek($self, $offset, $whence);
}

SELF->TELL

This method is invoked when tell is used on the tied handle.

sub TELL {
    my $self = shift;
    return tell $self;
}

SELF->PRINTF(LIST)

This method is run whenever printf is used on the tied handle. The LIST will contain the format and the items to be printed.

sub PRINTF {
    my $self = shift;
    my $template = shift;
    return $self->PRINT(sprintf $template, @_);
}

Here, we use sprintf to generate the formatted string and pass it to PRINT for uppercasing. There's nothing that requires you to use the built-in sprintf function though. You could interpret the percent escapes to suit your own purpose.

SELF->READ(LIST)

This method responds when the handle is read using read or sysread. Note that we modify the first argument of LIST "in-place", mimicking read's ability to fill in the scalar passed in as its second argument.

sub READ {
    my ($self, undef, $length, $offset) = @_;
    my $bufref = \$_[1];
    return read($self, $$bufref, $length, $offset);
}

SELF->WRITE(LIST)

This method gets invoked when the handle is written to with syswrite. Here, we uppercase the string to be written.

sub WRITE {
    my $self = shift;
    my $string = uc(shift);
    my $length = shift || length $string;
    my $offset = shift || 0;
    return syswrite $self, $string, $length, $offset;
}

SELF->EOF

This method returns a Boolean value when a filehandle tied to the Shout class is tested for its end-of-file status using eof.

sub EOF {
    my $self = shift;
    return eof $self;
}

SELF->BINMODE(DISC)

This method specifies the I/O discipline to be used on the filehandle. If none is specified, it puts the tied filehandle into binary mode (the :raw discipline), for filesystems that distinguish between text and binary files.

sub BINMODE {
    my $self = shift;
    my $disc = shift || ":raw";
    return binmode $self, $disc;
}

That's how you'd write it, but it's actually useless in our case because the open already wrote on the handle. So in our case we should probably make it say:

sub BINMODE { croak("Too late to use binmode") }

SELF->FILENO

This method should return the file descriptor (fileno) associated with the tied filehandle by the operating system.

sub FILENO {
    my $self = shift;
    return fileno $self;
}

SELF->DESTROY

As with the other types of ties, this method is triggered when the tied object is about to be destroyed. This is useful for letting the object clean up after itself. Here, we make sure that the file is closed, in case the program forgot to call close. We could just say close $self, but it's better to invoke the CLOSE method of the class. That way if the designer of the class decides to change how files are closed, this DESTROY method won't have to be modified.

sub DESTROY {
    my $self = shift;
    $self->CLOSE;      # Close the file using Shout's CLOSE method.
}

Here's a demonstration of our Shout class:

#!/usr/bin/perl
use Shout;
tie(*FOO, Shout::, ">filename");
print FOO "hello\n";            # Prints HELLO.
seek FOO, 0, 0;                 # Rewind to beginning.
@lines = <FOO>;                 # Calls the READLINE method.
close FOO;                      # Close file explicitly.
open(FOO, "+<", "filename");    # Reopen FOO, calling OPEN.
seek(FOO, 8, 0);                # Skip the "<SHOUT>\n".
sysread(FOO, $inbuf, 5);        # Read 5 bytes from FOO into $inbuf.
print "found $inbuf\n";         # Should print "hello".
seek(FOO, -5, 1);               # Back up over the "hello".
syswrite(FOO, "ciao!\n", 6);    # Write 6 bytes into FOO.
untie(*FOO);                    # Calls the CLOSE method implicitly.

<SHOUT>
CIAO!
</SHOUT>

# This is just so totally cool!
use overload q("") => sub { $_[0]->pathname };

# This is the stub to put in each function you want to trace.
sub trace {
    my $self = shift;
    local $Carp::CarpLevel = 1;
    Carp::cluck("\ntrace magical method") if $self->debug;
}

# Overload handler to print out our path.
sub pathname {
    my $self = shift;
    confess "i am not a class method" unless ref $self;
    $$self->{PATHNAME} = shift if @_;
    return $$self->{PATHNAME};
}
# Dual moded.
sub debug {
    my $self = shift;
    my $var = ref $self ? \$$self->{DEBUG} : \our $Debug;
    $$var = shift if @_;
    return ref $self ? $$self->{DEBUG} || $Debug : $Debug;
}

sub GETC { $_[0]->trace;           # NEW
    my($self) = @_;
    getc($self);
}

sub TIEHANDLE {
    my $class    = shift;
    my $form = shift;
    my $name = "$form@_";          # NEW
    open my $self, $form, @_   or croak "can't open $name: $!";
    if ($form =~ />/) {
        print $self  "<SHOUT>\n";
        $$self->{WRITING} = 1;     # Remember to do end tag
    }
    bless $self, $class;           # $fh is a glob ref
    $self->pathname($name);        # NEW
    return $self;
}

sub OPEN { $_[0]->trace;           # NEW
    my $self = shift;
    my $form = shift;
    my $name = "$form@_";          
    $self->CLOSE;
    open($self, $form, @_)      or croak "can't reopen $name: $!";
    $self->pathname($name);        # NEW
    if ($form =~ />/) {
        print $self "<SHOUT>\n" or croak "can't start print: $!";
        $$self->{WRITING} = 1;     # Remember to do end tag
    }
    else {
        $$self->{WRITING} = 0;     # Remember not to do end tag
    }
    return 1;
}

trace magical method at foo line 87
    Shout::SEEK('>filename', '>filename', 0, 2) called at foo line 81
    Shout::CLOSE('>filename') called at foo line 65
    Shout::OPEN('>filename', '+<', 'filename') called at foo line 141

14.4.2. Creative Filehandles

You can tie the same filehandle to both the input and the output of a two-ended pipe. Suppose you wanted to run the bc(1) (arbitrary precision calculator) program this way:

use Tie::Open2;

tie *CALC, 'Tie::Open2', "bc -l";
$sum = 2;
for (1 .. 7) {
    print CALC "$sum * $sum\n";
    $sum = <CALC>;
    print "$_: $sum";
    chomp $sum;
}
close CALC;

1: 4
2: 16
3: 256
4: 65536
5: 4294967296
6: 18446744073709551616
7: 340282366920938463463374607431768211456

package Tie::Open2;
use strict;
use Carp;
use Tie::Handle;  # do not inherit from this!
use IPC::Open2;

sub TIEHANDLE {
    my ($class, @cmd) = @_;
    no warnings 'once';
    my @fhpair = \do { local(*RDR, *WTR) };
    bless $_, 'Tie::StdHandle' for @fhpair;
    bless(\@fhpair => $class)->OPEN(@cmd) || die;
    return \@fhpair;
}

sub OPEN {
    my ($self, @cmd) = @_;
    $self->CLOSE if grep {defined} @{ $self->FILENO };
    open2(@$self, @cmd);
}

sub FILENO {
    my $self = shift;
    [ map { fileno $self->[$_] } 0,1 ];
}

for my $outmeth ( qw(PRINT PRINTF WRITE) ) {
    no strict 'refs';
    *$outmeth = sub {
        my $self = shift;
        $self->[1]->$outmeth(@_);
    };
}
for my $inmeth ( qw(READ READLINE GETC) ) {
    no strict 'refs';
    *$inmeth = sub {
        my $self = shift;
        $self->[0]->$inmeth(@_);
    };
}
for my $doppelmeth ( qw(BINMODE CLOSE EOF)) {
    no strict 'refs';
    *$doppelmeth = sub {
        my $self = shift;
        $self->[0]->$doppelmeth(@_) && $self->[1]->$doppelmeth(@_);
    };
}
for my $deadmeth ( qw(SEEK TELL)) {
    no strict 'refs';
    *$deadmeth = sub {
        croak("can't $deadmeth a pipe");
    };
}
1;

Here's an even wackier set of classes. The package names should give you a clue as to what they do.

use strict;
package Tie::DevNull;

    sub TIEHANDLE {
        my $class = shift;
        my $fh = local *FH;
        bless \$fh, $class;
    }
    for (qw(READ READLINE GETC PRINT PRINTF WRITE)) {
        no strict 'refs';
        *$_  = sub { return };
    }

package Tie::DevRandom;

    sub READLINE { rand() . "\n"; }
    sub TIEHANDLE {
        my $class = shift;
        my $fh = local *FH;
        bless \$fh, $class;
    }

    sub FETCH { rand() }
    sub TIESCALAR {
        my $class = shift;
        bless \my $self, $class;
    }

package Tie::Tee;

    sub TIEHANDLE {
        my $class = shift;
        my @handles;
        for my $path (@_) {
            open(my $fh, ">$path") || die "can't write $path";
            push @handles, $fh;
        }
        bless \@handles, $class;
    }

    sub PRINT {
        my $self = shift;
        my $ok = 0;
        for my $fh (@$self) {
            $ok += print $fh @_;
        }
        return $ok == @$self;
    }

package main;

tie *SCATTER,   "Tie::Tee", qw(tmp1 - tmp2 >tmp3 tmp4);
tie *RANDOM,    "Tie::DevRandom";
tie *NULL,      "Tie::DevNull";
tie my $randy,  "Tie::DevRandom";

for my $i (1..10) {
    my $line = <RANDOM>;
    chomp $line;
    for my $fh (*NULL, *SCATTER) {
        print $fh "$i: $line $randy\n";
    }
}

1: 0.124115571686165 0.20872819474074
2: 0.156618299751194 0.678171662366353
3: 0.799749050426126 0.300184963960792
4: 0.599474551447884 0.213935286029916
5: 0.700232143543861 0.800773751296671
6: 0.201203608274334 0.0654303290639575
7: 0.605381294683365 0.718162304090487
8: 0.452976481105495 0.574026269121667
9: 0.736819876983848 0.391737610662044
10: 0.518606540417331 0.381805078272308

14.3. Tying Hashes		14.5. A Subtle Untying Trap

Copyright © 2001 O'Reilly & Associates. All rights reserved.