| 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 | IO::Handle::BEGIN |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::DESTROY |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::_open_mode_string |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::autoflush |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::close |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::constant |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::eof |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::fcntl |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::fdopen |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::fileno |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_formfeed |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_line_break_characters |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_lines_left |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_lines_per_page |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_name |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_page_number |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_top_name |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::format_write |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::formline |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::getc |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::getline |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::getlines |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::input_line_number |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::input_record_separator |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::ioctl |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::new |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::new_from_fd |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::opened |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::output_field_separator |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::output_record_separator |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::print |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::printf |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::printflush |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::read |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::say |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::stat |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::sysread |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::syswrite |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::truncate |
| 0 | 0 | 0 | 0s | 0s | IO::Handle::write |
| 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; |