Rename ext/PerlIO/scalar to ext/PerlIO-scalar

5 files changed, 629 insertions, 0 deletions

diff --git a/ext/PerlIO-scalar/Makefile.PL b/ext/PerlIO-scalar/Makefile.PL
new file mode 100644
index 0000000000..11a9ee538c
--- /dev/null
+++ b/ext/PerlIO-scalar/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+	NAME		=> "PerlIO::scalar",
+	MAN3PODS    => {},  # Pods will be built by installman.
+	VERSION_FROM	=> 'scalar.pm',
+);
+
diff --git a/ext/PerlIO-scalar/scalar.pm b/ext/PerlIO-scalar/scalar.pm
new file mode 100644
index 0000000000..5188ddbc3c
--- /dev/null
+++ b/ext/PerlIO-scalar/scalar.pm
@@ -0,0 +1,41 @@
+package PerlIO::scalar;
+our $VERSION = '0.07';
+use XSLoader ();
+XSLoader::load 'PerlIO::scalar';
+1;
+__END__
+
+=head1 NAME
+
+PerlIO::scalar - in-memory IO, scalar IO
+
+=head1 SYNOPSIS
+
+   my $scalar = '';
+   ...
+   open my $fh, "<",  \$scalar or die;
+   open my $fh, ">",  \$scalar or die;
+   open my $fh, ">>", \$scalar or die;
+
+or
+
+   my $scalar = '';
+   ...
+   open my $fh, "<:scalar",  \$scalar or die;
+   open my $fh, ">:scalar",  \$scalar or die;
+   open my $fh, ">>:scalar", \$scalar or die;
+
+=head1 DESCRIPTION
+
+A filehandle is opened but the file operations are performed "in-memory"
+on a scalar variable.  All the normal file operations can be performed
+on the handle. The scalar is considered a stream of bytes.  Currently
+fileno($fh) returns -1.
+
+=head1 IMPLEMENTATION NOTE
+
+C<PerlIO::scalar> only exists to use XSLoader to load C code that
+provides support for treating a scalar as an "in memory" file.
+One does not need to explicitly C<use PerlIO::scalar>.
+
+=cut
diff --git a/ext/PerlIO-scalar/scalar.xs b/ext/PerlIO-scalar/scalar.xs
new file mode 100644
index 0000000000..d9574d7be8
--- /dev/null
+++ b/ext/PerlIO-scalar/scalar.xs
@@ -0,0 +1,312 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef PERLIO_LAYERS
+
+#include "perliol.h"
+
+typedef struct {
+    struct _PerlIO base;	/* Base "class" info */
+    SV *var;
+    Off_t posn;
+} PerlIOScalar;
+
+IV
+PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
+		    PerlIO_funcs * tab)
+{
+    IV code;
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    /* If called (normally) via open() then arg is ref to scalar we are
+     * using, otherwise arg (from binmode presumably) is either NULL
+     * or the _name_ of the scalar
+     */
+    if (arg) {
+	if (SvROK(arg)) {
+	    if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
+		if (ckWARN(WARN_LAYER))
+		    Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
+		SETERRNO(EINVAL, SS_IVCHAN);
+		return -1;
+	    }
+	    s->var = SvREFCNT_inc(SvRV(arg));
+	    SvGETMAGIC(s->var);
+	    if (!SvPOK(s->var) && SvOK(s->var))
+		(void)SvPV_nomg_const_nolen(s->var);
+	}
+	else {
+	    s->var =
+		SvREFCNT_inc(perl_get_sv
+			     (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
+	}
+    }
+    else {
+	s->var = newSVpvn("", 0);
+    }
+    SvUPGRADE(s->var, SVt_PV);
+    code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
+    if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
+	SvCUR_set(s->var, 0);
+    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
+	s->posn = SvCUR(s->var);
+    else
+	s->posn = 0;
+    return code;
+}
+
+IV
+PerlIOScalar_popped(pTHX_ PerlIO * f)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    if (s->var) {
+	SvREFCNT_dec(s->var);
+	s->var = Nullsv;
+    }
+    return 0;
+}
+
+IV
+PerlIOScalar_close(pTHX_ PerlIO * f)
+{
+    IV code = PerlIOBase_close(aTHX_ f);
+    PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
+    return code;
+}
+
+IV
+PerlIOScalar_fileno(pTHX_ PerlIO * f)
+{
+    return -1;
+}
+
+IV
+PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    STRLEN oldcur = SvCUR(s->var);
+    STRLEN newlen;
+    switch (whence) {
+    case SEEK_SET:
+	s->posn = offset;
+	break;
+    case SEEK_CUR:
+	s->posn = offset + s->posn;
+	break;
+    case SEEK_END:
+	s->posn = offset + SvCUR(s->var);
+	break;
+    }
+    if (s->posn < 0) {
+        if (ckWARN(WARN_LAYER))
+	    Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
+	SETERRNO(EINVAL, SS_IVCHAN);
+	return -1;
+    }
+    newlen = (STRLEN) s->posn;
+    if (newlen > oldcur) {
+	(void) SvGROW(s->var, newlen);
+	Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
+	/* No SvCUR_set(), though.  This is just a seek, not a write. */
+    }
+    else if (!SvPVX(s->var)) {
+	/* ensure there's always a character buffer */
+	(void)SvGROW(s->var,1);
+    }
+    SvPOK_on(s->var);
+    return 0;
+}
+
+Off_t
+PerlIOScalar_tell(pTHX_ PerlIO * f)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    return s->posn;
+}
+
+SSize_t
+PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
+{
+    if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
+	Off_t offset;
+	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+	SV *sv = s->var;
+	char *dst;
+	if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
+	    dst = SvGROW(sv, SvCUR(sv) + count);
+	    offset = SvCUR(sv);
+	    s->posn = offset + count;
+	}
+	else {
+	    if ((s->posn + count) > SvCUR(sv))
+		dst = SvGROW(sv, (STRLEN)s->posn + count);
+	    else
+		dst = SvPV_nolen(sv);
+	    offset = s->posn;
+	    s->posn += count;
+	}
+	Move(vbuf, dst + offset, count, char);
+	if ((STRLEN) s->posn > SvCUR(sv))
+	    SvCUR_set(sv, (STRLEN)s->posn);
+	SvPOK_on(s->var);
+	return count;
+    }
+    else
+	return 0;
+}
+
+IV
+PerlIOScalar_fill(pTHX_ PerlIO * f)
+{
+    return -1;
+}
+
+IV
+PerlIOScalar_flush(pTHX_ PerlIO * f)
+{
+    return 0;
+}
+
+STDCHAR *
+PerlIOScalar_get_base(pTHX_ PerlIO * f)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
+	return (STDCHAR *) SvPV_nolen(s->var);
+    }
+    return (STDCHAR *) NULL;
+}
+
+STDCHAR *
+PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
+{
+    if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
+	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+	return PerlIOScalar_get_base(aTHX_ f) + s->posn;
+    }
+    return (STDCHAR *) NULL;
+}
+
+SSize_t
+PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
+{
+    if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
+	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+	if (SvCUR(s->var) > (STRLEN) s->posn)
+	    return SvCUR(s->var) - (STRLEN)s->posn;
+	else
+	    return 0;
+    }
+    return 0;
+}
+
+Size_t
+PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
+{
+    if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
+	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+	return SvCUR(s->var);
+    }
+    return 0;
+}
+
+void
+PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    s->posn = SvCUR(s->var) - cnt;
+}
+
+PerlIO *
+PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
+		  const char *mode, int fd, int imode, int perm,
+		  PerlIO * f, int narg, SV ** args)
+{
+    SV *arg = (narg > 0) ? *args : PerlIOArg;
+    if (SvROK(arg) || SvPOK(arg)) {
+	if (!f) {
+	    f = PerlIO_allocate(aTHX);
+	}
+	if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
+	    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+	}
+	return f;
+    }
+    return NULL;
+}
+
+SV *
+PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
+{
+    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
+    SV *var = s->var;
+    if (flags & PERLIO_DUP_CLONE)
+	var = PerlIO_sv_dup(aTHX_ var, param);
+    else if (flags & PERLIO_DUP_FD) {
+	/* Equivalent (guesses NI-S) of dup() is to create a new scalar */
+	var = newSVsv(var);
+    }
+    else {
+	var = SvREFCNT_inc(var);
+    }
+    return newRV_noinc(var);
+}
+
+PerlIO *
+PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
+		 int flags)
+{
+    if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
+	PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
+	PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
+	/* var has been set by implicit push */
+	fs->posn = os->posn;
+    }
+    return f;
+}
+
+PERLIO_FUNCS_DECL(PerlIO_scalar) = {
+    sizeof(PerlIO_funcs),
+    "scalar",
+    sizeof(PerlIOScalar),
+    PERLIO_K_BUFFERED | PERLIO_K_RAW,
+    PerlIOScalar_pushed,
+    PerlIOScalar_popped,
+    PerlIOScalar_open,
+    PerlIOBase_binmode,
+    PerlIOScalar_arg,
+    PerlIOScalar_fileno,
+    PerlIOScalar_dup,
+    PerlIOBase_read,
+    NULL, /* unread */
+    PerlIOScalar_write,
+    PerlIOScalar_seek,
+    PerlIOScalar_tell,
+    PerlIOScalar_close,
+    PerlIOScalar_flush,
+    PerlIOScalar_fill,
+    PerlIOBase_eof,
+    PerlIOBase_error,
+    PerlIOBase_clearerr,
+    PerlIOBase_setlinebuf,
+    PerlIOScalar_get_base,
+    PerlIOScalar_bufsiz,
+    PerlIOScalar_get_ptr,
+    PerlIOScalar_get_cnt,
+    PerlIOScalar_set_ptrcnt,
+};
+
+
+#endif /* Layers available */
+
+MODULE = PerlIO::scalar	PACKAGE = PerlIO::scalar
+
+PROTOTYPES: ENABLE
+
+BOOT:
+{
+#ifdef PERLIO_LAYERS
+ PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
+#endif
+}
+
diff --git a/ext/PerlIO-scalar/t/scalar.t b/ext/PerlIO-scalar/t/scalar.t
new file mode 100644
index 0000000000..393ce0d375
--- /dev/null
+++ b/ext/PerlIO-scalar/t/scalar.t
@@ -0,0 +1,233 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    unless (find PerlIO::Layer 'perlio') {
+	print "1..0 # Skip: not perlio\n";
+	exit 0;
+    }
+    require Config;
+    if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
+        print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
+        exit 0;
+    }
+}
+
+use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
+
+$| = 1;
+
+use Test::More tests => 55;
+
+my $fh;
+my $var = "aaa\n";
+ok(open($fh,"+<",\$var));
+
+is(<$fh>, $var);
+
+ok(eof($fh));
+
+ok(seek($fh,0,SEEK_SET));
+ok(!eof($fh));
+
+ok(print $fh "bbb\n");
+is($var, "bbb\n");
+$var = "foo\nbar\n";
+ok(seek($fh,0,SEEK_SET));
+ok(!eof($fh));
+is(<$fh>, "foo\n");
+ok(close $fh, $!);
+
+# Test that semantics are similar to normal file-based I/O
+# Check that ">" clobbers the scalar
+$var = "Something";
+open $fh, ">", \$var;
+is($var, "");
+#  Check that file offset set to beginning of scalar
+my $off = tell($fh);
+is($off, 0);
+# Check that writes go where they should and update the offset
+$var = "Something";
+print $fh "Brea";
+$off = tell($fh);
+is($off, 4);
+is($var, "Breathing");
+close $fh;
+
+# Check that ">>" appends to the scalar
+$var = "Something ";
+open $fh, ">>", \$var;
+$off = tell($fh);
+is($off, 10);
+is($var, "Something ");
+#  Check that further writes go to the very end of the scalar
+$var .= "else ";
+is($var, "Something else ");
+
+$off = tell($fh);
+is($off, 10);
+
+print $fh "is here";
+is($var, "Something else is here");
+close $fh;
+
+# Check that updates to the scalar from elsewhere do not
+# cause problems
+$var = "line one\nline two\line three\n";
+open $fh, "<", \$var;
+while (<$fh>) {
+    $var = "foo";
+}
+close $fh;
+is($var, "foo");
+
+# Check that dup'ing the handle works
+
+$var = '';
+open $fh, "+>", \$var;
+print $fh "xxx\n";
+open $dup,'+<&',$fh;
+print $dup "yyy\n";
+seek($dup,0,SEEK_SET);
+is(<$dup>, "xxx\n");
+is(<$dup>, "yyy\n");
+close($fh);
+close($dup);
+
+open $fh, '<', \42;
+is(<$fh>, "42", "reading from non-string scalars");
+close $fh;
+
+{ package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
+tie $p, P; open $fh, '<', \$p;
+is(<$fh>, "shazam", "reading from magic scalars");
+
+{
+    use warnings;
+    my $warn = 0;
+    local $SIG{__WARN__} = sub { $warn++ };
+    open my $fh, '>', \my $scalar;
+    print $fh "foo";
+    close $fh;
+    is($warn, 0, "no warnings when writing to an undefined scalar");
+}
+
+{
+    use warnings;
+    my $warn = 0;
+    local $SIG{__WARN__} = sub { $warn++ };
+    for (1..2) {
+        open my $fh, '>', \my $scalar;
+        close $fh;
+    }
+    is($warn, 0, "no warnings when reusing a lexical");
+}
+
+{
+    use warnings;
+    my $warn = 0;
+    local $SIG{__WARN__} = sub { $warn++ };
+
+    my $fetch = 0;
+    {
+        package MgUndef;
+        sub TIESCALAR { bless [] }
+        sub FETCH { $fetch++; return undef }
+    }
+    tie my $scalar, MgUndef;
+
+    open my $fh, '<', \$scalar;
+    close $fh;
+    is($warn, 0, "no warnings reading a magical undef scalar");
+    is($fetch, 1, "FETCH only called once");
+}
+
+{
+    use warnings;
+    my $warn = 0;
+    local $SIG{__WARN__} = sub { $warn++ };
+    my $scalar = 3;
+    undef $scalar;
+    open my $fh, '<', \$scalar;
+    close $fh;
+    is($warn, 0, "no warnings reading an undef, allocated scalar");
+}
+
+my $data = "a non-empty PV";
+$data = undef;
+open(MEM, '<', \$data) or die "Fail: $!\n";
+my $x = join '', <MEM>;
+is($x, '');
+
+{
+    # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
+    my $s = <<'EOF';
+line A
+line B
+a third line
+EOF
+    open(F, '<', \$s) or die "Could not open string as a file";
+    local $/ = "";
+    my $ln = <F>;
+    close F;
+    is($ln, $s, "[perl #35929]");
+}
+
+# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
+{
+    ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
+    close F;
+
+    my $ro = \43;
+    ok(!(defined open(F, '>', $ro)), $!);
+    close F;
+    # but we can read from it
+    ok(open(F, '<', $ro), $!);
+    is(<F>, 43);
+    close F;
+}
+
+{
+    # Check that we zero fill when needed when seeking,
+    # and that seeking negative off the string does not do bad things.
+
+    my $foo;
+
+    ok(open(F, '>', \$foo));
+
+    # Seeking forward should zero fill.
+
+    ok(seek(F, 50, SEEK_SET));
+    print F "x";
+    is(length($foo), 51);
+    like($foo, qr/^\0{50}x$/);
+
+    is(tell(F), 51);
+    ok(seek(F, 0, SEEK_SET));
+    is(length($foo), 51);
+
+    # Seeking forward again should zero fill but only the new bytes.
+
+    ok(seek(F, 100, SEEK_SET));
+    print F "y";
+    is(length($foo), 101);
+    like($foo, qr/^\0{50}x\0{49}y$/);
+    is(tell(F), 101);
+
+    # Seeking back and writing should not zero fill.
+
+    ok(seek(F, 75, SEEK_SET));
+    print F "z";
+    is(length($foo), 101);
+    like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
+    is(tell(F), 76);
+
+    # Seeking negative should not do funny business.
+
+    ok(!seek(F,  -50, SEEK_SET), $!);
+    ok(seek(F, 0, SEEK_SET));
+    ok(!seek(F,  -50, SEEK_CUR), $!);
+    ok(!seek(F, -150, SEEK_END), $!);
+}
+
diff --git a/ext/PerlIO-scalar/t/scalar_ungetc.t b/ext/PerlIO-scalar/t/scalar_ungetc.t
new file mode 100644
index 0000000000..a4cd695056
--- /dev/null
+++ b/ext/PerlIO-scalar/t/scalar_ungetc.t
@@ -0,0 +1,36 @@
+#!perl -w
+use strict;
+use IO::Handle; # ungetc()
+
+use Test::More tests => 20;
+
+require_ok q{PerlIO::scalar};
+
+my $s = 'foo';
+Internals::SvREADONLY($s, 1);
+eval{
+	$s = 'bar';
+};
+like $@, qr/Modification of a read-only value/, '$s is readonly';
+
+ok open(my $io, '<', \$s), 'open';
+
+getc $io;
+
+my $a = ord 'A';
+
+note "buffer[$s]";
+is $io->ungetc($a), $a, 'ungetc';
+note "buffer[$s]";
+
+is getc($io), chr($a), 'getc';
+
+is $s, 'foo', '$s remains "foo"';
+
+is getc($io), 'o', 'getc/2';
+is getc($io), 'o', 'getc/3';
+is getc($io), undef, 'getc/4';
+
+for my $c($a .. ($a+10)){
+	is $io->ungetc($c), $c, "ungetc($c)";
+}