view release on metacpan or  search on metacpan

t/lib/IO/String.pm  view on Meta::CPAN

    my $len = $slen;
    my $off = 0;
    if (@_ > 1) {
	$len = $_[1] if $_[1] < $len;
	if (@_ > 2) {
	    $off = $_[2] || 0;
	    die "Offset outside string" if $off > $slen;
	    if ($off < 0) {
		$off += $slen;
		die "Offset outside string" if $off < 0;
	    }
	    my $rem = $slen - $off;
	    $len = $rem if $rem < $len;
	}
    }
    substr($$buf, $pos, $len) = substr($_[0], $off, $len);
    *$self->{pos} += $len;
    return $len;
}

*sysread = \&read;
*syswrite = \&write;

sub stat
{
    my $self = shift;
    return unless $self->opened;
    return 1 unless wantarray;
    my $len = length ${*$self->{buf}};

    return (
     undef, undef,  # dev, ino
     0666,          # filemode
     1,             # links
     $>,            # user id
     $),            # group id
     undef,         # device id
     $len,          # size
     undef,         # atime
     undef,         # mtime
     undef,         # ctime
     512,           # blksize
     int(($len+511)/512)  # blocks
    );
}

sub FILENO {
    return undef;   # XXX perlfunc says this means the file is closed
}

sub blocking {
    my $self = shift;
    my $old = *$self->{blocking} || 0;
    *$self->{blocking} = shift if @_;
    return $old;
}

my $notmuch = sub { return };

*fileno    = $notmuch;
*error     = $notmuch;
*clearerr  = $notmuch; 
*sync      = $notmuch;
*flush     = $notmuch;
*setbuf    = $notmuch;
*setvbuf   = $notmuch;

*untaint   = $notmuch;
*autoflush = $notmuch;
*fcntl     = $notmuch;
*ioctl     = $notmuch;

*GETC   = \&getc;
*PRINT  = \&print;
*PRINTF = \&printf;
*READ   = \&read;
*WRITE  = \&write;
*SEEK   = \&seek;
*TELL   = \&getpos;
*EOF    = \&eof;
*CLOSE  = \&close;
*BINMODE = \&binmode;


sub string_ref
{
    my $self = shift;
    return *$self->{buf};
}
*sref = \&string_ref;

1;

__END__

=head1 NAME

IO::String - Emulate file interface for in-core strings

=head1 SYNOPSIS

 use IO::String;
 $io = IO::String->new;
 $io = IO::String->new($var);
 tie *IO, 'IO::String';

 # read data
 <$io>;
 $io->getline;
 read($io, $buf, 100);

 # write data
 print $io "string\n";
 $io->print(@data);
 syswrite($io, $buf, 100);

 select $io;
 printf "Some text %s\n", $str;

 # seek
 $pos = $io->getpos;