lib/Tie/Handle.pm

   1 package Tie::Handle;
   2
   3 use 5.005_64;
   4 our $VERSION = '1.0';
   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 = (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
  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 =cut
 109
 110 use Carp;
 111 use warnings::register;
 112
 113 sub new {
 114     my $pkg = shift;
 115     $pkg->TIEHANDLE(@_);
 116 }
 117
 118 # "Grandfather" the new, a la Tie::Hash
 119
 120 sub TIEHANDLE {
 121     my $pkg = shift;
 122     if (defined &{"{$pkg}::new"}) {
 123         warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
 124             if warnings::enabled();
 125         $pkg->new(@_);
 126     }
 127     else {
 128         croak "$pkg doesn't define a TIEHANDLE method";
 129     }
 130 }
 131
 132 sub PRINT {
 133     my $self = shift;
 134     if($self->can('WRITE') != \&WRITE) {
 135         my $buf = join(defined $, ? $, : "",@_);
 136         $buf .= $\ if defined $\;
 137         $self->WRITE($buf,length($buf),0);
 138     }
 139     else {
 140         croak ref($self)," doesn't define a PRINT method";
 141     }
 142 }
 143
 144 sub PRINTF {
 145     my $self = shift;
 146
 147     if($self->can('WRITE') != \&WRITE) {
 148         my $buf = sprintf(shift,@_);
 149         $self->WRITE($buf,length($buf),0);
 150     }
 151     else {
 152         croak ref($self)," doesn't define a PRINTF method";
 153     }
 154 }
 155
 156 sub READLINE {
 157     my $pkg = ref $_[0];
 158     croak "$pkg doesn't define a READLINE method";
 159 }
 160
 161 sub GETC {
 162     my $self = shift;
 163
 164     if($self->can('READ') != \&READ) {
 165         my $buf;
 166         $self->READ($buf,1);
 167         return $buf;
 168     }
 169     else {
 170         croak ref($self)," doesn't define a GETC method";
 171     }
 172 }
 173
 174 sub READ {
 175     my $pkg = ref $_[0];
 176     croak "$pkg doesn't define a READ method";
 177 }
 178
 179 sub WRITE {
 180     my $pkg = ref $_[0];
 181     croak "$pkg doesn't define a WRITE method";
 182 }
 183
 184 sub CLOSE {
 185     my $pkg = ref $_[0];
 186     croak "$pkg doesn't define a CLOSE method";
 187 }
 188
 189 package Tie::StdHandle;
 190 our @ISA = 'Tie::Handle';
 191 use Carp;
 192
 193 sub TIEHANDLE
 194 {
 195  my $class = shift;
 196  my $fh    = do { \local *HANDLE};
 197  bless $fh,$class;
 198  $fh->OPEN(@_) if (@_);
 199  return $fh;
 200 }
 201
 202 sub EOF     { eof($_[0]) }
 203 sub TELL    { tell($_[0]) }
 204 sub FILENO  { fileno($_[0]) }
 205 sub SEEK    { seek($_[0],$_[1],$_[2]) }
 206 sub CLOSE   { close($_[0]) }
 207 sub BINMODE { binmode($_[0]) }
 208
 209 sub OPEN
 210 {
 211  $_[0]->CLOSE if defined($_[0]->FILENO);
 212  open($_[0],$_[1]);
 213 }
 214
 215 sub READ     { read($_[0],$_[1],$_[2]) }
 216 sub READLINE { my $fh = $_[0]; <$fh> }
 217 sub GETC     { getc($_[0]) }
 218
 219 sub WRITE
 220 {
 221  my $fh = $_[0];
 222  print $fh substr($_[1],0,$_[2])
 223 }
 224
 225
 226 1;