← Index
NYTProf Performance Profile   « line view »
For /Users/timbo/perl5/perlbrew/perls/perl-5.18.2/bin/perlcritic
  Run on Sat Mar 19 22:12:22 2016
Reported on Sat Mar 19 22:14:10 2016

Filename/Users/timbo/perl5/perlbrew/perls/perl-5.18.2/lib/site_perl/5.18.2/IO/String.pm
StatementsExecuted 39 statements in 2.23ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111889µs914µsIO::String::::BEGIN@13IO::String::BEGIN@13
11117µs36µsIO::String::::BEGIN@9IO::String::BEGIN@9
11110µs70µsIO::String::::BEGIN@10IO::String::BEGIN@10
0000s0sIO::String::::DESTROYIO::String::DESTROY
0000s0sIO::String::::FILENOIO::String::FILENO
0000s0sIO::String::::READLINEIO::String::READLINE
0000s0sIO::String::::TIEHANDLEIO::String::TIEHANDLE
0000s0sIO::String::::__ANON__[:387]IO::String::__ANON__[:387]
0000s0sIO::String::::_init_seek_constantsIO::String::_init_seek_constants
0000s0sIO::String::::binmodeIO::String::binmode
0000s0sIO::String::::blockingIO::String::blocking
0000s0sIO::String::::closeIO::String::close
0000s0sIO::String::::dumpIO::String::dump
0000s0sIO::String::::eofIO::String::eof
0000s0sIO::String::::getcIO::String::getc
0000s0sIO::String::::getlineIO::String::getline
0000s0sIO::String::::getlinesIO::String::getlines
0000s0sIO::String::::getposIO::String::getpos
0000s0sIO::String::::input_line_numberIO::String::input_line_number
0000s0sIO::String::::newIO::String::new
0000s0sIO::String::::openIO::String::open
0000s0sIO::String::::openedIO::String::opened
0000s0sIO::String::::padIO::String::pad
0000s0sIO::String::::posIO::String::pos
0000s0sIO::String::::printIO::String::print
0000s0sIO::String::::printfIO::String::printf
0000s0sIO::String::::readIO::String::read
0000s0sIO::String::::seekIO::String::seek
0000s0sIO::String::::statIO::String::stat
0000s0sIO::String::::string_refIO::String::string_ref
0000s0sIO::String::::truncateIO::String::truncate
0000s0sIO::String::::ungetcIO::String::ungetc
0000s0sIO::String::::writeIO::String::write
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package IO::String;
2
3# Copyright 1998-2005 Gisle Aas.
4#
5# This library is free software; you can redistribute it and/or
6# modify it under the same terms as Perl itself.
7
8111µsrequire 5.005_03;
9235µs255µs
# spent 36µs (17+19) within IO::String::BEGIN@9 which was called: # once (17µs+19µs) by PPI::Token::Data::BEGIN@31 at line 9
use strict;
# spent 36µs making 1 call to IO::String::BEGIN@9 # spent 19µs making 1 call to strict::import
10248µs2130µs
# spent 70µs (10+60) within IO::String::BEGIN@10 which was called: # once (10µs+60µs) by PPI::Token::Data::BEGIN@31 at line 10
use vars qw($VERSION $DEBUG $IO_CONSTANTS);
# spent 70µs making 1 call to IO::String::BEGIN@10 # spent 60µs making 1 call to vars::import
111600ns$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $
12
1322.12ms1914µs
# spent 914µs (889+25) within IO::String::BEGIN@13 which was called: # once (889µs+25µs) by PPI::Token::Data::BEGIN@31 at line 13
use Symbol ();
# spent 914µs making 1 call to IO::String::BEGIN@13
14
15sub new
16{
17 my $class = shift;
18 my $self = bless Symbol::gensym(), ref($class) || $class;
19 tie *$self, $self;
20 $self->open(@_);
21 return $self;
22}
23
24sub open
25{
26 my $self = shift;
27 return $self->new(@_) unless ref($self);
28
29 if (@_) {
30 my $bufref = ref($_[0]) ? $_[0] : \$_[0];
31 $$bufref = "" unless defined $$bufref;
32 *$self->{buf} = $bufref;
33 }
34 else {
35 my $buf = "";
36 *$self->{buf} = \$buf;
37 }
38 *$self->{pos} = 0;
39 *$self->{lno} = 0;
40 return $self;
41}
42
43sub pad
44{
45 my $self = shift;
46 my $old = *$self->{pad};
47 *$self->{pad} = substr($_[0], 0, 1) if @_;
48 return "\0" unless defined($old) && length($old);
49 return $old;
50}
51
52sub dump
53{
54 require Data::Dumper;
55 my $self = shift;
56 print Data::Dumper->Dump([$self], ['*self']);
57 print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']);
58 return;
59}
60
61sub TIEHANDLE
62{
63 print "TIEHANDLE @_\n" if $DEBUG;
64 return $_[0] if ref($_[0]);
65 my $class = shift;
66 my $self = bless Symbol::gensym(), $class;
67 $self->open(@_);
68 return $self;
69}
70
71sub DESTROY
72{
73 print "DESTROY @_\n" if $DEBUG;
74}
75
76sub close
77{
78 my $self = shift;
79 delete *$self->{buf};
80 delete *$self->{pos};
81 delete *$self->{lno};
82 undef *$self if $] eq "5.008"; # workaround for some bug
83 return 1;
84}
85
86sub opened
87{
88 my $self = shift;
89 return defined *$self->{buf};
90}
91
92sub binmode
93{
94 my $self = shift;
95 return 1 unless @_;
96 # XXX don't know much about layers yet :-(
97 return 0;
98}
99
100sub getc
101{
102 my $self = shift;
103 my $buf;
104 return $buf if $self->read($buf, 1);
105 return undef;
106}
107
108sub ungetc
109{
110 my $self = shift;
111 $self->setpos($self->getpos() - 1);
112 return 1;
113}
114
115sub eof
116{
117 my $self = shift;
118 return length(${*$self->{buf}}) <= *$self->{pos};
119}
120
121sub print
122{
123 my $self = shift;
124 if (defined $\) {
125 if (defined $,) {
126 $self->write(join($,, @_).$\);
127 }
128 else {
129 $self->write(join("",@_).$\);
130 }
131 }
132 else {
133 if (defined $,) {
134 $self->write(join($,, @_));
135 }
136 else {
137 $self->write(join("",@_));
138 }
139 }
140 return 1;
141}
14212µs*printflush = \*print;
143
144sub printf
145{
146 my $self = shift;
147 print "PRINTF(@_)\n" if $DEBUG;
148 my $fmt = shift;
149 $self->write(sprintf($fmt, @_));
150 return 1;
151}
152
153
1541200nsmy($SEEK_SET, $SEEK_CUR, $SEEK_END);
155
156sub _init_seek_constants
157{
158 if ($IO_CONSTANTS) {
159 require IO::Handle;
160 $SEEK_SET = &IO::Handle::SEEK_SET;
161 $SEEK_CUR = &IO::Handle::SEEK_CUR;
162 $SEEK_END = &IO::Handle::SEEK_END;
163 }
164 else {
165 $SEEK_SET = 0;
166 $SEEK_CUR = 1;
167 $SEEK_END = 2;
168 }
169}
170
171
172sub seek
173{
174 my($self,$off,$whence) = @_;
175 my $buf = *$self->{buf} || return 0;
176 my $len = length($$buf);
177 my $pos = *$self->{pos};
178
179 _init_seek_constants() unless defined $SEEK_SET;
180
181 if ($whence == $SEEK_SET) { $pos = $off }
182 elsif ($whence == $SEEK_CUR) { $pos += $off }
183 elsif ($whence == $SEEK_END) { $pos = $len + $off }
184 else { die "Bad whence ($whence)" }
185 print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG;
186
187 $pos = 0 if $pos < 0;
188 $self->truncate($pos) if $pos > $len; # extend file
189 *$self->{pos} = $pos;
190 return 1;
191}
192
193sub pos
194{
195 my $self = shift;
196 my $old = *$self->{pos};
197 if (@_) {
198 my $pos = shift || 0;
199 my $buf = *$self->{buf};
200 my $len = $buf ? length($$buf) : 0;
201 $pos = $len if $pos > $len;
202 *$self->{pos} = $pos;
203 }
204 return $old;
205}
206
207sub getpos { shift->pos; }
208
2091900ns*sysseek = \&seek;
2101300ns*setpos = \&pos;
2111300ns*tell = \&getpos;
212
- -
215sub getline
216{
217 my $self = shift;
218 my $buf = *$self->{buf} || return;
219 my $len = length($$buf);
220 my $pos = *$self->{pos};
221 return if $pos >= $len;
222
223 unless (defined $/) { # slurp
224 *$self->{pos} = $len;
225 return substr($$buf, $pos);
226 }
227
228 unless (length $/) { # paragraph mode
229 # XXX slow&lazy implementation using getc()
230 my $para = "";
231 my $eol = 0;
232 my $c;
233 while (defined($c = $self->getc)) {
234 if ($c eq "\n") {
235 $eol++;
236 next if $eol > 2;
237 }
238 elsif ($eol > 1) {
239 $self->ungetc($c);
240 last;
241 }
242 else {
243 $eol = 0;
244 }
245 $para .= $c;
246 }
247 return $para; # XXX wantarray
248 }
249
250 my $idx = index($$buf,$/,$pos);
251 if ($idx < 0) {
252 # return rest of it
253 *$self->{pos} = $len;
254 $. = ++ *$self->{lno};
255 return substr($$buf, $pos);
256 }
257 $len = $idx - $pos + length($/);
258 *$self->{pos} += $len;
259 $. = ++ *$self->{lno};
260 return substr($$buf, $pos, $len);
261}
262
263sub getlines
264{
265 die "getlines() called in scalar context\n" unless wantarray;
266 my $self = shift;
267 my($line, @lines);
268 push(@lines, $line) while defined($line = $self->getline);
269 return @lines;
270}
271
272sub READLINE
273{
274 goto &getlines if wantarray;
275 goto &getline;
276}
277
278sub input_line_number
279{
280 my $self = shift;
281 my $old = *$self->{lno};
282 *$self->{lno} = shift if @_;
283 return $old;
284}
285
286sub truncate
287{
288 my $self = shift;
289 my $len = shift || 0;
290 my $buf = *$self->{buf};
291 if (length($$buf) >= $len) {
292 substr($$buf, $len) = '';
293 *$self->{pos} = $len if $len < *$self->{pos};
294 }
295 else {
296 $$buf .= ($self->pad x ($len - length($$buf)));
297 }
298 return 1;
299}
300
301sub read
302{
303 my $self = shift;
304 my $buf = *$self->{buf};
305 return undef unless $buf;
306
307 my $pos = *$self->{pos};
308 my $rem = length($$buf) - $pos;
309 my $len = $_[1];
310 $len = $rem if $len > $rem;
311 return undef if $len < 0;
312 if (@_ > 2) { # read offset
313 substr($_[0],$_[2]) = substr($$buf, $pos, $len);
314 }
315 else {
316 $_[0] = substr($$buf, $pos, $len);
317 }
318 *$self->{pos} += $len;
319 return $len;
320}
321
322sub write
323{
324 my $self = shift;
325 my $buf = *$self->{buf};
326 return unless $buf;
327
328 my $pos = *$self->{pos};
329 my $slen = length($_[0]);
330 my $len = $slen;
331 my $off = 0;
332 if (@_ > 1) {
333 $len = $_[1] if $_[1] < $len;
334 if (@_ > 2) {
335 $off = $_[2] || 0;
336 die "Offset outside string" if $off > $slen;
337 if ($off < 0) {
338 $off += $slen;
339 die "Offset outside string" if $off < 0;
340 }
341 my $rem = $slen - $off;
342 $len = $rem if $rem < $len;
343 }
344 }
345 substr($$buf, $pos, $len) = substr($_[0], $off, $len);
346 *$self->{pos} += $len;
347 return $len;
348}
349
3501300ns*sysread = \&read;
3511200ns*syswrite = \&write;
352
353sub stat
354{
355 my $self = shift;
356 return unless $self->opened;
357 return 1 unless wantarray;
358 my $len = length ${*$self->{buf}};
359
360 return (
361 undef, undef, # dev, ino
362 0666, # filemode
363 1, # links
364 $>, # user id
365 $), # group id
366 undef, # device id
367 $len, # size
368 undef, # atime
369 undef, # mtime
370 undef, # ctime
371 512, # blksize
372 int(($len+511)/512) # blocks
373 );
374}
375
376sub FILENO {
377 return undef; # XXX perlfunc says this means the file is closed
378}
379
380sub blocking {
381 my $self = shift;
382 my $old = *$self->{blocking} || 0;
383 *$self->{blocking} = shift if @_;
384 return $old;
385}
386
38712µsmy $notmuch = sub { return };
388
3891300ns*fileno = $notmuch;
3901100ns*error = $notmuch;
3911100ns*clearerr = $notmuch;
3921100ns*sync = $notmuch;
3931100ns*flush = $notmuch;
3941100ns*setbuf = $notmuch;
3951100ns*setvbuf = $notmuch;
396
3971100ns*untaint = $notmuch;
3981100ns*autoflush = $notmuch;
3991100ns*fcntl = $notmuch;
4001100ns*ioctl = $notmuch;
401
4021300ns*GETC = \&getc;
4031200ns*PRINT = \&print;
4041200ns*PRINTF = \&printf;
4051200ns*READ = \&read;
4061200ns*WRITE = \&write;
4071200ns*SEEK = \&seek;
4081200ns*TELL = \&getpos;
4091200ns*EOF = \&eof;
4101200ns*CLOSE = \&close;
4111200ns*BINMODE = \&binmode;
412
413
414sub string_ref
415{
416 my $self = shift;
417 return *$self->{buf};
418}
4191200ns*sref = \&string_ref;
420
421111µs1;
422
423__END__
Report produced by the NYTProf 6.01 Perl profiler, developed by Tim Bunce and Adam Kaplan.