Commit | Line | Data |
---|---|---|
1d603a67 GB |
1 | package Tie::Handle; |
2 | ||
3 | =head1 NAME | |
4 | ||
4592e6ca | 5 | Tie::Handle, Tie::StdHandle - base class definitions for tied handles |
1d603a67 GB |
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 GB |
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 GS |
66 | =item CLOSE this |
67 | ||
68 | Close the handle | |
69 | ||
4592e6ca NIS |
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 GB |
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 GB |
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 NIS |
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 GB |
210 | } |
211 | ||
4592e6ca NIS |
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; |