File Coverage

inc/IO/Scalar.pm
Criterion Covered Total %
statement 44 160 27.5
branch 5 46 10.8
condition 3 13 23.0
subroutine 14 46 30.4
pod 22 23 95.6
total 88 288 30.5


line stmt bran cond sub pod time code
1             #line 1
2             package IO::Scalar;
3              
4              
5             #line 147
6              
7             use Carp;
8             use strict;
9             use vars qw($VERSION @ISA);
10             use IO::Handle;
11              
12             use 5.005;
13              
14             ### Stringification, courtesy of B. K. Oxley (binkley): :-)
15             use overload '""' => sub { ${*{$_[0]}->{SR}} };
16             use overload 'bool' => sub { 1 }; ### have to do this, so object is true!
17              
18             ### The package version, both in 1.23 style *and* usable by MakeMaker:
19             $VERSION = "2.110";
20              
21             ### Inheritance:
22             @ISA = qw(IO::Handle);
23              
24             ### This stuff should be got rid of ASAP.
25             require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
26              
27             #==============================
28              
29             #line 175
30              
31             #------------------------------
32              
33             #line 185
34              
35             sub new {
36             my $proto = shift;
37             my $class = ref($proto) || $proto;
38             my $self = bless \do { local *FH }, $class;
39             tie *$self, $class, $self;
40             $self->open(@_); ### open on anonymous by default
41             $self;
42             }
43             sub DESTROY {
44             shift->close;
45             }
46              
47             #------------------------------
48              
49             #line 210
50              
51             sub open {
52             my ($self, $sref) = @_;
53              
54             ### Sanity:
55             defined($sref) or do {my $s = ''; $sref = \$s};
56             (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
57              
58             ### Setup:
59             *$self->{Pos} = 0; ### seek position
60             *$self->{SR} = $sref; ### scalar reference
61             $self;
62             }
63              
64             #------------------------------
65              
66             #line 232
67              
68             sub opened {
69             *{shift()}->{SR};
70             }
71              
72             #------------------------------
73              
74             #line 246
75              
76             sub close {
77             my $self = shift;
78             %{*$self} = ();
79             1;
80             }
81              
82             #line 256
83              
84              
85              
86             #==============================
87              
88             #line 266
89              
90              
91             #------------------------------
92              
93             #line 276
94              
95             sub flush { "0 but true" }
96              
97             #------------------------------
98              
99             #line 287
100              
101             sub getc {
102             my $self = shift;
103              
104             ### Return undef right away if at EOF; else, move pos forward:
105             return undef if $self->eof;
106             substr(${*$self->{SR}}, *$self->{Pos}++, 1);
107             }
108              
109             #------------------------------
110              
111             #line 306
112              
113             sub getline {
114             my $self = shift;
115              
116             ### Return undef right away if at EOF:
117             return undef if $self->eof;
118              
119             ### Get next line:
120             my $sr = *$self->{SR};
121             my $i = *$self->{Pos}; ### Start matching at this point.
122              
123             ### Minimal impact implementation!
124             ### We do the fast fast thing (no regexps) if using the
125             ### classic input record separator.
126              
127             ### Case 1: $/ is undef: slurp all...
128             if (!defined($/)) {
129             *$self->{Pos} = length $$sr;
130             return substr($$sr, $i);
131             }
132              
133             ### Case 2: $/ is "\n": zoom zoom zoom...
134             elsif ($/ eq "\012") {
135              
136             ### Seek ahead for "\n"... yes, this really is faster than regexps.
137             my $len = length($$sr);
138             for (; $i < $len; ++$i) {
139             last if ord (substr ($$sr, $i, 1)) == 10;
140             }
141              
142             ### Extract the line:
143             my $line;
144             if ($i < $len) { ### We found a "\n":
145             $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
146             *$self->{Pos} = $i+1; ### Remember where we finished up.
147             }
148 5     5   2063 else { ### No "\n"; slurp the remainder:
  5         6  
  5         529  
149 5     5   24 $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
  5         6  
  5         129  
150 5     5   21 *$self->{Pos} = $len;
  5         4  
  5         250  
151 5     5   3168 }
  5         24921  
  5         226  
152             return $line;
153 5     5   111 }
  5         12  
154              
155             ### Case 3: $/ is ref to int. Do fixed-size records.
156 5     5   4806 ### (Thanks to Dominique Quatravaux.)
  5     0   3819  
  5         56  
  0         0  
  0         0  
  0         0  
157 5     5   285 elsif (ref($/)) {
  5     0   7  
  5         18  
  0         0  
158             my $len = length($$sr);
159             my $i = ${$/} + 0;
160             my $line = substr ($$sr, *$self->{Pos}, $i);
161             *$self->{Pos} += $i;
162             *$self->{Pos} = $len if (*$self->{Pos} > $len);
163             return $line;
164             }
165              
166             ### Case 4: $/ is either "" (paragraphs) or something weird...
167             ### This is Graham's general-purpose stuff, which might be
168             ### a tad slower than Case 2 for typical data, because
169             ### of the regexps.
170             else {
171             pos($$sr) = $i;
172              
173             ### If in paragraph mode, skip leading lines (and update i!):
174             length($/) or
175             (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
176              
177             ### If we see the separator in the buffer ahead...
178             if (length($/)
179             ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
180             : $$sr =~ m,\n\n,g ### (a paragraph)
181             ) {
182             *$self->{Pos} = pos $$sr;
183             return substr($$sr, $i, *$self->{Pos}-$i);
184             }
185             ### Else if no separator remains, just slurp the rest:
186             else {
187 16     16 1 23 *$self->{Pos} = length $$sr;
188 16   33     59 return substr($$sr, $i);
189 16         20 }
  16         71  
190 16         436 }
191 16         51 }
192 16         70  
193             #------------------------------
194              
195 11     11   36 #line 396
196              
197             sub getlines {
198             my $self = shift;
199             wantarray or croak("can't call getlines in scalar context!");
200             my ($line, @lines);
201             push @lines, $line while (defined($line = $self->getline));
202             @lines;
203             }
204              
205             #------------------------------
206              
207             #line 417
208              
209             sub print {
210             my $self = shift;
211             *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
212 16     16 1 141 1;
213             }
214             sub _unsafe_print {
215 16 50       39 my $self = shift;
  0         0  
  0         0  
216 16 50       42 my $append = join('', @_) . $\;
217             ${*$self->{SR}} .= $append;
218             *$self->{Pos} += length($append);
219 16         45 1;
220 16         31 }
221 16         22 sub _old_print {
222             my $self = shift;
223             ${*$self->{SR}} .= join('', @_) . $\;
224             *$self->{Pos} = length(${*$self->{SR}});
225             1;
226             }
227              
228              
229             #------------------------------
230              
231             #line 447
232              
233             sub read {
234 0     0 1 0 my $self = $_[0];
  0         0  
235             my $n = $_[2];
236             my $off = $_[3] || 0;
237              
238             my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
239             $n = length($read);
240             *$self->{Pos} += $n;
241             ($off ? substr($_[1], $off) : $_[1]) = $read;
242             return $n;
243             }
244              
245             #------------------------------
246              
247             #line 468
248 11     11 1 14  
249 11         22 sub write {
  11         31  
250 11         48 my $self = $_[0];
251             my $n = $_[2];
252             my $off = $_[3] || 0;
253              
254             my $data = substr($_[1], $off, $n);
255             $n = length($data);
256             $self->print($data);
257             return $n;
258             }
259              
260             #------------------------------
261              
262             #line 489
263              
264             sub sysread {
265             my $self = shift;
266             $self->read(@_);
267             }
268              
269             #------------------------------
270              
271             #line 503
272              
273             sub syswrite {
274             my $self = shift;
275             $self->write(@_);
276             }
277 0     0 1 0  
278             #line 512
279              
280              
281             #==============================
282              
283             #line 521
284              
285              
286             #------------------------------
287              
288             #line 531
289 0     0 1 0  
290             sub autoflush {}
291              
292 0 0       0 #------------------------------
293 0         0  
  0         0  
294             #line 542
295              
296             sub binmode {}
297              
298             #------------------------------
299              
300             #line 552
301              
302             sub clearerr { 1 }
303              
304             #------------------------------
305              
306             #line 562
307              
308 0     0 1 0 sub eof {
309             my $self = shift;
310             (*$self->{Pos} >= length(${*$self->{SR}}));
311 0 0       0 }
312              
313             #------------------------------
314 0         0  
315 0         0 #line 575
316              
317             sub seek {
318             my ($self, $pos, $whence) = @_;
319             my $eofpos = length(${*$self->{SR}});
320              
321             ### Seek:
322 0 0       0 if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
    0          
    0          
323 0         0 elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
324 0         0 elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
325             else { croak "bad seek whence ($whence)" }
326              
327             ### Fixup:
328             if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
329             if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
330             return 1;
331 0         0 }
332 0         0  
333 0 0       0 #------------------------------
334              
335             #line 599
336              
337 0         0 sub sysseek {
338 0 0       0 my $self = shift;
339 0         0 $self->seek (@_);
340 0         0 }
341              
342             #------------------------------
343 0         0  
344 0         0 #line 613
345              
346 0         0 sub tell { *{shift()}->{Pos} }
347              
348             #------------------------------
349             #
350             # use_RS [YESNO]
351             #
352 0         0 # I
353 0         0 # Obey the curent setting of $/, like IO::Handle does?
  0         0  
354 0         0 # Default is false in 1.x, but cold-welded true in 2.x and later.
355 0         0 #
356 0 0       0 sub use_RS {
357 0         0 my ($self, $yesno) = @_;
358             carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
359             }
360              
361             #------------------------------
362              
363             #line 637
364              
365 0         0 sub setpos { shift->seek($_[0],0) }
366              
367             #------------------------------
368 0 0 0     0  
369             #line 648
370              
371             *getpos = \&tell;
372 0 0       0  
    0          
373              
374             #------------------------------
375              
376 0         0 #line 660
377 0         0  
378             sub sref { *{shift()}->{SR} }
379              
380              
381 0         0 #------------------------------
382 0         0 # Tied handle methods...
383             #------------------------------
384              
385             # Conventional tiehandle interface:
386             sub TIEHANDLE {
387             ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
388             ? $_[1]
389             : shift->new(@_));
390             }
391             sub GETC { shift->getc(@_) }
392             sub PRINT { shift->print(@_) }
393             sub PRINTF { shift->print(sprintf(shift, @_)) }
394             sub READ { shift->read(@_) }
395             sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
396             sub WRITE { shift->write(@_); }
397             sub CLOSE { shift->close(@_); }
398 0     0 1 0 sub SEEK { shift->seek(@_); }
399 0 0       0 sub TELL { shift->tell(@_); }
400 0         0 sub EOF { shift->eof(@_); }
401 0         0  
402 0         0 #------------------------------------------------------------
403              
404             1;
405              
406             __END__