Commit | Line | Data |
---|---|---|
920dae64 AT |
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; |