lib/Tie/Handle.pm

   1 package Tie::Handle;
   2
   3 =head1 NAME
   4
   5 Tie::Handle, Tie::StdHandle  - base class definitions for tied handles
   6
   7 =head1 SYNOPSIS
   8
   9     package NewHandle;
  10     require Tie::Handle;
  11
  12     @ISA = (Tie::Handle);
  13
  14     sub READ { ... }            # Provide a needed method
  15     sub TIEHANDLE { ... }       # Overrides inherited method
  16
  17
  18     package main;
  19
  20     tie *FH, 'NewHandle';
  21
  22 =head1 DESCRIPTION
  23
  24 This module provides some skeletal methods for handle-tying classes. See
  25 L<perltie> for a list of the functions required in tying a handle to a package.
  26 The basic B<Tie::Handle> package provides a C<new> method, as well as methods
  27 C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>.
  28
  29 For developers wishing to write their own tied-handle classes, the methods
  30 are summarized below. The L<perltie> section not only documents these, but
  31 has sample code as well:
  32
  33 =over
  34
  35 =item TIEHANDLE classname, LIST
  36
  37 The method invoked by the command C<tie *glob, classname>. Associates a new
  38 glob instance with the specified class. C<LIST> would represent additional
  39 arguments (along the lines of L<AnyDBM_File> and compatriots) needed to
  40 complete the association.
  41
  42 =item WRITE this, scalar, length, offset
  43
  44 Write I<length> bytes of data from I<scalar> starting at I<offset>.
  45
  46 =item PRINT this, LIST
  47
  48 Print the values in I<LIST>
  49
  50 =item PRINTF this, format, LIST
  51
  52 Print the values in I<LIST> using I<format>
  53
  54 =item READ this, scalar, length, offset
  55
  56 Read I<length> bytes of data into I<scalar> starting at I<offset>.
  57
  58 =item READLINE this
  59
  60 Read a single line
  61
  62 =item GETC this
  63
  64 Get a single character
  65
  66 =item CLOSE this
  67
  68 Close the handle
  69
  70 =item OPEN this, filename
  71
  72 (Re-)open the handle
  73
  74 =item BINMODE this
  75
  76 Specify content is binary
  77
  78 =item EOF this
  79
  80 Test for end of file.
  81
  82 =item TELL this
  83
  84 Return position in the file.
  85
  86 =item SEEK this, offset, whence
  87
  88 Position the file.
  89
  90 Test for end of file.
  91
  92 =item DESTROY this
  93
  94 Free the storage associated with the tied handle referenced by I<this>.
  95 This is rarely needed, as Perl manages its memory quite well. But the
  96 option exists, should a class wish to perform specific actions upon the
  97 destruction of an instance.
  98
  99 =back
 100
 101 =head1 MORE INFORMATION
 102
 103 The L<perltie> section contains an example of tying handles.
 104
 105 =cut
 106
 107 use Carp;
 108
 109 sub new {
 110     my $pkg = shift;
 111     $pkg->TIEHANDLE(@_);
 112 }
 113
 114 # "Grandfather" the new, a la Tie::Hash
 115
 116 sub TIEHANDLE {
 117     my $pkg = shift;
 118     if (defined &{"{$pkg}::new"}) {
 119         carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
 120             if $^W;
 121         $pkg->new(@_);
 122     }
 123     else {
 124         croak "$pkg doesn't define a TIEHANDLE method";
 125     }
 126 }
 127
 128 sub PRINT {
 129     my $self = shift;
 130     if($self->can('WRITE') != \&WRITE) {
 131         my $buf = join(defined $, ? $, : "",@_);
 132         $buf .= $\ if defined $\;
 133         $self->WRITE($buf,length($buf),0);
 134     }
 135     else {
 136         croak ref($self)," doesn't define a PRINT method";
 137     }
 138 }
 139
 140 sub PRINTF {
 141     my $self = shift;
 142
 143     if($self->can('WRITE') != \&WRITE) {
 144         my $buf = sprintf(shift,@_);
 145         $self->WRITE($buf,length($buf),0);
 146     }
 147     else {
 148         croak ref($self)," doesn't define a PRINTF method";
 149     }
 150 }
 151
 152 sub READLINE {
 153     my $pkg = ref $_[0];
 154     croak "$pkg doesn't define a READLINE method";
 155 }
 156
 157 sub GETC {
 158     my $self = shift;
 159
 160     if($self->can('READ') != \&READ) {
 161         my $buf;
 162         $self->READ($buf,1);
 163         return $buf;
 164     }
 165     else {
 166         croak ref($self)," doesn't define a GETC method";
 167     }
 168 }
 169
 170 sub READ {
 171     my $pkg = ref $_[0];
 172     croak "$pkg doesn't define a READ method";
 173 }
 174
 175 sub WRITE {
 176     my $pkg = ref $_[0];
 177     croak "$pkg doesn't define a WRITE method";
 178 }
 179
 180 sub CLOSE {
 181     my $pkg = ref $_[0];
 182     croak "$pkg doesn't define a CLOSE method";
 183 }
 184
 185 package Tie::StdHandle;
 186 use vars qw(@ISA);
 187 @ISA = 'Tie::Handle';
 188 use Carp;
 189
 190 sub TIEHANDLE
 191 {
 192  my $class = shift;
 193  my $fh    = do { \local *HANDLE};
 194  bless $fh,$class;
 195  $fh->OPEN(@_) if (@_);
 196  return $fh;
 197 }
 198
 199 sub EOF     { eof($_[0]) }
 200 sub TELL    { tell($_[0]) }
 201 sub FILENO  { fileno($_[0]) }
 202 sub SEEK    { seek($_[0],$_[1],$_[2]) }
 203 sub CLOSE   { close($_[0]) }
 204 sub BINMODE { binmode($_[0]) }
 205
 206 sub OPEN
 207 {
 208  $_[0]->CLOSE if defined($_[0]->FILENO);
 209  open($_[0],$_[1]);
 210 }
 211
 212 sub READ     { read($_[0],$_[1],$_[2]) }
 213 sub READLINE { my $fh = $_[0]; <$fh> }
 214 sub GETC     { getc($_[0]) }
 215
 216 sub WRITE
 217 {
 218  my $fh = $_[0];
 219  print $fh substr($_[1],0,$_[2])
 220 }
 221
 222
 223 1;