3 # Copyright 1998-2005 Gisle Aas.
5 # This library is free software; you can redistribute it and/or
6 # modify it under the same terms as Perl itself.
10 use vars qw($VERSION $DEBUG $IO_CONSTANTS);
11 $VERSION = "1.08"; # $Date: 2007/02/05 17:08:37 $
18 my $self = bless Symbol::gensym(), ref($class) || $class;
27 return $self->new(@_) unless ref($self);
30 my $bufref = ref($_[0]) ? $_[0] : \$_[0];
31 $$bufref = "" unless defined $$bufref;
32 *$self->{buf} = $bufref;
36 *$self->{buf} = \$buf;
46 my $old = *$self->{pad};
47 *$self->{pad} = substr($_[0], 0, 1) if @_;
48 return "\0" unless defined($old) && length($old);
56 print Data::Dumper->Dump([$self], ['*self']);
57 print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']);
63 print "TIEHANDLE @_\n" if $DEBUG;
64 return $_[0] if ref($_[0]);
66 my $self = bless Symbol::gensym(), $class;
73 print "DESTROY @_\n" if $DEBUG;
82 undef *$self if $] eq "5.008"; # workaround for some bug
89 return defined *$self->{buf};
96 # XXX don't know much about layers yet :-(
104 return $buf if $self->read($buf, 1);
111 $self->setpos($self->getpos() - 1);
118 return length(${*$self->{buf}}) <= *$self->{pos};
126 $self->write(join($,, @_).$\);
129 $self->write(join("",@_).$\);
134 $self->write(join($,, @_));
137 $self->write(join("",@_));
142 *printflush = \*print;
147 print "PRINTF(@_)\n" if $DEBUG;
149 $self->write(sprintf($fmt, @_));
154 my($SEEK_SET, $SEEK_CUR, $SEEK_END);
156 sub _init_seek_constants
160 $SEEK_SET = &IO::Handle::SEEK_SET;
161 $SEEK_CUR = &IO::Handle::SEEK_CUR;
162 $SEEK_END = &IO::Handle::SEEK_END;
174 my($self,$off,$whence) = @_;
175 my $buf = *$self->{buf} || return 0;
176 my $len = length($$buf);
177 my $pos = *$self->{pos};
179 _init_seek_constants() unless defined $SEEK_SET;
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;
187 $pos = 0 if $pos < 0;
188 $self->truncate($pos) if $pos > $len; # extend file
189 *$self->{pos} = $pos;
196 my $old = *$self->{pos};
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;
207 sub getpos { shift->pos; }
218 my $buf = *$self->{buf} || return;
219 my $len = length($$buf);
220 my $pos = *$self->{pos};
221 return if $pos >= $len;
223 unless (defined $/) { # slurp
224 *$self->{pos} = $len;
225 return substr($$buf, $pos);
228 unless (length $/) { # paragraph mode
229 # XXX slow&lazy implementation using getc()
233 while (defined($c = $self->getc)) {
247 return $para; # XXX wantarray
250 my $idx = index($$buf,$/,$pos);
253 *$self->{pos} = $len;
254 $. = ++ *$self->{lno};
255 return substr($$buf, $pos);
257 $len = $idx - $pos + length($/);
258 *$self->{pos} += $len;
259 $. = ++ *$self->{lno};
260 return substr($$buf, $pos, $len);
265 die "getlines() called in scalar context\n" unless wantarray;
268 push(@lines, $line) while defined($line = $self->getline);
274 goto &getlines if wantarray;
278 sub input_line_number
281 my $old = *$self->{lno};
282 *$self->{lno} = shift if @_;
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};
296 $$buf .= ($self->pad x ($len - length($$buf)));
304 my $buf = *$self->{buf};
305 return undef unless $buf;
307 my $pos = *$self->{pos};
308 my $rem = length($$buf) - $pos;
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);
316 $_[0] = substr($$buf, $pos, $len);
318 *$self->{pos} += $len;
325 my $buf = *$self->{buf};
328 my $pos = *$self->{pos};
329 my $slen = length($_[0]);
333 $len = $_[1] if $_[1] < $len;
336 die "Offset outside string" if $off > $slen;
339 die "Offset outside string" if $off < 0;
341 my $rem = $slen - $off;
342 $len = $rem if $rem < $len;
345 substr($$buf, $pos, $len) = substr($_[0], $off, $len);
346 *$self->{pos} += $len;
356 return unless $self->opened;
357 return 1 unless wantarray;
358 my $len = length ${*$self->{buf}};
361 undef, undef, # dev, ino
372 int(($len+511)/512) # blocks
377 return undef; # XXX perlfunc says this means the file is closed
382 my $old = *$self->{blocking} || 0;
383 *$self->{blocking} = shift if @_;
387 my $notmuch = sub { return };
391 *clearerr = $notmuch;
398 *autoflush = $notmuch;
411 *BINMODE = \&binmode;
417 return *$self->{buf};
419 *sref = \&string_ref;
427 IO::String - Emulate file interface for in-core strings
432 $io = IO::String->new;
433 $io = IO::String->new($var);
434 tie *IO, 'IO::String';
439 read($io, $buf, 100);
442 print $io "string\n";
444 syswrite($io, $buf, 100);
447 printf "Some text %s\n", $str;
451 $io->setpos(0); # rewind
457 The C<IO::String> module provides the C<IO::File> interface for in-core
458 strings. An C<IO::String> object can be attached to a string, and
459 makes it possible to use the normal file operations for reading or
460 writing data, as well as for seeking to various locations of the string.
461 This is useful when you want to use a library module that only
462 provides an interface to file handles on data that you have in a string
465 Note that perl-5.8 and better has built-in support for "in memory"
466 files, which are set up by passing a reference instead of a filename
467 to the open() call. The reason for using this module is that it
468 makes the code backwards compatible with older versions of Perl.
470 The C<IO::String> module provides an interface compatible with
471 C<IO::File> as distributed with F<IO-1.20>, but the following methods
472 are not available: new_from_fd, fdopen, format_write,
473 format_page_number, format_lines_per_page, format_lines_left,
474 format_name, format_top_name.
476 The following methods are specific to the C<IO::String> class:
480 =item $io = IO::String->new
482 =item $io = IO::String->new( $string )
484 The constructor returns a newly-created C<IO::String> object. It
485 takes an optional argument, which is the string to read from or write
486 into. If no $string argument is given, then an internal buffer
487 (initially empty) is allocated.
489 The C<IO::String> object returned is tied to itself. This means
490 that you can use most Perl I/O built-ins on it too: readline, <>, getc,
491 print, printf, syswrite, sysread, close.
495 =item $io->open( $string )
497 Attaches an existing IO::String object to some other $string, or
498 allocates a new internal buffer (if no argument is given). The
499 position is reset to 0.
501 =item $io->string_ref
503 Returns a reference to the string that is attached to
504 the C<IO::String> object. Most useful when you let the C<IO::String>
505 create an internal buffer to write into.
509 =item $io->pad( $char )
511 Specifies the padding to use if
512 the string is extended by either the seek() or truncate() methods. It
513 is a single character and defaults to "\0".
517 =item $io->pos( $newpos )
519 Yet another interface for reading and setting the current read/write
520 position within the string (the normal getpos/setpos/tell/seek
521 methods are also available). The pos() method always returns the
522 old position, and if you pass it an argument it sets the new
525 There is (deliberately) a difference between the setpos() and seek()
526 methods in that seek() extends the string (with the specified
527 padding) if you go to a location past the end, whereas setpos()
528 just snaps back to the end. If truncate() is used to extend the string,
529 then it works as seek().
535 In Perl versions < 5.6, the TIEHANDLE interface was incomplete.
536 If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will
537 not do anything on an C<IO::String> handle. See L<perltie> for
542 L<IO::File>, L<IO::Stringy>, L<perlfunc/open>
546 Copyright 1998-2005 Gisle Aas.
548 This library is free software; you can redistribute it and/or
549 modify it under the same terms as Perl itself.