lib/Tie/Handle.pm

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