[perl5.git] / ext / PerlIO-scalar / scalar.xs

#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 && SvOK(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)
    {
	sv_force_normal(s->var);
	SvCUR_set(s->var, 0);
    }
    if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
    {
	sv_force_normal(s->var);
	s->posn = SvCUR(s->var);
    }
    else
	s->posn = 0;
    SvSETMAGIC(s->var);
    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)
{
    PERL_UNUSED_ARG(f);
    return -1;
}

IV
PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    STRLEN oldcur;
    STRLEN newlen;

    SvGETMAGIC(s->var);
    oldcur = SvCUR(s->var);

    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_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
    if (!f)
	return 0;
    if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
	PerlIOBase(f)->flags |= PERLIO_F_ERROR;
	SETERRNO(EBADF, SS_IVCHAN);
	return 0;
    }
    {
	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	SV *sv = s->var;
	char *p;
	STRLEN len;
	I32 got;
	p = SvPV(sv, len);
	got = len - (STRLEN)(s->posn);
	if (got <= 0)
	    return 0;
	if ((STRLEN)got > (STRLEN)count)
	    got = (STRLEN)count;
	Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
	s->posn += (Off_t)got;
	return (SSize_t)got;
    }
}

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;
	SvGETMAGIC(sv);
	sv_force_normal(sv);
	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 = SvPVX(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(sv);
	SvSETMAGIC(sv);
	return count;
    }
    else
	return 0;
}

IV
PerlIOScalar_fill(pTHX_ PerlIO * f)
{
    PERL_UNUSED_ARG(f);
    return -1;
}

IV
PerlIOScalar_flush(pTHX_ PerlIO * f)
{
    PERL_UNUSED_ARG(f);
    return 0;
}

STDCHAR *
PerlIOScalar_get_base(pTHX_ PerlIO * f)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
	SvGETMAGIC(s->var);
	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);
	SvGETMAGIC(s->var);
	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);
	SvGETMAGIC(s->var);
	return SvCUR(s->var);
    }
    return 0;
}

void
PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    PERL_UNUSED_ARG(ptr);
    SvGETMAGIC(s->var);
    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;
    PERL_UNUSED_ARG(fd);
    PERL_UNUSED_ARG(imode);
    PERL_UNUSED_ARG(perm);
    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,
    PerlIOScalar_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
}
Commit	Line	Data
f6c77cf1 NIS	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
14d89041 NIS	9	typedef struct {
	10	struct _PerlIO base; /* Base "class" info */
	11	SV *var;
	12	Off_t posn;
f6c77cf1 NIS	13	} PerlIOScalar;
	14
	15	IV
14d89041 NIS	16	PerlIOScalar_pushed(pTHX_ PerlIO * f, const char mode, SV arg,
14d89041 NIS	17	PerlIO_funcs * tab)
f6c77cf1	18	{
14d89041 NIS	19	IV code;
	20	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	*/
82505891	25	if (arg && SvOK(arg)) {
cba44c14	26	if (SvROK(arg)) {
b35bc0c6 RGS	27	if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
b35bc0c6 RGS	28	if (ckWARN(WARN_LAYER))
76c6a213	29	Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
42bc49da	30	SETERRNO(EINVAL, SS_IVCHAN);
b35bc0c6 RGS	31	return -1;
b35bc0c6 RGS	32	}
14d89041	33	s->var = SvREFCNT_inc(SvRV(arg));
22ccb26d BM	34	SvGETMAGIC(s->var);
	35	if (!SvPOK(s->var) && SvOK(s->var))
	36	(void)SvPV_nomg_const_nolen(s->var);
14d89041 NIS	37	}
	38	else {
	39	s->var =
	40	SvREFCNT_inc(perl_get_sv
	41	(SvPV_nolen(arg), GV_ADD \| GV_ADDMULTI));
	42	}
564dc057	43	}
14d89041 NIS	44	else {
14d89041 NIS	45	s->var = newSVpvn("", 0);
564dc057	46	}
c5b94a97	47	SvUPGRADE(s->var, SVt_PV);
14d89041	48	code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee	49	if (!SvOK(s->var) \|\| (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
526fd1b4 FC	50	{
526fd1b4 FC	51	sv_force_normal(s->var);
b162af07	52	SvCUR_set(s->var, 0);
526fd1b4	53	}
14d89041	54	if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
526fd1b4 FC	55	{
526fd1b4 FC	56	sv_force_normal(s->var);
14d89041	57	s->posn = SvCUR(s->var);
526fd1b4	58	}
14d89041 NIS	59	else
14d89041 NIS	60	s->posn = 0;
ffe0bb5a	61	SvSETMAGIC(s->var);
14d89041	62	return code;
f6c77cf1 NIS	63	}
	64
	65	IV
14d89041	66	PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1	67	{
14d89041 NIS	68	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	69	if (s->var) {
	70	SvREFCNT_dec(s->var);
	71	s->var = Nullsv;
	72	}
	73	return 0;
f6c77cf1 NIS	74	}
	75
	76	IV
14d89041	77	PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1	78	{
14d89041 NIS	79	IV code = PerlIOBase_close(aTHX_ f);
	80	PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF \| PERLIO_F_WRBUF);
	81	return code;
f6c77cf1 NIS	82	}
	83
	84	IV
14d89041	85	PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1	86	{
c33e8be1	87	PERL_UNUSED_ARG(f);
14d89041	88	return -1;
f6c77cf1 NIS	89	}
	90
	91	IV
14d89041	92	PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1	93	{
14d89041	94	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
e94207f0	95	STRLEN oldcur;
42bc49da	96	STRLEN newlen;
e94207f0 NC	97
	98	SvGETMAGIC(s->var);
	99	oldcur = SvCUR(s->var);
	100
14d89041	101	switch (whence) {
42bc49da	102	case SEEK_SET:
14d89041 NIS	103	s->posn = offset;
14d89041 NIS	104	break;
42bc49da	105	case SEEK_CUR:
14d89041 NIS	106	s->posn = offset + s->posn;
14d89041 NIS	107	break;
42bc49da	108	case SEEK_END:
14d89041 NIS	109	s->posn = offset + SvCUR(s->var);
	110	break;
	111	}
42bc49da JH	112	if (s->posn < 0) {
	113	if (ckWARN(WARN_LAYER))
	114	Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
	115	SETERRNO(EINVAL, SS_IVCHAN);
	116	return -1;
14d89041	117	}
42bc49da JH	118	newlen = (STRLEN) s->posn;
	119	if (newlen > oldcur) {
	120	(void) SvGROW(s->var, newlen);
	121	Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char);
	122	/* No SvCUR_set(), though. This is just a seek, not a write. */
	123	}
8b8eea96 RGS	124	else if (!SvPVX(s->var)) {
	125	/* ensure there's always a character buffer */
	126	(void)SvGROW(s->var,1);
	127	}
42bc49da	128	SvPOK_on(s->var);
14d89041	129	return 0;
f6c77cf1 NIS	130	}
	131
	132	Off_t
14d89041	133	PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1	134	{
14d89041 NIS	135	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
14d89041 NIS	136	return s->posn;
f6c77cf1 NIS	137	}
f6c77cf1 NIS	138
ffe0bb5a DM	139
	140	SSize_t
	141	PerlIOScalar_read(pTHX_ PerlIO f, void vbuf, Size_t count)
	142	{
	143	if (!f)
	144	return 0;
	145	if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
	146	PerlIOBase(f)->flags \|= PERLIO_F_ERROR;
	147	SETERRNO(EBADF, SS_IVCHAN);
	148	return 0;
	149	}
	150	{
	151	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	152	SV *sv = s->var;
	153	char *p;
ab9f1586 FC	154	STRLEN len;
ab9f1586 FC	155	I32 got;
ffe0bb5a DM	156	p = SvPV(sv, len);
	157	got = len - (STRLEN)(s->posn);
	158	if (got <= 0)
	159	return 0;
c33e8be1	160	if ((STRLEN)got > (STRLEN)count)
ffe0bb5a DM	161	got = (STRLEN)count;
	162	Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
	163	s->posn += (Off_t)got;
	164	return (SSize_t)got;
	165	}
	166	}
	167
f6c77cf1	168	SSize_t
14d89041	169	PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1	170	{
14d89041 NIS	171	if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
	172	Off_t offset;
	173	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	174	SV *sv = s->var;
	175	char *dst;
ffe0bb5a	176	SvGETMAGIC(sv);
526fd1b4	177	sv_force_normal(sv);
14d89041 NIS	178	if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
	179	dst = SvGROW(sv, SvCUR(sv) + count);
	180	offset = SvCUR(sv);
	181	s->posn = offset + count;
	182	}
	183	else {
	184	if ((s->posn + count) > SvCUR(sv))
4a9d6100	185	dst = SvGROW(sv, (STRLEN)s->posn + count);
14d89041	186	else
ffe0bb5a	187	dst = SvPVX(sv);
14d89041 NIS	188	offset = s->posn;
	189	s->posn += count;
	190	}
	191	Move(vbuf, dst + offset, count, char);
	192	if ((STRLEN) s->posn > SvCUR(sv))
4a9d6100	193	SvCUR_set(sv, (STRLEN)s->posn);
ffe0bb5a DM	194	SvPOK_on(sv);
ffe0bb5a DM	195	SvSETMAGIC(sv);
14d89041	196	return count;
09bf542c	197	}
14d89041 NIS	198	else
14d89041 NIS	199	return 0;
f6c77cf1 NIS	200	}
	201
	202	IV
14d89041	203	PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1	204	{
c33e8be1	205	PERL_UNUSED_ARG(f);
14d89041	206	return -1;
f6c77cf1 NIS	207	}
	208
	209	IV
14d89041	210	PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1	211	{
c33e8be1	212	PERL_UNUSED_ARG(f);
14d89041	213	return 0;
f6c77cf1 NIS	214	}
	215
	216	STDCHAR *
14d89041	217	PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1	218	{
14d89041 NIS	219	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
14d89041 NIS	220	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a	221	SvGETMAGIC(s->var);
14d89041 NIS	222	return (STDCHAR *) SvPV_nolen(s->var);
14d89041 NIS	223	}
9849c14c	224	return (STDCHAR *) NULL;
f6c77cf1 NIS	225	}
	226
	227	STDCHAR *
14d89041	228	PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1	229	{
14d89041 NIS	230	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
	231	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	232	return PerlIOScalar_get_base(aTHX_ f) + s->posn;
	233	}
9849c14c	234	return (STDCHAR *) NULL;
f6c77cf1 NIS	235	}
	236
	237	SSize_t
14d89041	238	PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1	239	{
14d89041 NIS	240	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
14d89041 NIS	241	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a	242	SvGETMAGIC(s->var);
14d89041	243	if (SvCUR(s->var) > (STRLEN) s->posn)
4a9d6100	244	return SvCUR(s->var) - (STRLEN)s->posn;
14d89041 NIS	245	else
	246	return 0;
	247	}
75effbe0	248	return 0;
f6c77cf1 NIS	249	}
	250
	251	Size_t
14d89041	252	PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1	253	{
14d89041 NIS	254	if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
14d89041 NIS	255	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a	256	SvGETMAGIC(s->var);
14d89041 NIS	257	return SvCUR(s->var);
	258	}
	259	return 0;
f6c77cf1 NIS	260	}
	261
	262	void
14d89041	263	PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1	264	{
14d89041	265	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
c33e8be1	266	PERL_UNUSED_ARG(ptr);
ffe0bb5a	267	SvGETMAGIC(s->var);
14d89041	268	s->posn = SvCUR(s->var) - cnt;
f6c77cf1 NIS	269	}
	270
	271	PerlIO *
14d89041 NIS	272	PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
	273	const char *mode, int fd, int imode, int perm,
	274	PerlIO * f, int narg, SV ** args)
f6c77cf1	275	{
14d89041	276	SV arg = (narg > 0) ? args : PerlIOArg;
c33e8be1 Z	277	PERL_UNUSED_ARG(fd);
	278	PERL_UNUSED_ARG(imode);
	279	PERL_UNUSED_ARG(perm);
14d89041 NIS	280	if (SvROK(arg) \|\| SvPOK(arg)) {
	281	if (!f) {
	282	f = PerlIO_allocate(aTHX);
	283	}
e3feee4e	284	if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041 NIS	285	PerlIOBase(f)->flags \|= PERLIO_F_OPEN;
	286	}
	287	return f;
	288	}
	289	return NULL;
f6c77cf1 NIS	290	}
f6c77cf1 NIS	291
ecdeb87c	292	SV *
14d89041	293	PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c	294	{
14d89041 NIS	295	PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
	296	SV *var = s->var;
	297	if (flags & PERLIO_DUP_CLONE)
	298	var = PerlIO_sv_dup(aTHX_ var, param);
	299	else if (flags & PERLIO_DUP_FD) {
	300	/* Equivalent (guesses NI-S) of dup() is to create a new scalar */
	301	var = newSVsv(var);
	302	}
	303	else {
	304	var = SvREFCNT_inc(var);
	305	}
	306	return newRV_noinc(var);
ecdeb87c NIS	307	}
ecdeb87c NIS	308
8cf8f3d1	309	PerlIO *
14d89041 NIS	310	PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
14d89041 NIS	311	int flags)
8cf8f3d1	312	{
14d89041 NIS	313	if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
	314	PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
	315	PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
	316	/* var has been set by implicit push */
	317	fs->posn = os->posn;
	318	}
	319	return f;
8cf8f3d1	320	}
f6c77cf1	321
27da23d5	322	PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041 NIS	323	sizeof(PerlIO_funcs),
	324	"scalar",
	325	sizeof(PerlIOScalar),
	326	PERLIO_K_BUFFERED \| PERLIO_K_RAW,
	327	PerlIOScalar_pushed,
	328	PerlIOScalar_popped,
	329	PerlIOScalar_open,
	330	PerlIOBase_binmode,
	331	PerlIOScalar_arg,
	332	PerlIOScalar_fileno,
	333	PerlIOScalar_dup,
ffe0bb5a	334	PerlIOScalar_read,
3ff3a8b6	335	NULL, /* unread */
14d89041 NIS	336	PerlIOScalar_write,
	337	PerlIOScalar_seek,
	338	PerlIOScalar_tell,
	339	PerlIOScalar_close,
	340	PerlIOScalar_flush,
	341	PerlIOScalar_fill,
	342	PerlIOBase_eof,
	343	PerlIOBase_error,
	344	PerlIOBase_clearerr,
	345	PerlIOBase_setlinebuf,
	346	PerlIOScalar_get_base,
	347	PerlIOScalar_bufsiz,
	348	PerlIOScalar_get_ptr,
	349	PerlIOScalar_get_cnt,
	350	PerlIOScalar_set_ptrcnt,
f6c77cf1 NIS	351	};
	352
	353
	354	#endif /* Layers available */
	355
e934609f	356	MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1	357
acf4de66 A	358	PROTOTYPES: ENABLE
acf4de66 A	359
f6c77cf1 NIS	360	BOOT:
	361	{
	362	#ifdef PERLIO_LAYERS
27da23d5	363	PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1 NIS	364	#endif
	365	}
	366