Re: [ID 20020623.006] Tie::StdHandle produces bogus untie() warnings
[p5sagit/p5-mst-13.2.git] / 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;