1package Tie::Handle; 2 3use 5.006_001; 4our $VERSION = '4.1'; 5 6=head1 NAME 7 8Tie::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 27This module provides some skeletal methods for handle-tying classes. See 28L<perltie> for a list of the functions required in tying a handle to a package. 29The basic B<Tie::Handle> package provides a C<new> method, as well as methods 30C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. 31 32For developers wishing to write their own tied-handle classes, the methods 33are summarized below. The L<perltie> section not only documents these, but 34has sample code as well: 35 36=over 4 37 38=item TIEHANDLE classname, LIST 39 40The method invoked by the command C<tie *glob, classname>. Associates a new 41glob instance with the specified class. C<LIST> would represent additional 42arguments (along the lines of L<AnyDBM_File> and compatriots) needed to 43complete the association. 44 45=item WRITE this, scalar, length, offset 46 47Write I<length> bytes of data from I<scalar> starting at I<offset>. 48 49=item PRINT this, LIST 50 51Print the values in I<LIST> 52 53=item PRINTF this, format, LIST 54 55Print the values in I<LIST> using I<format> 56 57=item READ this, scalar, length, offset 58 59Read I<length> bytes of data into I<scalar> starting at I<offset>. 60 61=item READLINE this 62 63Read a single line 64 65=item GETC this 66 67Get a single character 68 69=item CLOSE this 70 71Close the handle 72 73=item OPEN this, filename 74 75(Re-)open the handle 76 77=item BINMODE this 78 79Specify content is binary 80 81=item EOF this 82 83Test for end of file. 84 85=item TELL this 86 87Return position in the file. 88 89=item SEEK this, offset, whence 90 91Position the file. 92 93Test for end of file. 94 95=item DESTROY this 96 97Free the storage associated with the tied handle referenced by I<this>. 98This is rarely needed, as Perl manages its memory quite well. But the 99option exists, should a class wish to perform specific actions upon the 100destruction of an instance. 101 102=back 103 104=head1 MORE INFORMATION 105 106The L<perltie> section contains an example of tying handles. 107 108=head1 COMPATIBILITY 109 110This version of Tie::Handle is neither related to nor compatible with 111the Tie::Handle (3.0) module available on CPAN. It was due to an 112accident that two modules with the same name appeared. The namespace 113clash has been cleared in favor of this module that comes with the 114perl core in September 2000 and accordingly the version number has 115been bumped up to 4.0. 116 117=cut 118 119use Carp; 120use warnings::register; 121 122sub new { 123 my $pkg = shift; 124 $pkg->TIEHANDLE(@_); 125} 126 127# "Grandfather" the new, a la Tie::Hash 128 129sub 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 140sub 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 152sub 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 164sub READLINE { 165 my $pkg = ref $_[0]; 166 croak "$pkg doesn't define a READLINE method"; 167} 168 169sub 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 182sub READ { 183 my $pkg = ref $_[0]; 184 croak "$pkg doesn't define a READ method"; 185} 186 187sub WRITE { 188 my $pkg = ref $_[0]; 189 croak "$pkg doesn't define a WRITE method"; 190} 191 192sub CLOSE { 193 my $pkg = ref $_[0]; 194 croak "$pkg doesn't define a CLOSE method"; 195} 196 197package Tie::StdHandle; 198our @ISA = 'Tie::Handle'; 199use Carp; 200 201sub 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 210sub EOF { eof($_[0]) } 211sub TELL { tell($_[0]) } 212sub FILENO { fileno($_[0]) } 213sub SEEK { seek($_[0],$_[1],$_[2]) } 214sub CLOSE { close($_[0]) } 215sub BINMODE { binmode($_[0]) } 216 217sub OPEN 218{ 219 $_[0]->CLOSE if defined($_[0]->FILENO); 220 @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); 221} 222 223sub READ { read($_[0],$_[1],$_[2]) } 224sub READLINE { my $fh = $_[0]; <$fh> } 225sub GETC { getc($_[0]) } 226 227sub WRITE 228{ 229 my $fh = $_[0]; 230 print $fh substr($_[1],0,$_[2]) 231} 232 233 2341; 235