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