[p5sagit/p5-mst-13.2.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) {
	if (SvROK(arg)) {
	    if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') {
		if (ckWARN(WARN_LAYER))
		    Perl_warner(aTHX_ packWARN(WARN_LAYER), PL_no_modify);
		errno = EINVAL;
		return -1;
	    }
	    s->var = SvREFCNT_inc(SvRV(arg));
	    if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
		(void)SvPV_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);
    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 ((STRLEN) s->posn > SvCUR(s->var)) {
	(void) SvGROW(s->var, (STRLEN) s->posn);
    }
    return 0;
}

Off_t
PerlIOScalar_tell(pTHX_ PerlIO * f)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    return s->posn;
}

SSize_t
PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
{
    PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
    char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
    s->posn -= count;
    Move(vbuf, dst + s->posn, count, char);
    SvPOK_on(s->var);
    return count;
}

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 *) Nullch;
}

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 *) Nullch;
}

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,
    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

PROTOTYPES: ENABLE

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