File | /usr/lib/perl/5.10/IO/Handle.pm |
Statements Executed | 30 |
Total Time | 0.0029709 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN | IO::Handle::
0 | 0 | 0 | 0s | 0s | DESTROY | IO::Handle::
0 | 0 | 0 | 0s | 0s | _open_mode_string | IO::Handle::
0 | 0 | 0 | 0s | 0s | autoflush | IO::Handle::
0 | 0 | 0 | 0s | 0s | close | IO::Handle::
0 | 0 | 0 | 0s | 0s | constant | IO::Handle::
0 | 0 | 0 | 0s | 0s | eof | IO::Handle::
0 | 0 | 0 | 0s | 0s | fcntl | IO::Handle::
0 | 0 | 0 | 0s | 0s | fdopen | IO::Handle::
0 | 0 | 0 | 0s | 0s | fileno | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_formfeed | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_line_break_characters | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_lines_left | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_lines_per_page | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_name | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_page_number | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_top_name | IO::Handle::
0 | 0 | 0 | 0s | 0s | format_write | IO::Handle::
0 | 0 | 0 | 0s | 0s | formline | IO::Handle::
0 | 0 | 0 | 0s | 0s | getc | IO::Handle::
0 | 0 | 0 | 0s | 0s | getline | IO::Handle::
0 | 0 | 0 | 0s | 0s | getlines | IO::Handle::
0 | 0 | 0 | 0s | 0s | input_line_number | IO::Handle::
0 | 0 | 0 | 0s | 0s | input_record_separator | IO::Handle::
0 | 0 | 0 | 0s | 0s | ioctl | IO::Handle::
0 | 0 | 0 | 0s | 0s | new | IO::Handle::
0 | 0 | 0 | 0s | 0s | new_from_fd | IO::Handle::
0 | 0 | 0 | 0s | 0s | opened | IO::Handle::
0 | 0 | 0 | 0s | 0s | output_field_separator | IO::Handle::
0 | 0 | 0 | 0s | 0s | output_record_separator | IO::Handle::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | printf | IO::Handle::
0 | 0 | 0 | 0s | 0s | printflush | IO::Handle::
0 | 0 | 0 | 0s | 0s | read | IO::Handle::
0 | 0 | 0 | 0s | 0s | say | IO::Handle::
0 | 0 | 0 | 0s | 0s | stat | IO::Handle::
0 | 0 | 0 | 0s | 0s | sysread | IO::Handle::
0 | 0 | 0 | 0s | 0s | syswrite | IO::Handle::
0 | 0 | 0 | 0s | 0s | truncate | IO::Handle::
0 | 0 | 0 | 0s | 0s | write | IO::Handle::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package IO::Handle; | |||
2 | ||||
3 | 3 | 31µs | 10µs | use 5.006_001; |
4 | 3 | 80µs | 27µs | use strict; # spent 41µs making 1 call to strict::import |
5 | 1 | 600ns | 600ns | our($VERSION, @EXPORT_OK, @ISA); |
6 | 3 | 27µs | 9µs | use Carp; # spent 53µs making 1 call to Exporter::import |
7 | 3 | 29µs | 10µs | use Symbol; # spent 52µs making 1 call to Exporter::import |
8 | 3 | 26µs | 8µs | use SelectSaver; # spent 5µs making 1 call to import |
9 | 3 | 2.52ms | 839µs | use IO (); # Load the XS module |
10 | ||||
11 | 1 | 1µs | 1µs | require Exporter; |
12 | 1 | 9µs | 9µs | @ISA = qw(Exporter); |
13 | ||||
14 | 1 | 600ns | 600ns | $VERSION = "1.27"; |
15 | 1 | 25µs | 25µs | $VERSION = eval $VERSION; |
16 | ||||
17 | 1 | 6µs | 6µs | @EXPORT_OK = qw( |
18 | autoflush | |||
19 | output_field_separator | |||
20 | output_record_separator | |||
21 | input_record_separator | |||
22 | input_line_number | |||
23 | format_page_number | |||
24 | format_lines_per_page | |||
25 | format_lines_left | |||
26 | format_name | |||
27 | format_top_name | |||
28 | format_line_break_characters | |||
29 | format_formfeed | |||
30 | format_write | |||
31 | ||||
32 | ||||
33 | printf | |||
34 | say | |||
35 | getline | |||
36 | getlines | |||
37 | ||||
38 | printflush | |||
39 | flush | |||
40 | ||||
41 | SEEK_SET | |||
42 | SEEK_CUR | |||
43 | SEEK_END | |||
44 | _IOFBF | |||
45 | _IOLBF | |||
46 | _IONBF | |||
47 | ); | |||
48 | ||||
49 | ################################################ | |||
50 | ## Constructors, destructors. | |||
51 | ## | |||
52 | ||||
53 | sub new { | |||
54 | my $class = ref($_[0]) || $_[0] || "IO::Handle"; | |||
55 | @_ == 1 or croak "usage: new $class"; | |||
56 | my $io = gensym; | |||
57 | bless $io, $class; | |||
58 | } | |||
59 | ||||
60 | sub new_from_fd { | |||
61 | my $class = ref($_[0]) || $_[0] || "IO::Handle"; | |||
62 | @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; | |||
63 | my $io = gensym; | |||
64 | shift; | |||
65 | IO::Handle::fdopen($io, @_) | |||
66 | or return undef; | |||
67 | bless $io, $class; | |||
68 | } | |||
69 | ||||
70 | # | |||
71 | # There is no need for DESTROY to do anything, because when the | |||
72 | # last reference to an IO object is gone, Perl automatically | |||
73 | # closes its associated files (if any). However, to avoid any | |||
74 | # attempts to autoload DESTROY, we here define it to do nothing. | |||
75 | # | |||
76 | 1 | 400ns | 400ns | sub DESTROY {} |
77 | ||||
78 | ################################################ | |||
79 | ## Open and close. | |||
80 | ## | |||
81 | ||||
82 | sub _open_mode_string { | |||
83 | my ($mode) = @_; | |||
84 | $mode =~ /^\+?(<|>>?)$/ | |||
85 | or $mode =~ s/^r(\+?)$/$1</ | |||
86 | or $mode =~ s/^w(\+?)$/$1>/ | |||
87 | or $mode =~ s/^a(\+?)$/$1>>/ | |||
88 | or croak "IO::Handle: bad open mode: $mode"; | |||
89 | $mode; | |||
90 | } | |||
91 | ||||
92 | sub fdopen { | |||
93 | @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; | |||
94 | my ($io, $fd, $mode) = @_; | |||
95 | local(*GLOB); | |||
96 | ||||
97 | if (ref($fd) && "".$fd =~ /GLOB\(/o) { | |||
98 | # It's a glob reference; Alias it as we cannot get name of anon GLOBs | |||
99 | my $n = qualify(*GLOB); | |||
100 | *GLOB = *{*$fd}; | |||
101 | $fd = $n; | |||
102 | } elsif ($fd =~ m#^\d+$#) { | |||
103 | # It's an FD number; prefix with "=". | |||
104 | $fd = "=$fd"; | |||
105 | } | |||
106 | ||||
107 | open($io, _open_mode_string($mode) . '&' . $fd) | |||
108 | ? $io : undef; | |||
109 | } | |||
110 | ||||
111 | sub close { | |||
112 | @_ == 1 or croak 'usage: $io->close()'; | |||
113 | my($io) = @_; | |||
114 | ||||
115 | close($io); | |||
116 | } | |||
117 | ||||
118 | ################################################ | |||
119 | ## Normal I/O functions. | |||
120 | ## | |||
121 | ||||
122 | # flock | |||
123 | # select | |||
124 | ||||
125 | sub opened { | |||
126 | @_ == 1 or croak 'usage: $io->opened()'; | |||
127 | defined fileno($_[0]); | |||
128 | } | |||
129 | ||||
130 | sub fileno { | |||
131 | @_ == 1 or croak 'usage: $io->fileno()'; | |||
132 | fileno($_[0]); | |||
133 | } | |||
134 | ||||
135 | sub getc { | |||
136 | @_ == 1 or croak 'usage: $io->getc()'; | |||
137 | getc($_[0]); | |||
138 | } | |||
139 | ||||
140 | sub eof { | |||
141 | @_ == 1 or croak 'usage: $io->eof()'; | |||
142 | eof($_[0]); | |||
143 | } | |||
144 | ||||
145 | sub print { | |||
146 | @_ or croak 'usage: $io->print(ARGS)'; | |||
147 | my $this = shift; | |||
148 | print $this @_; | |||
149 | } | |||
150 | ||||
151 | sub printf { | |||
152 | @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; | |||
153 | my $this = shift; | |||
154 | printf $this @_; | |||
155 | } | |||
156 | ||||
157 | sub say { | |||
158 | @_ or croak 'usage: $io->say(ARGS)'; | |||
159 | my $this = shift; | |||
160 | print $this @_, "\n"; | |||
161 | } | |||
162 | ||||
163 | sub getline { | |||
164 | @_ == 1 or croak 'usage: $io->getline()'; | |||
165 | my $this = shift; | |||
166 | return scalar <$this>; | |||
167 | } | |||
168 | ||||
169 | 1 | 6µs | 6µs | *gets = \&getline; # deprecated |
170 | ||||
171 | sub getlines { | |||
172 | @_ == 1 or croak 'usage: $io->getlines()'; | |||
173 | wantarray or | |||
174 | croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; | |||
175 | my $this = shift; | |||
176 | return <$this>; | |||
177 | } | |||
178 | ||||
179 | sub truncate { | |||
180 | @_ == 2 or croak 'usage: $io->truncate(LEN)'; | |||
181 | truncate($_[0], $_[1]); | |||
182 | } | |||
183 | ||||
184 | sub read { | |||
185 | @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; | |||
186 | read($_[0], $_[1], $_[2], $_[3] || 0); | |||
187 | } | |||
188 | ||||
189 | sub sysread { | |||
190 | @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; | |||
191 | sysread($_[0], $_[1], $_[2], $_[3] || 0); | |||
192 | } | |||
193 | ||||
194 | sub write { | |||
195 | @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; | |||
196 | local($\) = ""; | |||
197 | $_[2] = length($_[1]) unless defined $_[2]; | |||
198 | print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); | |||
199 | } | |||
200 | ||||
201 | sub syswrite { | |||
202 | @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; | |||
203 | if (defined($_[2])) { | |||
204 | syswrite($_[0], $_[1], $_[2], $_[3] || 0); | |||
205 | } else { | |||
206 | syswrite($_[0], $_[1]); | |||
207 | } | |||
208 | } | |||
209 | ||||
210 | sub stat { | |||
211 | @_ == 1 or croak 'usage: $io->stat()'; | |||
212 | stat($_[0]); | |||
213 | } | |||
214 | ||||
215 | ################################################ | |||
216 | ## State modification functions. | |||
217 | ## | |||
218 | ||||
219 | sub autoflush { | |||
220 | my $old = new SelectSaver qualify($_[0], caller); | |||
221 | my $prev = $|; | |||
222 | $| = @_ > 1 ? $_[1] : 1; | |||
223 | $prev; | |||
224 | } | |||
225 | ||||
226 | sub output_field_separator { | |||
227 | carp "output_field_separator is not supported on a per-handle basis" | |||
228 | if ref($_[0]); | |||
229 | my $prev = $,; | |||
230 | $, = $_[1] if @_ > 1; | |||
231 | $prev; | |||
232 | } | |||
233 | ||||
234 | sub output_record_separator { | |||
235 | carp "output_record_separator is not supported on a per-handle basis" | |||
236 | if ref($_[0]); | |||
237 | my $prev = $\; | |||
238 | $\ = $_[1] if @_ > 1; | |||
239 | $prev; | |||
240 | } | |||
241 | ||||
242 | sub input_record_separator { | |||
243 | carp "input_record_separator is not supported on a per-handle basis" | |||
244 | if ref($_[0]); | |||
245 | my $prev = $/; | |||
246 | $/ = $_[1] if @_ > 1; | |||
247 | $prev; | |||
248 | } | |||
249 | ||||
250 | sub input_line_number { | |||
251 | local $.; | |||
252 | () = tell qualify($_[0], caller) if ref($_[0]); | |||
253 | my $prev = $.; | |||
254 | $. = $_[1] if @_ > 1; | |||
255 | $prev; | |||
256 | } | |||
257 | ||||
258 | sub format_page_number { | |||
259 | my $old; | |||
260 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); | |||
261 | my $prev = $%; | |||
262 | $% = $_[1] if @_ > 1; | |||
263 | $prev; | |||
264 | } | |||
265 | ||||
266 | sub format_lines_per_page { | |||
267 | my $old; | |||
268 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); | |||
269 | my $prev = $=; | |||
270 | $= = $_[1] if @_ > 1; | |||
271 | $prev; | |||
272 | } | |||
273 | ||||
274 | sub format_lines_left { | |||
275 | my $old; | |||
276 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); | |||
277 | my $prev = $-; | |||
278 | $- = $_[1] if @_ > 1; | |||
279 | $prev; | |||
280 | } | |||
281 | ||||
282 | sub format_name { | |||
283 | my $old; | |||
284 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); | |||
285 | my $prev = $~; | |||
286 | $~ = qualify($_[1], caller) if @_ > 1; | |||
287 | $prev; | |||
288 | } | |||
289 | ||||
290 | sub format_top_name { | |||
291 | my $old; | |||
292 | $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); | |||
293 | my $prev = $^; | |||
294 | $^ = qualify($_[1], caller) if @_ > 1; | |||
295 | $prev; | |||
296 | } | |||
297 | ||||
298 | sub format_line_break_characters { | |||
299 | carp "format_line_break_characters is not supported on a per-handle basis" | |||
300 | if ref($_[0]); | |||
301 | my $prev = $:; | |||
302 | $: = $_[1] if @_ > 1; | |||
303 | $prev; | |||
304 | } | |||
305 | ||||
306 | sub format_formfeed { | |||
307 | carp "format_formfeed is not supported on a per-handle basis" | |||
308 | if ref($_[0]); | |||
309 | my $prev = $^L; | |||
310 | $^L = $_[1] if @_ > 1; | |||
311 | $prev; | |||
312 | } | |||
313 | ||||
314 | sub formline { | |||
315 | my $io = shift; | |||
316 | my $picture = shift; | |||
317 | local($^A) = $^A; | |||
318 | local($\) = ""; | |||
319 | formline($picture, @_); | |||
320 | print $io $^A; | |||
321 | } | |||
322 | ||||
323 | sub format_write { | |||
324 | @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; | |||
325 | if (@_ == 2) { | |||
326 | my ($io, $fmt) = @_; | |||
327 | my $oldfmt = $io->format_name(qualify($fmt,caller)); | |||
328 | CORE::write($io); | |||
329 | $io->format_name($oldfmt); | |||
330 | } else { | |||
331 | CORE::write($_[0]); | |||
332 | } | |||
333 | } | |||
334 | ||||
335 | # XXX undocumented | |||
336 | sub fcntl { | |||
337 | @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; | |||
338 | my ($io, $op) = @_; | |||
339 | return fcntl($io, $op, $_[2]); | |||
340 | } | |||
341 | ||||
342 | # XXX undocumented | |||
343 | sub ioctl { | |||
344 | @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; | |||
345 | my ($io, $op) = @_; | |||
346 | return ioctl($io, $op, $_[2]); | |||
347 | } | |||
348 | ||||
349 | # this sub is for compatability with older releases of IO that used | |||
350 | # a sub called constant to detemine if a constant existed -- GMB | |||
351 | # | |||
352 | # The SEEK_* and _IO?BF constants were the only constants at that time | |||
353 | # any new code should just chech defined(&CONSTANT_NAME) | |||
354 | ||||
355 | sub constant { | |||
356 | 3 | 197µs | 66µs | no strict 'refs'; # spent 27µs making 1 call to strict::unimport |
357 | my $name = shift; | |||
358 | (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) | |||
359 | ? &{$name}() : undef; | |||
360 | } | |||
361 | ||||
362 | # so that flush.pl can be deprecated | |||
363 | ||||
364 | sub printflush { | |||
365 | my $io = shift; | |||
366 | my $old; | |||
367 | $old = new SelectSaver qualify($io, caller) if ref($io); | |||
368 | local $| = 1; | |||
369 | if(ref($io)) { | |||
370 | print $io @_; | |||
371 | } | |||
372 | else { | |||
373 | print @_; | |||
374 | } | |||
375 | } | |||
376 | ||||
377 | 1 | 16µs | 16µs | 1; |