Implement:

 1.  open($fh,"+<",undef);  # add test to t/io/open.t
 2.  open($fh,"+<",\$var);  # New test t/lib/io_scalar.t

p4raw-id: //depot/perlio@9318

3 files changed, 243 insertions, 0 deletions

diff --git a/ext/PerlIO/Scalar/Makefile.PL b/ext/PerlIO/Scalar/Makefile.PL
new file mode 100644
index 0000000000..81fe5139e6
--- /dev/null
+++ b/ext/PerlIO/Scalar/Makefile.PL
@@ -0,0 +1,6 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+	NAME		=> "PerlIO::Scalar",
+	VERSION_FROM	=> 'Scalar.pm',
+);
+
diff --git a/ext/PerlIO/Scalar/Scalar.pm b/ext/PerlIO/Scalar/Scalar.pm
new file mode 100644
index 0000000000..e733a72c1b
--- /dev/null
+++ b/ext/PerlIO/Scalar/Scalar.pm
@@ -0,0 +1,6 @@
+package PerlIO::Scalar;
+our $VERSION = '0.01';
+use XSLoader ();
+XSLoader::load 'PerlIO::Scalar';
+1;
+__END__
diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs
new file mode 100644
index 0000000000..650cc5a67a
--- /dev/null
+++ b/ext/PerlIO/Scalar/Scalar.xs
@@ -0,0 +1,231 @@
+#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(PerlIO *f, const char *mode, SV *arg)
+{
+ PerlIOScalar *b = PerlIOSelf(f,PerlIOScalar);
+ return PerlIOBase_pushed(f,mode,arg);
+}
+
+IV
+PerlIOScalar_popped(PerlIO *f)
+{
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ if (s->var)
+  {
+   dTHX;
+   SvREFCNT_dec(s->var);
+   s->var = Nullsv;
+  }
+ return 0;
+}
+
+IV
+PerlIOScalar_close(PerlIO *f)
+{
+ dTHX;
+ IV code = PerlIOBase_close(f);
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+IV
+PerlIOScalar_fileno(PerlIO *f)
+{
+ return -1;
+}
+
+IV
+PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence)
+{
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ switch(whence)
+  {
+   case 0:
+    s->posn = offset;
+    break;
+   case 1:
+    s->posn = offset + s->posn;
+    break;
+   case 2:
+    s->posn = offset + SvCUR(s->var);
+    break;
+  }
+ if (s->posn > SvCUR(s->var))
+  {
+   dTHX;
+   (void) SvGROW(s->var,s->posn);
+  }
+ return 0;
+}
+
+Off_t
+PerlIOScalar_tell(PerlIO *f)
+{
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ return s->posn;
+}
+
+SSize_t
+PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count)
+{
+ dTHX;
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ char *dst = SvGROW(s->var,s->posn+count);
+ Move(vbuf,dst,count,char);
+ s->posn += count;
+ SvCUR_set(s->var,s->posn);
+ SvPOK_on(s->var);
+ return count;
+}
+
+SSize_t
+PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count)
+{
+ if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE)
+  {
+   return PerlIOScalar_unread(f,vbuf,count);
+  }
+ return 0;
+}
+
+IV
+PerlIOScalar_fill(PerlIO *f)
+{
+ return -1;
+}
+
+IV
+PerlIOScalar_flush(PerlIO *f)
+{
+ return 0;
+}
+
+STDCHAR *
+PerlIOScalar_get_base(PerlIO *f)
+{
+ PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+ if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
+  {
+   dTHX;
+   return (STDCHAR *)SvPV_nolen(s->var);
+  }
+}
+
+STDCHAR *
+PerlIOScalar_get_ptr(PerlIO *f)
+{
+ if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
+  {
+   PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+   return PerlIOScalar_get_base(f)+s->posn;
+  }
+ return (STDCHAR *) Nullch;
+}
+
+SSize_t
+PerlIOScalar_get_cnt(PerlIO *f)
+{
+ if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
+  {
+   PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+   return SvCUR(s->var) - s->posn;
+  }
+ return 0;
+}
+
+Size_t
+PerlIOScalar_bufsiz(PerlIO *f)
+{
+ if (PerlIOBase(f)->flags & PERLIO_F_CANREAD)
+  {
+   PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
+   return SvCUR(s->var);
+  }
+ return 0;
+}
+
+void
+PerlIOScalar_set_ptrcnt(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, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args)
+{
+ PerlIOScalar *s;
+ if (narg > 0)
+  {
+   SV *ref = *args;
+   if (SvROK(ref))
+    {
+     SV *var = SvRV(ref);
+     sv_upgrade(var,SVt_PV);
+     f = PerlIO_allocate(aTHX);
+     s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOScalar);
+     s->var = SvREFCNT_inc(var);
+     s->posn = 0;
+     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+     return f;
+    }
+  }
+ return NULL;
+}
+
+
+PerlIO_funcs PerlIO_scalar = {
+ "Scalar",
+ sizeof(PerlIOScalar),
+ PERLIO_K_BUFFERED,
+ PerlIOScalar_pushed,
+ PerlIOScalar_popped,
+ PerlIOScalar_open,
+ NULL,
+ PerlIOScalar_fileno,
+ PerlIOBase_read,
+ PerlIOScalar_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
+
+BOOT:
+{
+#ifdef PERLIO_LAYERS
+ PerlIO_define_layer(aTHX_ &PerlIO_scalar);
+#endif
+}
+