Tie::StdHandle did not know about 3-arg open
[perl.git] / lib / Tie / Handle.pm
1 package Tie::Handle;
2
3 use 5.005_64;
4 our $VERSION = '1.0';
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 = (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
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 =cut
109
110 use Carp;
111 use warnings::register;
112
113 sub new {
114     my $pkg = shift;
115     $pkg->TIEHANDLE(@_);
116 }
117
118 # "Grandfather" the new, a la Tie::Hash
119
120 sub TIEHANDLE {
121     my $pkg = shift;
122     if (defined &{"{$pkg}::new"}) {
123         warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing");
124         $pkg->new(@_);
125     }
126     else {
127         croak "$pkg doesn't define a TIEHANDLE method";
128     }
129 }
130
131 sub PRINT {
132     my $self = shift;
133     if($self->can('WRITE') != \&WRITE) {
134         my $buf = join(defined $, ? $, : "",@_);
135         $buf .= $\ if defined $\;
136         $self->WRITE($buf,length($buf),0);
137     }
138     else {
139         croak ref($self)," doesn't define a PRINT method";
140     }
141 }
142
143 sub PRINTF {
144     my $self = shift;
145     
146     if($self->can('WRITE') != \&WRITE) {
147         my $buf = sprintf(shift,@_);
148         $self->WRITE($buf,length($buf),0);
149     }
150     else {
151         croak ref($self)," doesn't define a PRINTF method";
152     }
153 }
154
155 sub READLINE {
156     my $pkg = ref $_[0];
157     croak "$pkg doesn't define a READLINE method";
158 }
159
160 sub GETC {
161     my $self = shift;
162     
163     if($self->can('READ') != \&READ) {
164         my $buf;
165         $self->READ($buf,1);
166         return $buf;
167     }
168     else {
169         croak ref($self)," doesn't define a GETC method";
170     }
171 }
172
173 sub READ {
174     my $pkg = ref $_[0];
175     croak "$pkg doesn't define a READ method";
176 }
177
178 sub WRITE {
179     my $pkg = ref $_[0];
180     croak "$pkg doesn't define a WRITE method";
181 }
182
183 sub CLOSE {
184     my $pkg = ref $_[0];
185     croak "$pkg doesn't define a CLOSE method";
186 }
187
188 package Tie::StdHandle; 
189 our @ISA = 'Tie::Handle';
190 use Carp;
191
192 sub TIEHANDLE 
193 {
194  my $class = shift;
195  my $fh    = do { \local *HANDLE};
196  bless $fh,$class;
197  $fh->OPEN(@_) if (@_);
198  return $fh;
199 }
200
201 sub EOF     { eof($_[0]) }
202 sub TELL    { tell($_[0]) }
203 sub FILENO  { fileno($_[0]) }
204 sub SEEK    { seek($_[0],$_[1],$_[2]) }
205 sub CLOSE   { close($_[0]) }
206 sub BINMODE { binmode($_[0]) }
207
208 sub OPEN
209 {
210  $_[0]->CLOSE if defined($_[0]->FILENO);
211  @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
212 }
213
214 sub READ     { read($_[0],$_[1],$_[2]) }
215 sub READLINE { my $fh = $_[0]; <$fh> }
216 sub GETC     { getc($_[0]) }
217
218 sub WRITE
219 {
220  my $fh = $_[0];
221  print $fh substr($_[1],0,$_[2])
222 }
223
224
225 1;