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