1			#define PERL_NO_GET_CONTEXT
     2			#include "EXTERN.h"
     3			#include "perl.h"
     4			#include "XSUB.h"
     5			#ifdef PERLIO_LAYERS
     6			
     7			#include "perliol.h"
     8			
     9			typedef struct {
    10			    struct _PerlIO base;	/* Base "class" info */
    11			    SV *var;
    12			    Off_t posn;
    13			} PerlIOScalar;
    14			
    15			IV
    16			PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
    17					    PerlIO_funcs * tab)
    18	         938    {
    19	         938        IV code;
    20	         938        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    21			    /* If called (normally) via open() then arg is ref to scalar we are
    22			     * using, otherwise arg (from binmode presumably) is either NULL
    23			     * or the _name_ of the scalar
    24			     */
    25	         938        if (arg) {
    26	         938    	if (SvROK(arg)) {
    27	         938    	    s->var = SvREFCNT_inc(SvRV(arg));
    28	         938    	    if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
    29	           3    		(void)SvPV_nolen(s->var);
    30				}
    31				else {
    32	      ######    	    s->var =
    33					SvREFCNT_inc(perl_get_sv
    34	      ######    			     (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
    35				}
    36			    }
    37			    else {
    38	      ######    	s->var = newSVpvn("", 0);
    39			    }
    40	         938        SvUPGRADE(s->var, SVt_PV);
    41	         938        code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
    42	         938        if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
    43	         930    	SvCUR_set(s->var, 0);
    44	         938        if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
    45	           1    	s->posn = SvCUR(s->var);
    46			    else
    47	         937    	s->posn = 0;
    48	         938        return code;
    49			}
    50			
    51			IV
    52			PerlIOScalar_popped(pTHX_ PerlIO * f)
    53	         938    {
    54	         938        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    55	         938        if (s->var) {
    56	         938    	SvREFCNT_dec(s->var);
    57	         938    	s->var = Nullsv;
    58			    }
    59	         938        return 0;
    60			}
    61			
    62			IV
    63			PerlIOScalar_close(pTHX_ PerlIO * f)
    64	         938    {
    65	         938        IV code = PerlIOBase_close(aTHX_ f);
    66	         938        PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
    67	         938        return code;
    68			}
    69			
    70			IV
    71			PerlIOScalar_fileno(pTHX_ PerlIO * f)
    72	         942    {
    73	         942        return -1;
    74			}
    75			
    76			IV
    77			PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
    78	           7    {
    79	           7        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    80	           7        switch (whence) {
    81			    case 0:
    82	           7    	s->posn = offset;
    83	           7    	break;
    84			    case 1:
    85	      ######    	s->posn = offset + s->posn;
    86	      ######    	break;
    87			    case 2:
    88	      ######    	s->posn = offset + SvCUR(s->var);
    89				break;
    90			    }
    91	           7        if ((STRLEN) s->posn > SvCUR(s->var)) {
    92	      ######    	(void) SvGROW(s->var, (STRLEN) s->posn);
    93			    }
    94	           7        return 0;
    95			}
    96			
    97			Off_t
    98			PerlIOScalar_tell(pTHX_ PerlIO * f)
    99	           9    {
   100	           9        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   101	           9        return s->posn;
   102			}
   103			
   104			SSize_t
   105			PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
   106	           1    {
   107	           1        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   108	           1        char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
   109	           1        s->posn -= count;
   110	           1        Move(vbuf, dst + s->posn, count, char);
   111	           1        SvPOK_on(s->var);
   112	           1        return count;
   113			}
   114			
   115			SSize_t
   116			PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
   117	       31915    {
   118	       31915        if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
   119	       31915    	Off_t offset;
   120	       31915    	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   121	       31915    	SV *sv = s->var;
   122	       31915    	char *dst;
   123	       31915    	if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
   124	           1    	    dst = SvGROW(sv, SvCUR(sv) + count);
   125	           1    	    offset = SvCUR(sv);
   126	           1    	    s->posn = offset + count;
   127				}
   128				else {
   129	       31914    	    if ((s->posn + count) > SvCUR(sv))
   130	       31912    		dst = SvGROW(sv, (STRLEN)s->posn + count);
   131				    else
   132	           2    		dst = SvPV_nolen(sv);
   133	       31914    	    offset = s->posn;
   134	       31914    	    s->posn += count;
   135				}
   136	       31915    	Move(vbuf, dst + offset, count, char);
   137	       31915    	if ((STRLEN) s->posn > SvCUR(sv))
   138	       31913    	    SvCUR_set(sv, (STRLEN)s->posn);
   139	       31915    	SvPOK_on(s->var);
   140	       31915    	return count;
   141			    }
   142			    else
   143	      ######    	return 0;
   144			}
   145			
   146			IV
   147			PerlIOScalar_fill(pTHX_ PerlIO * f)
   148	           8    {
   149	           8        return -1;
   150			}
   151			
   152			IV
   153			PerlIOScalar_flush(pTHX_ PerlIO * f)
   154	        1004    {
   155	        1004        return 0;
   156			}
   157			
   158			STDCHAR *
   159			PerlIOScalar_get_base(pTHX_ PerlIO * f)
   160	          44    {
   161	          44        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   162	          44        if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
   163	          44    	return (STDCHAR *) SvPV_nolen(s->var);
   164			    }
   165	      ######        return (STDCHAR *) Nullch;
   166			}
   167			
   168			STDCHAR *
   169			PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
   170	          44    {
   171	          44        if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
   172	          44    	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   173	          44    	return PerlIOScalar_get_base(aTHX_ f) + s->posn;
   174			    }
   175	      ######        return (STDCHAR *) Nullch;
   176			}
   177			
   178			SSize_t
   179			PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
   180	          56    {
   181	          56        if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
   182	          56    	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   183	          56    	if (SvCUR(s->var) > (STRLEN) s->posn)
   184	          34    	    return SvCUR(s->var) - (STRLEN)s->posn;
   185				else
   186	          22    	    return 0;
   187			    }
   188	      ######        return 0;
   189			}
   190			
   191			Size_t
   192			PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
   193	      ######    {
   194	      ######        if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
   195	      ######    	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   196	      ######    	return SvCUR(s->var);
   197			    }
   198	      ######        return 0;
   199			}
   200			
   201			void
   202			PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
   203	          44    {
   204	          44        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   205	          44        s->posn = SvCUR(s->var) - cnt;
   206			}
   207			
   208			PerlIO *
   209			PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
   210					  const char *mode, int fd, int imode, int perm,
   211					  PerlIO * f, int narg, SV ** args)
   212	         937    {
   213	         937        SV *arg = (narg > 0) ? *args : PerlIOArg;
   214	         937        if (SvROK(arg) || SvPOK(arg)) {
   215	         937    	if (!f) {
   216	         937    	    f = PerlIO_allocate(aTHX);
   217				}
   218	         937    	if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
   219	         937    	    PerlIOBase(f)->flags |= PERLIO_F_OPEN;
   220				}
   221	         937    	return f;
   222			    }
   223	      ######        return NULL;
   224			}
   225			
   226			SV *
   227			PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
   228	           1    {
   229	           1        PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
   230	           1        SV *var = s->var;
   231	           1        if (flags & PERLIO_DUP_CLONE)
   232	      ######    	var = PerlIO_sv_dup(aTHX_ var, param);
   233	           1        else if (flags & PERLIO_DUP_FD) {
   234				/* Equivalent (guesses NI-S) of dup() is to create a new scalar */
   235	           1    	var = newSVsv(var);
   236			    }
   237			    else {
   238	      ######    	var = SvREFCNT_inc(var);
   239			    }
   240	           1        return newRV_noinc(var);
   241			}
   242			
   243			PerlIO *
   244			PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
   245					 int flags)
   246	           1    {
   247	           1        if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
   248	           1    	PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
   249	           1    	PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
   250				/* var has been set by implicit push */
   251	           1    	fs->posn = os->posn;
   252			    }
   253	           1        return f;
   254			}
   255			
   256			PERLIO_FUNCS_DECL(PerlIO_scalar) = {
   257			    sizeof(PerlIO_funcs),
   258			    "scalar",
   259			    sizeof(PerlIOScalar),
   260			    PERLIO_K_BUFFERED | PERLIO_K_RAW,
   261			    PerlIOScalar_pushed,
   262			    PerlIOScalar_popped,
   263			    PerlIOScalar_open,
   264			    PerlIOBase_binmode,
   265			    PerlIOScalar_arg,
   266			    PerlIOScalar_fileno,
   267			    PerlIOScalar_dup,
   268			    PerlIOBase_read,
   269			    PerlIOScalar_unread,
   270			    PerlIOScalar_write,
   271			    PerlIOScalar_seek,
   272			    PerlIOScalar_tell,
   273			    PerlIOScalar_close,
   274			    PerlIOScalar_flush,
   275			    PerlIOScalar_fill,
   276			    PerlIOBase_eof,
   277			    PerlIOBase_error,
   278			    PerlIOBase_clearerr,
   279			    PerlIOBase_setlinebuf,
   280			    PerlIOScalar_get_base,
   281			    PerlIOScalar_bufsiz,
   282			    PerlIOScalar_get_ptr,
   283			    PerlIOScalar_get_cnt,
   284			    PerlIOScalar_set_ptrcnt,
   285			};
   286			
   287			
   288			#endif /* Layers available */
   289			
   290			MODULE = PerlIO::scalar	PACKAGE = PerlIO::scalar
   291			
   292			PROTOTYPES: ENABLE
   293			
   294			BOOT:
   295			{
   296			#ifdef PERLIO_LAYERS
   297	          16     PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
   298			#endif
   299			}
   300			
   301