← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:10 2021

Filename/usr/local/lib/perl5/site_perl/IO/Scalar.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sIO::Scalar::::BEGIN@10IO::Scalar::BEGIN@10
0000s0sIO::Scalar::::BEGIN@3IO::Scalar::BEGIN@3
0000s0sIO::Scalar::::BEGIN@5IO::Scalar::BEGIN@5
0000s0sIO::Scalar::::BEGIN@6IO::Scalar::BEGIN@6
0000s0sIO::Scalar::::BEGIN@9IO::Scalar::BEGIN@9
0000s0sIO::Scalar::::BINMODEIO::Scalar::BINMODE
0000s0sIO::Scalar::::CLOSEIO::Scalar::CLOSE
0000s0sIO::Scalar::::DESTROYIO::Scalar::DESTROY
0000s0sIO::Scalar::::EOFIO::Scalar::EOF
0000s0sIO::Scalar::::GETCIO::Scalar::GETC
0000s0sIO::Scalar::::PRINTIO::Scalar::PRINT
0000s0sIO::Scalar::::PRINTFIO::Scalar::PRINTF
0000s0sIO::Scalar::::READIO::Scalar::READ
0000s0sIO::Scalar::::READLINEIO::Scalar::READLINE
0000s0sIO::Scalar::::SEEKIO::Scalar::SEEK
0000s0sIO::Scalar::::TELLIO::Scalar::TELL
0000s0sIO::Scalar::::TIEHANDLEIO::Scalar::TIEHANDLE
0000s0sIO::Scalar::::WRITEIO::Scalar::WRITE
0000s0sIO::Scalar::::__ANON__[:10]IO::Scalar::__ANON__[:10]
0000s0sIO::Scalar::::__ANON__[:9]IO::Scalar::__ANON__[:9]
0000s0sIO::Scalar::::_old_printIO::Scalar::_old_print
0000s0sIO::Scalar::::_unsafe_printIO::Scalar::_unsafe_print
0000s0sIO::Scalar::::autoflushIO::Scalar::autoflush
0000s0sIO::Scalar::::binmodeIO::Scalar::binmode
0000s0sIO::Scalar::::clearerrIO::Scalar::clearerr
0000s0sIO::Scalar::::closeIO::Scalar::close
0000s0sIO::Scalar::::eofIO::Scalar::eof
0000s0sIO::Scalar::::filenoIO::Scalar::fileno
0000s0sIO::Scalar::::flushIO::Scalar::flush
0000s0sIO::Scalar::::getcIO::Scalar::getc
0000s0sIO::Scalar::::getlineIO::Scalar::getline
0000s0sIO::Scalar::::getlinesIO::Scalar::getlines
0000s0sIO::Scalar::::newIO::Scalar::new
0000s0sIO::Scalar::::openIO::Scalar::open
0000s0sIO::Scalar::::openedIO::Scalar::opened
0000s0sIO::Scalar::::printIO::Scalar::print
0000s0sIO::Scalar::::readIO::Scalar::read
0000s0sIO::Scalar::::seekIO::Scalar::seek
0000s0sIO::Scalar::::setposIO::Scalar::setpos
0000s0sIO::Scalar::::srefIO::Scalar::sref
0000s0sIO::Scalar::::sysreadIO::Scalar::sysread
0000s0sIO::Scalar::::sysseekIO::Scalar::sysseek
0000s0sIO::Scalar::::syswriteIO::Scalar::syswrite
0000s0sIO::Scalar::::tellIO::Scalar::tell
0000s0sIO::Scalar::::use_RSIO::Scalar::use_RS
0000s0sIO::Scalar::::writeIO::Scalar::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::Scalar;
2
3use strict;
4
5use Carp;
6use IO::Handle;
7
8### Stringification, courtesy of B. K. Oxley (binkley): :-)
9use overload '""' => sub { ${*{$_[0]}->{SR}} };
10use overload 'bool' => sub { 1 }; ### have to do this, so object is true!
11
12### The package version, both in 1.23 style *and* usable by MakeMaker:
13our $VERSION = '2.113';
14
15### Inheritance:
16our @ISA = qw(IO::Handle);
17
18### This stuff should be got rid of ASAP.
19require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
20
21#==============================
22
- -
25=head1 NAME
26
27IO::Scalar - IO:: interface for reading/writing a scalar
28
29
30=head1 SYNOPSIS
31
32Perform I/O on strings, using the basic OO interface...
33
34 use 5.005;
35 use IO::Scalar;
36 $data = "My message:\n";
37
38 ### Open a handle on a string, and append to it:
39 $SH = new IO::Scalar \$data;
40 $SH->print("Hello");
41 $SH->print(", world!\nBye now!\n");
42 print "The string is now: ", $data, "\n";
43
44 ### Open a handle on a string, read it line-by-line, then close it:
45 $SH = new IO::Scalar \$data;
46 while (defined($_ = $SH->getline)) {
47 print "Got line: $_";
48 }
49 $SH->close;
50
51 ### Open a handle on a string, and slurp in all the lines:
52 $SH = new IO::Scalar \$data;
53 print "All lines:\n", $SH->getlines;
54
55 ### Get the current position (either of two ways):
56 $pos = $SH->getpos;
57 $offset = $SH->tell;
58
59 ### Set the current position (either of two ways):
60 $SH->setpos($pos);
61 $SH->seek($offset, 0);
62
63 ### Open an anonymous temporary scalar:
64 $SH = new IO::Scalar;
65 $SH->print("Hi there!");
66 print "I printed: ", ${$SH->sref}, "\n"; ### get at value
67
68
69Don't like OO for your I/O? No problem.
70Thanks to the magic of an invisible tie(), the following now
71works out of the box, just as it does with IO::Handle:
72
73 use 5.005;
74 use IO::Scalar;
75 $data = "My message:\n";
76
77 ### Open a handle on a string, and append to it:
78 $SH = new IO::Scalar \$data;
79 print $SH "Hello";
80 print $SH ", world!\nBye now!\n";
81 print "The string is now: ", $data, "\n";
82
83 ### Open a handle on a string, read it line-by-line, then close it:
84 $SH = new IO::Scalar \$data;
85 while (<$SH>) {
86 print "Got line: $_";
87 }
88 close $SH;
89
90 ### Open a handle on a string, and slurp in all the lines:
91 $SH = new IO::Scalar \$data;
92 print "All lines:\n", <$SH>;
93
94 ### Get the current position (WARNING: requires 5.6):
95 $offset = tell $SH;
96
97 ### Set the current position (WARNING: requires 5.6):
98 seek $SH, $offset, 0;
99
100 ### Open an anonymous temporary scalar:
101 $SH = new IO::Scalar;
102 print $SH "Hi there!";
103 print "I printed: ", ${$SH->sref}, "\n"; ### get at value
104
105
106And for you folks with 1.x code out there: the old tie() style still works,
107though this is I<unnecessary and deprecated>:
108
109 use IO::Scalar;
110
111 ### Writing to a scalar...
112 my $s;
113 tie *OUT, 'IO::Scalar', \$s;
114 print OUT "line 1\nline 2\n", "line 3\n";
115 print "String is now: $s\n"
116
117 ### Reading and writing an anonymous scalar...
118 tie *OUT, 'IO::Scalar';
119 print OUT "line 1\nline 2\n", "line 3\n";
120 tied(OUT)->seek(0,0);
121 while (<OUT>) {
122 print "Got line: ", $_;
123 }
124
125
126Stringification works, too!
127
128 my $SH = new IO::Scalar \$data;
129 print $SH "Hello, ";
130 print $SH "world!";
131 print "I printed: $SH\n";
132
- -
135=head1 DESCRIPTION
136
137This class is part of the IO::Stringy distribution;
138see L<IO::Stringy> for change log and general information.
139
140The IO::Scalar class implements objects which behave just like
141IO::Handle (or FileHandle) objects, except that you may use them
142to write to (or read from) scalars. These handles are
143automatically C<tiehandle>d (though please see L<"WARNINGS">
144for information relevant to your Perl version).
145
146
147Basically, this:
148
149 my $s;
150 $SH = new IO::Scalar \$s;
151 $SH->print("Hel", "lo, "); ### OO style
152 $SH->print("world!\n"); ### ditto
153
154Or this:
155
156 my $s;
157 $SH = tie *OUT, 'IO::Scalar', \$s;
158 print OUT "Hel", "lo, "; ### non-OO style
159 print OUT "world!\n"; ### ditto
160
161Causes $s to be set to:
162
163 "Hello, world!\n"
164
165
166=head1 PUBLIC INTERFACE
167
168=head2 Construction
169
170=over 4
171
172=cut
173
174#------------------------------
175
176=item new [ARGS...]
177
178I<Class method.>
179Return a new, unattached scalar handle.
180If any arguments are given, they're sent to open().
181
182=cut
183
184sub new {
185 my $proto = shift;
186 my $class = ref($proto) || $proto;
187 my $self = bless \do { local *FH }, $class;
188 tie *$self, $class, $self;
189 $self->open(@_); ### open on anonymous by default
190 $self;
191}
192sub DESTROY {
193 shift->close;
194}
195
196#------------------------------
197
198=item open [SCALARREF]
199
200I<Instance method.>
201Open the scalar handle on a new scalar, pointed to by SCALARREF.
202If no SCALARREF is given, a "private" scalar is created to hold
203the file data.
204
205Returns the self object on success, undefined on error.
206
207=cut
208
209sub open {
210 my ($self, $sref) = @_;
211
212 ### Sanity:
213 defined($sref) or do {my $s = ''; $sref = \$s};
214 (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
215
216 ### Setup:
217 *$self->{Pos} = 0; ### seek position
218 *$self->{SR} = $sref; ### scalar reference
219 $self;
220}
221
222#------------------------------
223
224=item opened
225
226I<Instance method.>
227Is the scalar handle opened on something?
228
229=cut
230
231sub opened {
232 *{shift()}->{SR};
233}
234
235#------------------------------
236
237=item close
238
239I<Instance method.>
240Disassociate the scalar handle from its underlying scalar.
241Done automatically on destroy.
242
243=cut
244
245sub close {
246 my $self = shift;
247 %{*$self} = ();
248 1;
249}
250
251=back
252
253=cut
254
- -
257#==============================
258
259=head2 Input and output
260
261=over 4
262
263=cut
264
265
266#------------------------------
267
268=item flush
269
270I<Instance method.>
271No-op, provided for OO compatibility.
272
273=cut
274
275sub flush { "0 but true" }
276
277#------------------------------
278
279=item fileno
280
281I<Instance method.>
282No-op, returns undef
283
284=cut
285
286sub fileno { }
287
288#------------------------------
289
290=item getc
291
292I<Instance method.>
293Return the next character, or undef if none remain.
294
295=cut
296
297sub getc {
298 my $self = shift;
299
300 ### Return undef right away if at EOF; else, move pos forward:
301 return undef if $self->eof;
302 substr(${*$self->{SR}}, *$self->{Pos}++, 1);
303}
304
305#------------------------------
306
307=item getline
308
309I<Instance method.>
310Return the next line, or undef on end of string.
311Can safely be called in an array context.
312Currently, lines are delimited by "\n".
313
314=cut
315
316sub getline {
317 my $self = shift;
318
319 ### Return undef right away if at EOF:
320 return undef if $self->eof;
321
322 ### Get next line:
323 my $sr = *$self->{SR};
324 my $i = *$self->{Pos}; ### Start matching at this point.
325
326 ### Minimal impact implementation!
327 ### We do the fast thing (no regexps) if using the
328 ### classic input record separator.
329
330 ### Case 1: $/ is undef: slurp all...
331 if (!defined($/)) {
332 *$self->{Pos} = length $$sr;
333 return substr($$sr, $i);
334 }
335
336 ### Case 2: $/ is "\n": zoom zoom zoom...
337 elsif ($/ eq "\012") {
338
339 ### Seek ahead for "\n"... yes, this really is faster than regexps.
340 my $len = length($$sr);
341 for (; $i < $len; ++$i) {
342 last if ord (substr ($$sr, $i, 1)) == 10;
343 }
344
345 ### Extract the line:
346 my $line;
347 if ($i < $len) { ### We found a "\n":
348 $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
349 *$self->{Pos} = $i+1; ### Remember where we finished up.
350 }
351 else { ### No "\n"; slurp the remainder:
352 $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
353 *$self->{Pos} = $len;
354 }
355 return $line;
356 }
357
358 ### Case 3: $/ is ref to int. Do fixed-size records.
359 ### (Thanks to Dominique Quatravaux.)
360 elsif (ref($/)) {
361 my $len = length($$sr);
362 my $i = ${$/} + 0;
363 my $line = substr ($$sr, *$self->{Pos}, $i);
364 *$self->{Pos} += $i;
365 *$self->{Pos} = $len if (*$self->{Pos} > $len);
366 return $line;
367 }
368
369 ### Case 4: $/ is either "" (paragraphs) or something weird...
370 ### This is Graham's general-purpose stuff, which might be
371 ### a tad slower than Case 2 for typical data, because
372 ### of the regexps.
373 else {
374 pos($$sr) = $i;
375
376 ### If in paragraph mode, skip leading lines (and update i!):
377 length($/) or
378 (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
379
380 ### If we see the separator in the buffer ahead...
381 if (length($/)
382 ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
383 : $$sr =~ m,\n\n,g ### (a paragraph)
384 ) {
385 *$self->{Pos} = pos $$sr;
386 return substr($$sr, $i, *$self->{Pos}-$i);
387 }
388 ### Else if no separator remains, just slurp the rest:
389 else {
390 *$self->{Pos} = length $$sr;
391 return substr($$sr, $i);
392 }
393 }
394}
395
396#------------------------------
397
398=item getlines
399
400I<Instance method.>
401Get all remaining lines.
402It will croak() if accidentally called in a scalar context.
403
404=cut
405
406sub getlines {
407 my $self = shift;
408 wantarray or croak("can't call getlines in scalar context!");
409 my ($line, @lines);
410 push @lines, $line while (defined($line = $self->getline));
411 @lines;
412}
413
414#------------------------------
415
416=item print ARGS...
417
418I<Instance method.>
419Print ARGS to the underlying scalar.
420
421B<Warning:> this continues to always cause a seek to the end
422of the string, but if you perform seek()s and tell()s, it is
423still safer to explicitly seek-to-end before subsequent print()s.
424
425=cut
426
427sub print {
428 my $self = shift;
429 *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
430 1;
431}
432sub _unsafe_print {
433 my $self = shift;
434 my $append = join('', @_) . $\;
435 ${*$self->{SR}} .= $append;
436 *$self->{Pos} += length($append);
437 1;
438}
439sub _old_print {
440 my $self = shift;
441 ${*$self->{SR}} .= join('', @_) . $\;
442 *$self->{Pos} = length(${*$self->{SR}});
443 1;
444}
445
446
447#------------------------------
448
449=item read BUF, NBYTES, [OFFSET]
450
451I<Instance method.>
452Read some bytes from the scalar.
453Returns the number of bytes actually read, 0 on end-of-file, undef on error.
454
455=cut
456
457sub read {
458 my $self = $_[0];
459 my $n = $_[2];
460 my $off = $_[3] || 0;
461
462 my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
463 $n = length($read);
464 *$self->{Pos} += $n;
465 ($off ? substr($_[1], $off) : $_[1]) = $read;
466 return $n;
467}
468
469#------------------------------
470
471=item write BUF, NBYTES, [OFFSET]
472
473I<Instance method.>
474Write some bytes to the scalar.
475
476=cut
477
478sub write {
479 my $self = $_[0];
480 my $n = $_[2];
481 my $off = $_[3] || 0;
482
483 my $data = substr($_[1], $off, $n);
484 $n = length($data);
485 $self->print($data);
486 return $n;
487}
488
489#------------------------------
490
491=item sysread BUF, LEN, [OFFSET]
492
493I<Instance method.>
494Read some bytes from the scalar.
495Returns the number of bytes actually read, 0 on end-of-file, undef on error.
496
497=cut
498
499sub sysread {
500 my $self = shift;
501 $self->read(@_);
502}
503
504#------------------------------
505
506=item syswrite BUF, NBYTES, [OFFSET]
507
508I<Instance method.>
509Write some bytes to the scalar.
510
511=cut
512
513sub syswrite {
514 my $self = shift;
515 $self->write(@_);
516}
517
518=back
519
520=cut
521
522
523#==============================
524
525=head2 Seeking/telling and other attributes
526
527=over 4
528
529=cut
530
531
532#------------------------------
533
534=item autoflush
535
536I<Instance method.>
537No-op, provided for OO compatibility.
538
539=cut
540
541sub autoflush {}
542
543#------------------------------
544
545=item binmode
546
547I<Instance method.>
548No-op, provided for OO compatibility.
549
550=cut
551
552sub binmode {}
553
554#------------------------------
555
556=item clearerr
557
558I<Instance method.> Clear the error and EOF flags. A no-op.
559
560=cut
561
562sub clearerr { 1 }
563
564#------------------------------
565
566=item eof
567
568I<Instance method.> Are we at end of file?
569
570=cut
571
572sub eof {
573 my $self = shift;
574 (*$self->{Pos} >= length(${*$self->{SR}}));
575}
576
577#------------------------------
578
579=item seek OFFSET, WHENCE
580
581I<Instance method.> Seek to a given position in the stream.
582
583=cut
584
585sub seek {
586 my ($self, $pos, $whence) = @_;
587 my $eofpos = length(${*$self->{SR}});
588
589 ### Seek:
590 if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
591 elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
592 elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
593 else { croak "bad seek whence ($whence)" }
594
595 ### Fixup:
596 if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
597 if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
598 return 1;
599}
600
601#------------------------------
602
603=item sysseek OFFSET, WHENCE
604
605I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
606
607=cut
608
609sub sysseek {
610 my $self = shift;
611 $self->seek (@_);
612}
613
614#------------------------------
615
616=item tell
617
618I<Instance method.>
619Return the current position in the stream, as a numeric offset.
620
621=cut
622
623sub tell { *{shift()}->{Pos} }
624
625#------------------------------
626#
627# use_RS [YESNO]
628#
629# I<Instance method.>
630# Obey the current setting of $/, like IO::Handle does?
631# Default is false in 1.x, but cold-welded true in 2.x and later.
632#
633sub use_RS {
634 my ($self, $yesno) = @_;
635 carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
636 }
637
638#------------------------------
639
640=item setpos POS
641
642I<Instance method.>
643Set the current position, using the opaque value returned by C<getpos()>.
644
645=cut
646
647sub setpos { shift->seek($_[0],0) }
648
649#------------------------------
650
651=item getpos
652
653I<Instance method.>
654Return the current position in the string, as an opaque object.
655
656=cut
657
658*getpos = \&tell;
659
660
661#------------------------------
662
663=item sref
664
665I<Instance method.>
666Return a reference to the underlying scalar.
667
668=cut
669
670sub sref { *{shift()}->{SR} }
671
672
673#------------------------------
674# Tied handle methods...
675#------------------------------
676
677# Conventional tiehandle interface:
678sub TIEHANDLE {
679 ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
680 ? $_[1]
681 : shift->new(@_));
682}
683sub GETC { shift->getc(@_) }
684sub PRINT { shift->print(@_) }
685sub PRINTF { shift->print(sprintf(shift, @_)) }
686sub READ { shift->read(@_) }
687sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
688sub WRITE { shift->write(@_); }
689sub CLOSE { shift->close(@_); }
690sub SEEK { shift->seek(@_); }
691sub TELL { shift->tell(@_); }
692sub EOF { shift->eof(@_); }
693sub BINMODE { 1; }
694
695#------------------------------------------------------------
696
6971;
698
699__END__