Commit | Line | Data |
1d603a67 |
1 | package Tie::Handle; |
2 | |
3 | =head1 NAME |
4 | |
4592e6ca |
5 | Tie::Handle, Tie::StdHandle - base class definitions for tied handles |
1d603a67 |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | package NewHandle; |
10 | require Tie::Handle; |
11 | |
12 | @ISA = (Tie::Handle); |
13 | |
14 | sub READ { ... } # Provide a needed method |
15 | sub TIEHANDLE { ... } # Overrides inherited method |
16 | |
17 | |
18 | package main; |
19 | |
20 | tie *FH, 'NewHandle'; |
21 | |
22 | =head1 DESCRIPTION |
23 | |
24 | This module provides some skeletal methods for handle-tying classes. See |
25 | L<perltie> for a list of the functions required in tying a handle to a package. |
26 | The basic B<Tie::Handle> package provides a C<new> method, as well as methods |
4592e6ca |
27 | C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. |
1d603a67 |
28 | |
29 | For developers wishing to write their own tied-handle classes, the methods |
30 | are summarized below. The L<perltie> section not only documents these, but |
31 | has sample code as well: |
32 | |
33 | =over |
34 | |
35 | =item TIEHANDLE classname, LIST |
36 | |
37 | The method invoked by the command C<tie *glob, classname>. Associates a new |
38 | glob instance with the specified class. C<LIST> would represent additional |
39 | arguments (along the lines of L<AnyDBM_File> and compatriots) needed to |
40 | complete the association. |
41 | |
42 | =item WRITE this, scalar, length, offset |
43 | |
44 | Write I<length> bytes of data from I<scalar> starting at I<offset>. |
45 | |
46 | =item PRINT this, LIST |
47 | |
48 | Print the values in I<LIST> |
49 | |
50 | =item PRINTF this, format, LIST |
51 | |
52 | Print the values in I<LIST> using I<format> |
53 | |
54 | =item READ this, scalar, length, offset |
55 | |
56 | Read I<length> bytes of data into I<scalar> starting at I<offset>. |
57 | |
58 | =item READLINE this |
59 | |
60 | Read a single line |
61 | |
62 | =item GETC this |
63 | |
64 | Get a single character |
65 | |
8a059744 |
66 | =item CLOSE this |
67 | |
68 | Close the handle |
69 | |
4592e6ca |
70 | =item OPEN this, filename |
71 | |
72 | (Re-)open the handle |
73 | |
74 | =item BINMODE this |
75 | |
76 | Specify content is binary |
77 | |
78 | =item EOF this |
79 | |
80 | Test for end of file. |
81 | |
82 | =item TELL this |
83 | |
84 | Return position in the file. |
85 | |
86 | =item SEEK this, offset, whence |
87 | |
88 | Position the file. |
89 | |
90 | Test for end of file. |
91 | |
1d603a67 |
92 | =item DESTROY this |
93 | |
94 | Free the storage associated with the tied handle referenced by I<this>. |
95 | This is rarely needed, as Perl manages its memory quite well. But the |
96 | option exists, should a class wish to perform specific actions upon the |
97 | destruction of an instance. |
98 | |
99 | =back |
100 | |
101 | =head1 MORE INFORMATION |
102 | |
103 | The L<perltie> section contains an example of tying handles. |
104 | |
105 | =cut |
106 | |
107 | use Carp; |
108 | |
109 | sub new { |
110 | my $pkg = shift; |
111 | $pkg->TIEHANDLE(@_); |
112 | } |
113 | |
114 | # "Grandfather" the new, a la Tie::Hash |
115 | |
116 | sub TIEHANDLE { |
117 | my $pkg = shift; |
118 | if (defined &{"{$pkg}::new"}) { |
119 | carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing" |
120 | if $^W; |
121 | $pkg->new(@_); |
122 | } |
123 | else { |
124 | croak "$pkg doesn't define a TIEHANDLE method"; |
125 | } |
126 | } |
127 | |
128 | sub PRINT { |
129 | my $self = shift; |
130 | if($self->can('WRITE') != \&WRITE) { |
131 | my $buf = join(defined $, ? $, : "",@_); |
132 | $buf .= $\ if defined $\; |
133 | $self->WRITE($buf,length($buf),0); |
134 | } |
135 | else { |
136 | croak ref($self)," doesn't define a PRINT method"; |
137 | } |
138 | } |
139 | |
140 | sub PRINTF { |
141 | my $self = shift; |
142 | |
143 | if($self->can('WRITE') != \&WRITE) { |
4592e6ca |
144 | my $buf = sprintf(shift,@_); |
1d603a67 |
145 | $self->WRITE($buf,length($buf),0); |
146 | } |
147 | else { |
148 | croak ref($self)," doesn't define a PRINTF method"; |
149 | } |
150 | } |
151 | |
152 | sub READLINE { |
153 | my $pkg = ref $_[0]; |
154 | croak "$pkg doesn't define a READLINE method"; |
155 | } |
156 | |
157 | sub GETC { |
158 | my $self = shift; |
159 | |
160 | if($self->can('READ') != \&READ) { |
161 | my $buf; |
162 | $self->READ($buf,1); |
163 | return $buf; |
164 | } |
165 | else { |
166 | croak ref($self)," doesn't define a GETC method"; |
167 | } |
168 | } |
169 | |
170 | sub READ { |
171 | my $pkg = ref $_[0]; |
172 | croak "$pkg doesn't define a READ method"; |
173 | } |
174 | |
175 | sub WRITE { |
176 | my $pkg = ref $_[0]; |
177 | croak "$pkg doesn't define a WRITE method"; |
178 | } |
179 | |
180 | sub CLOSE { |
181 | my $pkg = ref $_[0]; |
182 | croak "$pkg doesn't define a CLOSE method"; |
4592e6ca |
183 | } |
184 | |
185 | package Tie::StdHandle; |
186 | use vars qw(@ISA); |
187 | @ISA = 'Tie::Handle'; |
188 | use Carp; |
189 | |
190 | sub TIEHANDLE |
191 | { |
192 | my $class = shift; |
193 | my $fh = do { \local *HANDLE}; |
194 | bless $fh,$class; |
195 | $fh->OPEN(@_) if (@_); |
196 | return $fh; |
197 | } |
198 | |
199 | sub EOF { eof($_[0]) } |
200 | sub TELL { tell($_[0]) } |
201 | sub FILENO { fileno($_[0]) } |
202 | sub SEEK { seek($_[0],$_[1],$_[2]) } |
203 | sub CLOSE { close($_[0]) } |
204 | sub BINMODE { binmode($_[0]) } |
205 | |
206 | sub OPEN |
207 | { |
208 | $_[0]->CLOSE if defined($_[0]->FILENO); |
209 | open($_[0],$_[1]); |
1d603a67 |
210 | } |
211 | |
4592e6ca |
212 | sub READ { read($_[0],$_[1],$_[2]) } |
213 | sub READLINE { my $fh = $_[0]; <$fh> } |
214 | sub GETC { getc($_[0]) } |
215 | |
216 | sub WRITE |
217 | { |
218 | my $fh = $_[0]; |
219 | print $fh substr($_[1],0,$_[2]) |
220 | } |
221 | |
222 | |
1d603a67 |
223 | 1; |