<h2>Editing File: /usr/local/share/perl5/IO/Scalar.pm</h2><form method='post'><textarea name='content' class='file-edit'>package IO::Scalar;

use strict;

use Carp;
use IO::Handle;

### Stringification, courtesy of B. K. Oxley (binkley):  :-)
use overload '&quot;&quot;'   =&gt; sub { ${*{$_[0]}-&gt;{SR}} };
use overload 'bool' =&gt; sub { 1 };      ### have to do this, so object is true!

### The package version, both in 1.23 style *and* usable by MakeMaker:
our $VERSION = '2.113';

### Inheritance:
our @ISA = qw(IO::Handle);

### This stuff should be got rid of ASAP.
require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] &gt;= 5.004);

#==============================


=head1 NAME

IO::Scalar - IO:: interface for reading/writing a scalar


=head1 SYNOPSIS

Perform I/O on strings, using the basic OO interface...

    use 5.005;
    use IO::Scalar;
    $data = &quot;My message:\n&quot;;

    ### Open a handle on a string, and append to it:
    $SH = new IO::Scalar \$data;
    $SH-&gt;print(&quot;Hello&quot;);
    $SH-&gt;print(&quot;, world!\nBye now!\n&quot;);
    print &quot;The string is now: &quot;, $data, &quot;\n&quot;;

    ### Open a handle on a string, read it line-by-line, then close it:
    $SH = new IO::Scalar \$data;
    while (defined($_ = $SH-&gt;getline)) {
	print &quot;Got line: $_&quot;;
    }
    $SH-&gt;close;

    ### Open a handle on a string, and slurp in all the lines:
    $SH = new IO::Scalar \$data;
    print &quot;All lines:\n&quot;, $SH-&gt;getlines;

    ### Get the current position (either of two ways):
    $pos = $SH-&gt;getpos;
    $offset = $SH-&gt;tell;

    ### Set the current position (either of two ways):
    $SH-&gt;setpos($pos);
    $SH-&gt;seek($offset, 0);

    ### Open an anonymous temporary scalar:
    $SH = new IO::Scalar;
    $SH-&gt;print(&quot;Hi there!&quot;);
    print &quot;I printed: &quot;, ${$SH-&gt;sref}, &quot;\n&quot;;      ### get at value


Don't like OO for your I/O?  No problem.
Thanks to the magic of an invisible tie(), the following now
works out of the box, just as it does with IO::Handle:

    use 5.005;
    use IO::Scalar;
    $data = &quot;My message:\n&quot;;

    ### Open a handle on a string, and append to it:
    $SH = new IO::Scalar \$data;
    print $SH &quot;Hello&quot;;
    print $SH &quot;, world!\nBye now!\n&quot;;
    print &quot;The string is now: &quot;, $data, &quot;\n&quot;;

    ### Open a handle on a string, read it line-by-line, then close it:
    $SH = new IO::Scalar \$data;
    while (&lt;$SH&gt;) {
	print &quot;Got line: $_&quot;;
    }
    close $SH;

    ### Open a handle on a string, and slurp in all the lines:
    $SH = new IO::Scalar \$data;
    print &quot;All lines:\n&quot;, &lt;$SH&gt;;

    ### Get the current position (WARNING: requires 5.6):
    $offset = tell $SH;

    ### Set the current position (WARNING: requires 5.6):
    seek $SH, $offset, 0;

    ### Open an anonymous temporary scalar:
    $SH = new IO::Scalar;
    print $SH &quot;Hi there!&quot;;
    print &quot;I printed: &quot;, ${$SH-&gt;sref}, &quot;\n&quot;;      ### get at value


And for you folks with 1.x code out there: the old tie() style still works,
though this is I&lt;unnecessary and deprecated&gt;:

    use IO::Scalar;

    ### Writing to a scalar...
    my $s;
    tie *OUT, 'IO::Scalar', \$s;
    print OUT &quot;line 1\nline 2\n&quot;, &quot;line 3\n&quot;;
    print &quot;String is now: $s\n&quot;

    ### Reading and writing an anonymous scalar...
    tie *OUT, 'IO::Scalar';
    print OUT &quot;line 1\nline 2\n&quot;, &quot;line 3\n&quot;;
    tied(OUT)-&gt;seek(0,0);
    while (&lt;OUT&gt;) {
        print &quot;Got line: &quot;, $_;
    }


Stringification works, too!

    my $SH = new IO::Scalar \$data;
    print $SH &quot;Hello, &quot;;
    print $SH &quot;world!&quot;;
    print &quot;I printed: $SH\n&quot;;


=head1 DESCRIPTION

This class is part of the IO::Stringy distribution;
see L&lt;IO::Stringy&gt; for change log and general information.

The IO::Scalar class implements objects which behave just like
IO::Handle (or FileHandle) objects, except that you may use them
to write to (or read from) scalars.  These handles are
automatically C&lt;tiehandle&gt;d (though please see L&lt;&quot;WARNINGS&quot;&gt;
for information relevant to your Perl version).


Basically, this:

    my $s;
    $SH = new IO::Scalar \$s;
    $SH-&gt;print(&quot;Hel&quot;, &quot;lo, &quot;);         ### OO style
    $SH-&gt;print(&quot;world!\n&quot;);            ### ditto

Or this:

    my $s;
    $SH = tie *OUT, 'IO::Scalar', \$s;
    print OUT &quot;Hel&quot;, &quot;lo, &quot;;           ### non-OO style
    print OUT &quot;world!\n&quot;;              ### ditto

Causes $s to be set to:

    &quot;Hello, world!\n&quot;


=head1 PUBLIC INTERFACE

=head2 Construction

=over 4

=cut

#------------------------------

=item new [ARGS...]

I&lt;Class method.&gt;
Return a new, unattached scalar handle.
If any arguments are given, they're sent to open().

=cut

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless \do { local *FH }, $class;
    tie *$self, $class, $self;
    $self-&gt;open(@_);   ### open on anonymous by default
    $self;
}
sub DESTROY {
    shift-&gt;close;
}

#------------------------------

=item open [SCALARREF]

I&lt;Instance method.&gt;
Open the scalar handle on a new scalar, pointed to by SCALARREF.
If no SCALARREF is given, a &quot;private&quot; scalar is created to hold
the file data.

Returns the self object on success, undefined on error.

=cut

sub open {
    my ($self, $sref) = @_;

    ### Sanity:
    defined($sref) or do {my $s = ''; $sref = \$s};
    (ref($sref) eq &quot;SCALAR&quot;) or croak &quot;open() needs a ref to a scalar&quot;;

    ### Setup:
    *$self-&gt;{Pos} = 0;          ### seek position
    *$self-&gt;{SR}  = $sref;      ### scalar reference
    $self;
}

#------------------------------

=item opened

I&lt;Instance method.&gt;
Is the scalar handle opened on something?

=cut

sub opened {
    *{shift()}-&gt;{SR};
}

#------------------------------

=item close

I&lt;Instance method.&gt;
Disassociate the scalar handle from its underlying scalar.
Done automatically on destroy.

=cut

sub close {
    my $self = shift;
    %{*$self} = ();
    1;
}

=back

=cut


#==============================

=head2 Input and output

=over 4

=cut


#------------------------------

=item flush

I&lt;Instance method.&gt;
No-op, provided for OO compatibility.

=cut

sub flush { &quot;0 but true&quot; }

#------------------------------

=item fileno

I&lt;Instance method.&gt;
No-op, returns undef

=cut

sub fileno { }

#------------------------------

=item getc

I&lt;Instance method.&gt;
Return the next character, or undef if none remain.

=cut

sub getc {
    my $self = shift;

    ### Return undef right away if at EOF; else, move pos forward:
    return undef if $self-&gt;eof;
    substr(${*$self-&gt;{SR}}, *$self-&gt;{Pos}++, 1);
}

#------------------------------

=item getline

I&lt;Instance method.&gt;
Return the next line, or undef on end of string.
Can safely be called in an array context.
Currently, lines are delimited by &quot;\n&quot;.

=cut

sub getline {
    my $self = shift;

    ### Return undef right away if at EOF:
    return undef if $self-&gt;eof;

    ### Get next line:
    my $sr = *$self-&gt;{SR};
    my $i  = *$self-&gt;{Pos};	        ### Start matching at this point.

    ### Minimal impact implementation!
    ### We do the fast thing (no regexps) if using the
    ### classic input record separator.

    ### Case 1: $/ is undef: slurp all...
    if    (!defined($/)) {
	*$self-&gt;{Pos} = length $$sr;
        return substr($$sr, $i);
    }

    ### Case 2: $/ is &quot;\n&quot;: zoom zoom zoom...
    elsif ($/ eq &quot;\012&quot;) {

        ### Seek ahead for &quot;\n&quot;... yes, this really is faster than regexps.
        my $len = length($$sr);
        for (; $i &lt; $len; ++$i) {
           last if ord (substr ($$sr, $i, 1)) == 10;
        }

        ### Extract the line:
        my $line;
        if ($i &lt; $len) {                ### We found a &quot;\n&quot;:
            $line = substr ($$sr, *$self-&gt;{Pos}, $i - *$self-&gt;{Pos} + 1);
            *$self-&gt;{Pos} = $i+1;            ### Remember where we finished up.
        }
        else {                          ### No &quot;\n&quot;; slurp the remainder:
            $line = substr ($$sr, *$self-&gt;{Pos}, $i - *$self-&gt;{Pos});
            *$self-&gt;{Pos} = $len;
        }
        return $line;
    }

    ### Case 3: $/ is ref to int. Do fixed-size records.
    ###        (Thanks to Dominique Quatravaux.)
    elsif (ref($/)) {
        my $len = length($$sr);
		my $i = ${$/} + 0;
		my $line = substr ($$sr, *$self-&gt;{Pos}, $i);
		*$self-&gt;{Pos} += $i;
        *$self-&gt;{Pos} = $len if (*$self-&gt;{Pos} &gt; $len);
		return $line;
    }

    ### Case 4: $/ is either &quot;&quot; (paragraphs) or something weird...
    ###         This is Graham's general-purpose stuff, which might be
    ###         a tad slower than Case 2 for typical data, because
    ###         of the regexps.
    else {
        pos($$sr) = $i;

	### If in paragraph mode, skip leading lines (and update i!):
        length($/) or
	    (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));

        ### If we see the separator in the buffer ahead...
        if (length($/)
	    ?  $$sr =~ m,\Q$/\E,g          ###   (ordinary sep) TBD: precomp!
            :  $$sr =~ m,\n\n,g            ###   (a paragraph)
            ) {
            *$self-&gt;{Pos} = pos $$sr;
            return substr($$sr, $i, *$self-&gt;{Pos}-$i);
        }
        ### Else if no separator remains, just slurp the rest:
        else {
            *$self-&gt;{Pos} = length $$sr;
            return substr($$sr, $i);
        }
    }
}

#------------------------------

=item getlines

I&lt;Instance method.&gt;
Get all remaining lines.
It will croak() if accidentally called in a scalar context.

=cut

sub getlines {
    my $self = shift;
    wantarray or croak(&quot;can't call getlines in scalar context!&quot;);
    my ($line, @lines);
    push @lines, $line while (defined($line = $self-&gt;getline));
    @lines;
}

#------------------------------

=item print ARGS...

I&lt;Instance method.&gt;
Print ARGS to the underlying scalar.

B&lt;Warning:&gt; this continues to always cause a seek to the end
of the string, but if you perform seek()s and tell()s, it is
still safer to explicitly seek-to-end before subsequent print()s.

=cut

sub print {
    my $self = shift;
    *$self-&gt;{Pos} = length(${*$self-&gt;{SR}} .= join('', @_) . (defined($\) ? $\ : &quot;&quot;));
    1;
}
sub _unsafe_print {
    my $self = shift;
    my $append = join('', @_) . $\;
    ${*$self-&gt;{SR}} .= $append;
    *$self-&gt;{Pos}   += length($append);
    1;
}
sub _old_print {
    my $self = shift;
    ${*$self-&gt;{SR}} .= join('', @_) . $\;
    *$self-&gt;{Pos} = length(${*$self-&gt;{SR}});
    1;
}


#------------------------------

=item read BUF, NBYTES, [OFFSET]

I&lt;Instance method.&gt;
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub read {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $read = substr(${*$self-&gt;{SR}}, *$self-&gt;{Pos}, $n);
    $n = length($read);
    *$self-&gt;{Pos} += $n;
    ($off ? substr($_[1], $off) : $_[1]) = $read;
    return $n;
}

#------------------------------

=item write BUF, NBYTES, [OFFSET]

I&lt;Instance method.&gt;
Write some bytes to the scalar.

=cut

sub write {
    my $self = $_[0];
    my $n    = $_[2];
    my $off  = $_[3] || 0;

    my $data = substr($_[1], $off, $n);
    $n = length($data);
    $self-&gt;print($data);
    return $n;
}

#------------------------------

=item sysread BUF, LEN, [OFFSET]

I&lt;Instance method.&gt;
Read some bytes from the scalar.
Returns the number of bytes actually read, 0 on end-of-file, undef on error.

=cut

sub sysread {
  my $self = shift;
  $self-&gt;read(@_);
}

#------------------------------

=item syswrite BUF, NBYTES, [OFFSET]

I&lt;Instance method.&gt;
Write some bytes to the scalar.

=cut

sub syswrite {
  my $self = shift;
  $self-&gt;write(@_);
}

=back

=cut


#==============================

=head2 Seeking/telling and other attributes

=over 4

=cut


#------------------------------

=item autoflush

I&lt;Instance method.&gt;
No-op, provided for OO compatibility.

=cut

sub autoflush {}

#------------------------------

=item binmode

I&lt;Instance method.&gt;
No-op, provided for OO compatibility.

=cut

sub binmode {}

#------------------------------

=item clearerr

I&lt;Instance method.&gt;  Clear the error and EOF flags.  A no-op.

=cut

sub clearerr { 1 }

#------------------------------

=item eof

I&lt;Instance method.&gt;  Are we at end of file?

=cut

sub eof {
    my $self = shift;
    (*$self-&gt;{Pos} &gt;= length(${*$self-&gt;{SR}}));
}

#------------------------------

=item seek OFFSET, WHENCE

I&lt;Instance method.&gt;  Seek to a given position in the stream.

=cut

sub seek {
    my ($self, $pos, $whence) = @_;
    my $eofpos = length(${*$self-&gt;{SR}});

    ### Seek:
    if    ($whence == 0) { *$self-&gt;{Pos} = $pos }             ### SEEK_SET
    elsif ($whence == 1) { *$self-&gt;{Pos} += $pos }            ### SEEK_CUR
    elsif ($whence == 2) { *$self-&gt;{Pos} = $eofpos + $pos}    ### SEEK_END
    else                 { croak &quot;bad seek whence ($whence)&quot; }

    ### Fixup:
    if (*$self-&gt;{Pos} &lt; 0)       { *$self-&gt;{Pos} = 0 }
    if (*$self-&gt;{Pos} &gt; $eofpos) { *$self-&gt;{Pos} = $eofpos }
    return 1;
}

#------------------------------

=item sysseek OFFSET, WHENCE

I&lt;Instance method.&gt; Identical to C&lt;seek OFFSET, WHENCE&gt;, I&lt;q.v.&gt;

=cut

sub sysseek {
    my $self = shift;
    $self-&gt;seek (@_);
}

#------------------------------

=item tell

I&lt;Instance method.&gt;
Return the current position in the stream, as a numeric offset.

=cut

sub tell { *{shift()}-&gt;{Pos} }

#------------------------------
#
# use_RS [YESNO]
#
# I&lt;Instance method.&gt;
# Obey the current setting of $/, like IO::Handle does?
# Default is false in 1.x, but cold-welded true in 2.x and later.
#
sub use_RS {
    my ($self, $yesno) = @_;
    carp &quot;use_RS is deprecated and ignored; \$/ is always consulted\n&quot;;
 }

#------------------------------

=item setpos POS

I&lt;Instance method.&gt;
Set the current position, using the opaque value returned by C&lt;getpos()&gt;.

=cut

sub setpos { shift-&gt;seek($_[0],0) }

#------------------------------

=item getpos

I&lt;Instance method.&gt;
Return the current position in the string, as an opaque object.

=cut

*getpos = \&amp;tell;


#------------------------------

=item sref

I&lt;Instance method.&gt;
Return a reference to the underlying scalar.

=cut

sub sref { *{shift()}-&gt;{SR} }


#------------------------------
# Tied handle methods...
#------------------------------

# Conventional tiehandle interface:
sub TIEHANDLE {
    ((defined($_[1]) &amp;&amp; UNIVERSAL::isa($_[1], &quot;IO::Scalar&quot;))
     ? $_[1]
     : shift-&gt;new(@_));
}
sub GETC      { shift-&gt;getc(@_) }
sub PRINT     { shift-&gt;print(@_) }
sub PRINTF    { shift-&gt;print(sprintf(shift, @_)) }
sub READ      { shift-&gt;read(@_) }
sub READLINE  { wantarray ? shift-&gt;getlines(@_) : shift-&gt;getline(@_) }
sub WRITE     { shift-&gt;write(@_); }
sub CLOSE     { shift-&gt;close(@_); }
sub SEEK      { shift-&gt;seek(@_); }
sub TELL      { shift-&gt;tell(@_); }
sub EOF       { shift-&gt;eof(@_); }
sub BINMODE   { 1; }

#------------------------------------------------------------

1;

__END__


=back

=cut


=head1 AUTHOR

Eryq (F&lt;eryq@zeegee.com&gt;).
President, ZeeGee Software Inc (F&lt;http://www.zeegee.com&gt;).

=head1 CONTRIBUTORS

Dianne Skoll (F&lt;dfs@roaringpenguin.com&gt;).

=head1 COPYRIGHT &amp; LICENSE

Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Flocal%2Fshare%2Fperl5%2FIO'>Back to Directory</a>