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