1#line 1
2package IO::Scalar;
3
4
5#line 147
6
7use Carp;
8use strict;
9use vars qw($VERSION @ISA);
10use IO::Handle;
11
12use 5.005;
13
14### Stringification, courtesy of B. K. Oxley (binkley):  :-)
15use overload '""'   => sub { ${*{$_[0]}->{SR}} };
16use 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.
25require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
26
27#==============================
28
29#line 175
30
31#------------------------------
32
33#line 185
34
35sub 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}
43sub DESTROY {
44    shift->close;
45}
46
47#------------------------------
48
49#line 210
50
51sub 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
68sub opened {
69    *{shift()}->{SR};
70}
71
72#------------------------------
73
74#line 246
75
76sub 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
95sub flush { "0 but true" }
96
97#------------------------------
98
99#line 287
100
101sub 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
113sub 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        else {                          ### No "\n"; slurp the remainder:
149            $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
150            *$self->{Pos} = $len;
151        }
152        return $line;
153    }
154
155    ### Case 3: $/ is ref to int. Do fixed-size records.
156    ###        (Thanks to Dominique Quatravaux.)
157    elsif (ref($/)) {
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            *$self->{Pos} = length $$sr;
188            return substr($$sr, $i);
189        }
190    }
191}
192
193#------------------------------
194
195#line 396
196
197sub 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
209sub print {
210    my $self = shift;
211    *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
212    1;
213}
214sub _unsafe_print {
215    my $self = shift;
216    my $append = join('', @_) . $\;
217    ${*$self->{SR}} .= $append;
218    *$self->{Pos}   += length($append);
219    1;
220}
221sub _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
233sub read {
234    my $self = $_[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
249sub write {
250    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
264sub sysread {
265  my $self = shift;
266  $self->read(@_);
267}
268
269#------------------------------
270
271#line 503
272
273sub syswrite {
274  my $self = shift;
275  $self->write(@_);
276}
277
278#line 512
279
280
281#==============================
282
283#line 521
284
285
286#------------------------------
287
288#line 531
289
290sub autoflush {}
291
292#------------------------------
293
294#line 542
295
296sub binmode {}
297
298#------------------------------
299
300#line 552
301
302sub clearerr { 1 }
303
304#------------------------------
305
306#line 562
307
308sub eof {
309    my $self = shift;
310    (*$self->{Pos} >= length(${*$self->{SR}}));
311}
312
313#------------------------------
314
315#line 575
316
317sub seek {
318    my ($self, $pos, $whence) = @_;
319    my $eofpos = length(${*$self->{SR}});
320
321    ### Seek:
322    if    ($whence == 0) { *$self->{Pos} = $pos }             ### SEEK_SET
323    elsif ($whence == 1) { *$self->{Pos} += $pos }            ### SEEK_CUR
324    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}
332
333#------------------------------
334
335#line 599
336
337sub sysseek {
338    my $self = shift;
339    $self->seek (@_);
340}
341
342#------------------------------
343
344#line 613
345
346sub tell { *{shift()}->{Pos} }
347
348#------------------------------
349#
350# use_RS [YESNO]
351#
352# I<Instance method.>
353# Obey the curent setting of $/, like IO::Handle does?
354# Default is false in 1.x, but cold-welded true in 2.x and later.
355#
356sub use_RS {
357    my ($self, $yesno) = @_;
358    carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
359 }
360
361#------------------------------
362
363#line 637
364
365sub setpos { shift->seek($_[0],0) }
366
367#------------------------------
368
369#line 648
370
371*getpos = \&tell;
372
373
374#------------------------------
375
376#line 660
377
378sub sref { *{shift()}->{SR} }
379
380
381#------------------------------
382# Tied handle methods...
383#------------------------------
384
385# Conventional tiehandle interface:
386sub TIEHANDLE {
387    ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar"))
388     ? $_[1]
389     : shift->new(@_));
390}
391sub GETC      { shift->getc(@_) }
392sub PRINT     { shift->print(@_) }
393sub PRINTF    { shift->print(sprintf(shift, @_)) }
394sub READ      { shift->read(@_) }
395sub READLINE  { wantarray ? shift->getlines(@_) : shift->getline(@_) }
396sub WRITE     { shift->write(@_); }
397sub CLOSE     { shift->close(@_); }
398sub SEEK      { shift->seek(@_); }
399sub TELL      { shift->tell(@_); }
400sub EOF       { shift->eof(@_); }
401
402#------------------------------------------------------------
403
4041;
405
406__END__
407
408
409
410#line 696
411
412
413#line 777
414
415