| 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; |