Commit | Line | Data |
1d603a67 |
1 | package Tie::Handle; |
2 | |
17f410f9 |
3 | use 5.005_64; |
22d4bb9c |
4 | our $VERSION = '4.0'; |
8cd2b3b0 |
5 | |
1d603a67 |
6 | =head1 NAME |
7 | |
4592e6ca |
8 | Tie::Handle, Tie::StdHandle - base class definitions for tied handles |
1d603a67 |
9 | |
10 | =head1 SYNOPSIS |
11 | |
12 | package NewHandle; |
13 | require Tie::Handle; |
3cb6de81 |
14 | |
1d603a67 |
15 | @ISA = (Tie::Handle); |
3cb6de81 |
16 | |
1d603a67 |
17 | sub READ { ... } # Provide a needed method |
18 | sub TIEHANDLE { ... } # Overrides inherited method |
3cb6de81 |
19 | |
20 | |
1d603a67 |
21 | package main; |
3cb6de81 |
22 | |
1d603a67 |
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 |
4592e6ca |
30 | C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. |
1d603a67 |
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 | |
8a059744 |
69 | =item CLOSE this |
70 | |
71 | Close the handle |
72 | |
4592e6ca |
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 | |
1d603a67 |
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 | |
22d4bb9c |
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 | |
1d603a67 |
117 | =cut |
118 | |
119 | use Carp; |
ee8c7f54 |
120 | use warnings::register; |
1d603a67 |
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"}) { |
22d4bb9c |
132 | warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"); |
1d603a67 |
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) { |
4592e6ca |
156 | my $buf = sprintf(shift,@_); |
1d603a67 |
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"; |
22d4bb9c |
195 | } |
4592e6ca |
196 | |
197 | package Tie::StdHandle; |
22d4bb9c |
198 | our @ISA = 'Tie::Handle'; |
4592e6ca |
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; |
22d4bb9c |
208 | } |
4592e6ca |
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 |
22d4bb9c |
218 | { |
4592e6ca |
219 | $_[0]->CLOSE if defined($_[0]->FILENO); |
22d4bb9c |
220 | @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]); |
1d603a67 |
221 | } |
222 | |
4592e6ca |
223 | sub READ { read($_[0],$_[1],$_[2]) } |
224 | sub READLINE { my $fh = $_[0]; <$fh> } |
225 | sub GETC { getc($_[0]) } |
226 | |
227 | sub WRITE |
22d4bb9c |
228 | { |
4592e6ca |
229 | my $fh = $_[0]; |
230 | print $fh substr($_[1],0,$_[2]) |
231 | } |
232 | |
233 | |
1d603a67 |
234 | 1; |