Convert-Scalar/Scalar.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define RETCOPY(sv)             \
  if (GIMME_V != G_VOID)        \
    {                           \
      dXSTARG;                  \
      sv_setsv (TARG, (sv));    \
      EXTEND (SP, 1);           \
      PUSHs (TARG);             \
    }

static void
extend (SV *scalar, STRLEN addlen)
{
  SvUPGRADE (scalar, SVt_PV);

  STRLEN cur = SvCUR (scalar);
  STRLEN len = SvLEN (scalar);
  
  if (cur + addlen < len)
    return;

  STRLEN l = len;
  STRLEN o = cur + addlen >= 4096 ? sizeof (void *) * 4 : 0;

  if (l < 64)
    l = 64;

  /* for big sizes, leave a bit of space for malloc management, and assume 4kb or smaller pages */
  addlen += o;

  while (cur + addlen >= l)
    l <<= 1;

  sv_grow (scalar, l - o);
}

MODULE = Convert::Scalar                PACKAGE = Convert::Scalar

TYPEMAP: <<EOF
SSize_t         T_UV
EOF

PROTOTYPES: ENABLE

bool
utf8 (SV *scalar, SV *mode = NO_INIT)
        CODE:
        SvGETMAGIC (scalar);
        RETVAL = !!SvUTF8 (scalar);
        if (items > 1)
          {
            if (SvREADONLY (scalar))
              croak ("Convert::Scalar::utf8 called on read only scalar");
            if (SvTRUE (mode))
              SvUTF8_on (scalar);
            else
              SvUTF8_off (scalar);
          }
        OUTPUT:
        RETVAL

void
utf8_on (SV *scalar)
        PPCODE:
        if (SvREADONLY (scalar))
          croak ("Convert::Scalar::utf8_on called on read only scalar");

        SvGETMAGIC (scalar);
        SvUTF8_on (scalar);
        RETCOPY (scalar);

void
utf8_off (SV *scalar)
        PPCODE:
        if (SvREADONLY (scalar))
          croak ("Convert::Scalar::utf8_off called on read only scalar");

        SvGETMAGIC (scalar);
        SvUTF8_off (scalar);
        RETCOPY (scalar);

int
utf8_valid (SV *scalar)
        CODE:
        STRLEN len;
        char *str = SvPV (scalar, len);
        RETVAL = !!is_utf8_string (str, len);
        OUTPUT:
        RETVAL

void
utf8_upgrade (SV *scalar)
        PPCODE:
        if (SvREADONLY (scalar))
          croak ("Convert::Scalar::utf8_upgrade called on read only scalar");

        sv_utf8_upgrade(scalar);
        RETCOPY (scalar);

bool
utf8_downgrade (SV *scalar, bool fail_ok = 0)
        CODE:
        if (SvREADONLY (scalar))
          croak ("Convert::Scalar::utf8_downgrade called on read only scalar");

        RETVAL = !!sv_utf8_downgrade (scalar, fail_ok);
        OUTPUT:
        RETVAL

void
utf8_encode (SV *scalar)
        PPCODE:
        if (SvREADONLY (scalar))
          croak ("Convert::Scalar::utf8_encode called on read only scalar");

        sv_utf8_encode (scalar);
        RETCOPY (scalar);

UV
utf8_length (SV *scalar)
        CODE:
        RETVAL = (UV) utf8_length (SvPV_nolen (scalar), SvEND (scalar));
        OUTPUT:
        RETVAL

bool
readonly (SV *scalar, SV *on = NO_INIT)
        CODE:
        RETVAL = SvREADONLY (scalar);
        if (items > 1)
          {
            if (SvTRUE (on))
              SvREADONLY_on (scalar);
            else
              SvREADONLY_off (scalar);
          }
        OUTPUT:
        RETVAL

void
readonly_on (SV *scalar)
        CODE:
        SvREADONLY_on (scalar);

void
readonly_off (SV *scalar)
        CODE:
        SvREADONLY_off (scalar);

void
unmagic (SV *scalar, char type)
        CODE:
        sv_unmagic (scalar, type);

void
weaken (SV *scalar)
        CODE:
        sv_rvweaken (scalar);

void
taint (SV *scalar)
        CODE:
        SvTAINTED_on (scalar);

bool
tainted (SV *scalar)
        CODE:
        RETVAL = !!SvTAINTED (scalar);
        OUTPUT:
        RETVAL

void
untaint (SV *scalar)
        CODE:
        SvTAINTED_off (scalar);

STRLEN
len (SV *scalar)
        CODE:
        if (SvTYPE (scalar) < SVt_PV)
          XSRETURN_UNDEF;
        RETVAL = SvLEN (scalar);
        OUTPUT:
        RETVAL

void
grow (SV *scalar, STRLEN newlen)
        PPCODE:
        sv_grow (scalar, newlen);
        if (GIMME_V != G_VOID)
          XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));

void
extend (SV *scalar, STRLEN addlen = 64)
        PPCODE:
{
        extend (scalar, addlen);

        if (GIMME_V != G_VOID)
          XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
}

SSize_t
extend_read (PerlIO *fh, SV *scalar, STRLEN addlen = 64)
        CODE:
{
        if (SvUTF8 (scalar))
          sv_utf8_downgrade (scalar, 0);

        extend (scalar, addlen);

        RETVAL = PerlLIO_read (PerlIO_fileno (fh), SvEND (scalar), SvLEN (scalar) - SvCUR (scalar));

        if (RETVAL < 0)
          XSRETURN_UNDEF;

        SvPOK_only (scalar);
        SvCUR_set (scalar, SvCUR (scalar) + RETVAL);
}
        OUTPUT: RETVAL

SSize_t
read_all (PerlIO *fh, SV *scalar, STRLEN count)
        CODE:
{
        SvUPGRADE (scalar, SVt_PV);
        if (SvUTF8 (scalar))
          sv_utf8_downgrade (scalar, 0);

        SvPOK_only (scalar);

        int fd = PerlIO_fileno (fh);
        RETVAL = 0;

        SvGROW (scalar, count);

        for (;;)
          {
            STRLEN rem = count - RETVAL;

            if (!rem)
              break;

            STRLEN got = PerlLIO_read (fd, SvPVX (scalar) + RETVAL, rem);

            if (got == 0)
              break;
            else if (got < 0)
              if (RETVAL)
                break;
              else
                XSRETURN_UNDEF;

            RETVAL += got;
          }

        SvCUR_set (scalar, RETVAL);
}
        OUTPUT: RETVAL

SSize_t
write_all (PerlIO *fh, SV *scalar)
        CODE:
{
        STRLEN count;
        char *ptr = SvPVbyte (scalar, count);

        int fd = PerlIO_fileno (fh);
        RETVAL = 0;

        for (;;)
          {
            STRLEN rem = count - RETVAL;

            if (!rem)
              break;

            STRLEN got = PerlLIO_write (fd, ptr + RETVAL, rem);

            if (got < 0)
              if (RETVAL)
                break;
              else
                XSRETURN_UNDEF;

            RETVAL += got;
          }
}
        OUTPUT: RETVAL

int
refcnt (SV *scalar, U32 newrefcnt = NO_INIT)
        ALIAS:
          refcnt_rv = 1
        CODE:
        if (ix)
          {
            if (!SvROK (scalar)) croak ("refcnt_rv requires a reference as it's first argument");
            scalar = SvRV (scalar);
          }
        RETVAL = SvREFCNT (scalar);
        if (items > 1)
          SvREFCNT (scalar) = newrefcnt;
        OUTPUT:
        RETVAL

void
refcnt_inc (SV *scalar)
        ALIAS:
          refcnt_inc_rv = 1
        CODE:
        if (ix)
          {
            if (!SvROK (scalar)) croak ("refcnt_inc_rv requires a reference as it's first argument");
            scalar = SvRV (scalar);
          }
        SvREFCNT_inc (scalar);

void
refcnt_dec (SV *scalar)
        ALIAS:
          refcnt_dec_rv = 1
        CODE:
        if (ix)
          {
            if (!SvROK (scalar)) croak ("refcnt_dec_rv requires a reference as it's first argument");
            scalar = SvRV (scalar);
          }
        SvREFCNT_dec (scalar);

bool
ok (SV *scalar)
        CODE:
        RETVAL = !!SvOK (scalar);
        OUTPUT:
        RETVAL

bool
uok (SV *scalar)
        CODE:
        RETVAL = !!SvUOK (scalar);
        OUTPUT:
        RETVAL

bool
rok (SV *scalar)
        CODE:
        RETVAL = !!SvROK (scalar);
        OUTPUT:
        RETVAL

bool
pok (SV *scalar)
        CODE:
        RETVAL = !!SvPOK (scalar);
        OUTPUT:
        RETVAL

bool
nok (SV *scalar)
        CODE:
        RETVAL = !!SvNOK (scalar);
        OUTPUT:
        RETVAL

bool
niok (SV *scalar)
        CODE:
        RETVAL = !!SvNIOK (scalar);
        OUTPUT:
        RETVAL

Revision:	1.12
Committed:	Tue Aug 15 07:29:07 2017 UTC (6 years, 8 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_12, HEAD
Changes since 1.11:	+118 -46 lines
Log Message:	1.12
#	Content
1	#include "EXTERN.h"
2	#include "perl.h"
3	#include "XSUB.h"
4
5	#define RETCOPY(sv) \
6	if (GIMME_V != G_VOID) \
7	{ \
8	dXSTARG; \
9	sv_setsv (TARG, (sv)); \
10	EXTEND (SP, 1); \
11	PUSHs (TARG); \
12	}
13
14	static void
15	extend (SV *scalar, STRLEN addlen)
16	{
17	SvUPGRADE (scalar, SVt_PV);
18
19	STRLEN cur = SvCUR (scalar);
20	STRLEN len = SvLEN (scalar);
21
22	if (cur + addlen < len)
23	return;
24
25	STRLEN l = len;
26	STRLEN o = cur + addlen >= 4096 ? sizeof (void ) 4 : 0;
27
28	if (l < 64)
29	l = 64;
30
31	/* for big sizes, leave a bit of space for malloc management, and assume 4kb or smaller pages */
32	addlen += o;
33
34	while (cur + addlen >= l)
35	l <<= 1;
36
37	sv_grow (scalar, l - o);
38	}
39
40	MODULE = Convert::Scalar PACKAGE = Convert::Scalar
41
42	TYPEMAP: <<EOF
43	SSize_t T_UV
44	EOF
45
46	PROTOTYPES: ENABLE
47
48	bool
49	utf8 (SV scalar, SV mode = NO_INIT)
50	CODE:
51	SvGETMAGIC (scalar);
52	RETVAL = !!SvUTF8 (scalar);
53	if (items > 1)
54	{
55	if (SvREADONLY (scalar))
56	croak ("Convert::Scalar::utf8 called on read only scalar");
57	if (SvTRUE (mode))
58	SvUTF8_on (scalar);
59	else
60	SvUTF8_off (scalar);
61	}
62	OUTPUT:
63	RETVAL
64
65	void
66	utf8_on (SV *scalar)
67	PPCODE:
68	if (SvREADONLY (scalar))
69	croak ("Convert::Scalar::utf8_on called on read only scalar");
70
71	SvGETMAGIC (scalar);
72	SvUTF8_on (scalar);
73	RETCOPY (scalar);
74
75	void
76	utf8_off (SV *scalar)
77	PPCODE:
78	if (SvREADONLY (scalar))
79	croak ("Convert::Scalar::utf8_off called on read only scalar");
80
81	SvGETMAGIC (scalar);
82	SvUTF8_off (scalar);
83	RETCOPY (scalar);
84
85	int
86	utf8_valid (SV *scalar)
87	CODE:
88	STRLEN len;
89	char *str = SvPV (scalar, len);
90	RETVAL = !!is_utf8_string (str, len);
91	OUTPUT:
92	RETVAL
93
94	void
95	utf8_upgrade (SV *scalar)
96	PPCODE:
97	if (SvREADONLY (scalar))
98	croak ("Convert::Scalar::utf8_upgrade called on read only scalar");
99
100	sv_utf8_upgrade(scalar);
101	RETCOPY (scalar);
102
103	bool
104	utf8_downgrade (SV *scalar, bool fail_ok = 0)
105	CODE:
106	if (SvREADONLY (scalar))
107	croak ("Convert::Scalar::utf8_downgrade called on read only scalar");
108
109	RETVAL = !!sv_utf8_downgrade (scalar, fail_ok);
110	OUTPUT:
111	RETVAL
112
113	void
114	utf8_encode (SV *scalar)
115	PPCODE:
116	if (SvREADONLY (scalar))
117	croak ("Convert::Scalar::utf8_encode called on read only scalar");
118
119	sv_utf8_encode (scalar);
120	RETCOPY (scalar);
121
122	UV
123	utf8_length (SV *scalar)
124	CODE:
125	RETVAL = (UV) utf8_length (SvPV_nolen (scalar), SvEND (scalar));
126	OUTPUT:
127	RETVAL
128
129	bool
130	readonly (SV scalar, SV on = NO_INIT)
131	CODE:
132	RETVAL = SvREADONLY (scalar);
133	if (items > 1)
134	{
135	if (SvTRUE (on))
136	SvREADONLY_on (scalar);
137	else
138	SvREADONLY_off (scalar);
139	}
140	OUTPUT:
141	RETVAL
142
143	void
144	readonly_on (SV *scalar)
145	CODE:
146	SvREADONLY_on (scalar);
147
148	void
149	readonly_off (SV *scalar)
150	CODE:
151	SvREADONLY_off (scalar);
152
153	void
154	unmagic (SV *scalar, char type)
155	CODE:
156	sv_unmagic (scalar, type);
157
158	void
159	weaken (SV *scalar)
160	CODE:
161	sv_rvweaken (scalar);
162
163	void
164	taint (SV *scalar)
165	CODE:
166	SvTAINTED_on (scalar);
167
168	bool
169	tainted (SV *scalar)
170	CODE:
171	RETVAL = !!SvTAINTED (scalar);
172	OUTPUT:
173	RETVAL
174
175	void
176	untaint (SV *scalar)
177	CODE:
178	SvTAINTED_off (scalar);
179
180	STRLEN
181	len (SV *scalar)
182	CODE:
183	if (SvTYPE (scalar) < SVt_PV)
184	XSRETURN_UNDEF;
185	RETVAL = SvLEN (scalar);
186	OUTPUT:
187	RETVAL
188
189	void
190	grow (SV *scalar, STRLEN newlen)
191	PPCODE:
192	sv_grow (scalar, newlen);
193	if (GIMME_V != G_VOID)
194	XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
195
196	void
197	extend (SV *scalar, STRLEN addlen = 64)
198	PPCODE:
199	{
200	extend (scalar, addlen);
201
202	if (GIMME_V != G_VOID)
203	XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
204	}
205
206	SSize_t
207	extend_read (PerlIO fh, SV scalar, STRLEN addlen = 64)
208	CODE:
209	{
210	if (SvUTF8 (scalar))
211	sv_utf8_downgrade (scalar, 0);
212
213	extend (scalar, addlen);
214
215	RETVAL = PerlLIO_read (PerlIO_fileno (fh), SvEND (scalar), SvLEN (scalar) - SvCUR (scalar));
216
217	if (RETVAL < 0)
218	XSRETURN_UNDEF;
219
220	SvPOK_only (scalar);
221	SvCUR_set (scalar, SvCUR (scalar) + RETVAL);
222	}
223	OUTPUT: RETVAL
224
225	SSize_t
226	read_all (PerlIO fh, SV scalar, STRLEN count)
227	CODE:
228	{
229	SvUPGRADE (scalar, SVt_PV);
230	if (SvUTF8 (scalar))
231	sv_utf8_downgrade (scalar, 0);
232
233	SvPOK_only (scalar);
234
235	int fd = PerlIO_fileno (fh);
236	RETVAL = 0;
237
238	SvGROW (scalar, count);
239
240	for (;;)
241	{
242	STRLEN rem = count - RETVAL;
243
244	if (!rem)
245	break;
246
247	STRLEN got = PerlLIO_read (fd, SvPVX (scalar) + RETVAL, rem);
248
249	if (got == 0)
250	break;
251	else if (got < 0)
252	if (RETVAL)
253	break;
254	else
255	XSRETURN_UNDEF;
256
257	RETVAL += got;
258	}
259
260	SvCUR_set (scalar, RETVAL);
261	}
262	OUTPUT: RETVAL
263
264	SSize_t
265	write_all (PerlIO fh, SV scalar)
266	CODE:
267	{
268	STRLEN count;
269	char *ptr = SvPVbyte (scalar, count);
270
271	int fd = PerlIO_fileno (fh);
272	RETVAL = 0;
273
274	for (;;)
275	{
276	STRLEN rem = count - RETVAL;
277
278	if (!rem)
279	break;
280
281	STRLEN got = PerlLIO_write (fd, ptr + RETVAL, rem);
282
283	if (got < 0)
284	if (RETVAL)
285	break;
286	else
287	XSRETURN_UNDEF;
288
289	RETVAL += got;
290	}
291	}
292	OUTPUT: RETVAL
293
294	int
295	refcnt (SV *scalar, U32 newrefcnt = NO_INIT)
296	ALIAS:
297	refcnt_rv = 1
298	CODE:
299	if (ix)
300	{
301	if (!SvROK (scalar)) croak ("refcnt_rv requires a reference as it's first argument");
302	scalar = SvRV (scalar);
303	}
304	RETVAL = SvREFCNT (scalar);
305	if (items > 1)
306	SvREFCNT (scalar) = newrefcnt;
307	OUTPUT:
308	RETVAL
309
310	void
311	refcnt_inc (SV *scalar)
312	ALIAS:
313	refcnt_inc_rv = 1
314	CODE:
315	if (ix)
316	{
317	if (!SvROK (scalar)) croak ("refcnt_inc_rv requires a reference as it's first argument");
318	scalar = SvRV (scalar);
319	}
320	SvREFCNT_inc (scalar);
321
322	void
323	refcnt_dec (SV *scalar)
324	ALIAS:
325	refcnt_dec_rv = 1
326	CODE:
327	if (ix)
328	{
329	if (!SvROK (scalar)) croak ("refcnt_dec_rv requires a reference as it's first argument");
330	scalar = SvRV (scalar);
331	}
332	SvREFCNT_dec (scalar);
333
334	bool
335	ok (SV *scalar)
336	CODE:
337	RETVAL = !!SvOK (scalar);
338	OUTPUT:
339	RETVAL
340
341	bool
342	uok (SV *scalar)
343	CODE:
344	RETVAL = !!SvUOK (scalar);
345	OUTPUT:
346	RETVAL
347
348	bool
349	rok (SV *scalar)
350	CODE:
351	RETVAL = !!SvROK (scalar);
352	OUTPUT:
353	RETVAL
354
355	bool
356	pok (SV *scalar)
357	CODE:
358	RETVAL = !!SvPOK (scalar);
359	OUTPUT:
360	RETVAL
361
362	bool
363	nok (SV *scalar)
364	CODE:
365	RETVAL = !!SvNOK (scalar);
366	OUTPUT:
367	RETVAL
368
369	bool
370	niok (SV *scalar)
371	CODE:
372	RETVAL = !!SvNIOK (scalar);
373	OUTPUT:
374	RETVAL
375