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, 9 months ago) by root
Branch:	MAIN
CVS Tags:	rel-1_12, HEAD
Changes since 1.11:	+118 -46 lines
Log Message:	1.12
#	User	Rev	Content
1	root	1.1	#include "EXTERN.h"
2			#include "perl.h"
3			#include "XSUB.h"
4
5	root	1.6	#define RETCOPY(sv) \
6			if (GIMME_V != G_VOID) \
7	root	1.12	{ \
8	root	1.6	dXSTARG; \
9			sv_setsv (TARG, (sv)); \
10			EXTEND (SP, 1); \
11			PUSHs (TARG); \
12			}
13
14	root	1.12	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	root	1.1	MODULE = Convert::Scalar PACKAGE = Convert::Scalar
41
42	root	1.12	TYPEMAP: <<EOF
43			SSize_t T_UV
44			EOF
45
46			PROTOTYPES: ENABLE
47
48	root	1.7	bool
49	root	1.10	utf8 (SV scalar, SV mode = NO_INIT)
50	root	1.1	CODE:
51			SvGETMAGIC (scalar);
52			RETVAL = !!SvUTF8 (scalar);
53			if (items > 1)
54			{
55	root	1.3	if (SvREADONLY (scalar))
56			croak ("Convert::Scalar::utf8 called on read only scalar");
57	root	1.1	if (SvTRUE (mode))
58			SvUTF8_on (scalar);
59			else
60			SvUTF8_off (scalar);
61			}
62			OUTPUT:
63			RETVAL
64
65			void
66	root	1.10	utf8_on (SV *scalar)
67	root	1.1	PPCODE:
68	root	1.3	if (SvREADONLY (scalar))
69			croak ("Convert::Scalar::utf8_on called on read only scalar");
70
71	root	1.1	SvGETMAGIC (scalar);
72			SvUTF8_on (scalar);
73	root	1.6	RETCOPY (scalar);
74	root	1.1
75			void
76	root	1.10	utf8_off (SV *scalar)
77	root	1.1	PPCODE:
78	root	1.3	if (SvREADONLY (scalar))
79			croak ("Convert::Scalar::utf8_off called on read only scalar");
80
81	root	1.1	SvGETMAGIC (scalar);
82			SvUTF8_off (scalar);
83	root	1.6	RETCOPY (scalar);
84	root	1.1
85			int
86	root	1.10	utf8_valid (SV *scalar)
87	root	1.1	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	root	1.10	utf8_upgrade (SV *scalar)
96	root	1.1	PPCODE:
97	root	1.3	if (SvREADONLY (scalar))
98			croak ("Convert::Scalar::utf8_upgrade called on read only scalar");
99
100	root	1.1	sv_utf8_upgrade(scalar);
101	root	1.6	RETCOPY (scalar);
102	root	1.1
103			bool
104	root	1.10	utf8_downgrade (SV *scalar, bool fail_ok = 0)
105	root	1.1	CODE:
106	root	1.3	if (SvREADONLY (scalar))
107			croak ("Convert::Scalar::utf8_downgrade called on read only scalar");
108
109	root	1.9	RETVAL = !!sv_utf8_downgrade (scalar, fail_ok);
110	root	1.1	OUTPUT:
111			RETVAL
112
113			void
114	root	1.10	utf8_encode (SV *scalar)
115	root	1.1	PPCODE:
116	root	1.3	if (SvREADONLY (scalar))
117			croak ("Convert::Scalar::utf8_encode called on read only scalar");
118
119	root	1.1	sv_utf8_encode (scalar);
120	root	1.6	RETCOPY (scalar);
121	root	1.1
122			UV
123	root	1.10	utf8_length (SV *scalar)
124	root	1.1	CODE:
125	root	1.4	RETVAL = (UV) utf8_length (SvPV_nolen (scalar), SvEND (scalar));
126	root	1.1	OUTPUT:
127			RETVAL
128
129	root	1.10	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	root	1.1	void
144	root	1.10	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	root	1.1	CODE:
156			sv_unmagic (scalar, type);
157
158			void
159	root	1.10	weaken (SV *scalar)
160	root	1.1	CODE:
161			sv_rvweaken (scalar);
162
163			void
164	root	1.10	taint (SV *scalar)
165	root	1.1	CODE:
166			SvTAINTED_on (scalar);
167
168	root	1.9	bool
169	root	1.10	tainted (SV *scalar)
170	root	1.1	CODE:
171	root	1.9	RETVAL = !!SvTAINTED (scalar);
172	root	1.1	OUTPUT:
173			RETVAL
174
175			void
176	root	1.10	untaint (SV *scalar)
177	root	1.1	CODE:
178			SvTAINTED_off (scalar);
179
180	root	1.10	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	root	1.1	void
190	root	1.10	grow (SV *scalar, STRLEN newlen)
191	root	1.1	PPCODE:
192			sv_grow (scalar, newlen);
193			if (GIMME_V != G_VOID)
194			XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
195
196	root	1.10	void
197	root	1.12	extend (SV *scalar, STRLEN addlen = 64)
198	root	1.10	PPCODE:
199			{
200	root	1.12	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	root	1.10
220	root	1.12	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	root	1.10	{
242	root	1.12	STRLEN rem = count - RETVAL;
243
244			if (!rem)
245			break;
246	root	1.10
247	root	1.12	STRLEN got = PerlLIO_read (fd, SvPVX (scalar) + RETVAL, rem);
248	root	1.10
249	root	1.12	if (got == 0)
250			break;
251			else if (got < 0)
252			if (RETVAL)
253			break;
254			else
255			XSRETURN_UNDEF;
256	root	1.10
257	root	1.12	RETVAL += got;
258			}
259	root	1.10
260	root	1.12	SvCUR_set (scalar, RETVAL);
261			}
262			OUTPUT: RETVAL
263	root	1.10
264	root	1.12	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	root	1.10	}
291			}
292	root	1.12	OUTPUT: RETVAL
293	root	1.10
294	root	1.2	int
295	root	1.10	refcnt (SV *scalar, U32 newrefcnt = NO_INIT)
296	root	1.2	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	root	1.10	refcnt_inc (SV *scalar)
312	root	1.2	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	root	1.10	refcnt_dec (SV *scalar)
324	root	1.2	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	root	1.5
334			bool
335	root	1.10	ok (SV *scalar)
336	root	1.5	CODE:
337	root	1.9	RETVAL = !!SvOK (scalar);
338	root	1.5	OUTPUT:
339			RETVAL
340
341			bool
342	root	1.10	uok (SV *scalar)
343	root	1.5	CODE:
344	root	1.9	RETVAL = !!SvUOK (scalar);
345	root	1.5	OUTPUT:
346			RETVAL
347
348			bool
349	root	1.10	rok (SV *scalar)
350	root	1.5	CODE:
351	root	1.9	RETVAL = !!SvROK (scalar);
352	root	1.5	OUTPUT:
353			RETVAL
354
355			bool
356	root	1.10	pok (SV *scalar)
357	root	1.5	CODE:
358	root	1.9	RETVAL = !!SvPOK (scalar);
359	root	1.5	OUTPUT:
360			RETVAL
361
362			bool
363	root	1.10	nok (SV *scalar)
364	root	1.5	CODE:
365	root	1.9	RETVAL = !!SvNOK (scalar);
366	root	1.5	OUTPUT:
367			RETVAL
368
369			bool
370	root	1.10	niok (SV *scalar)
371	root	1.5	CODE:
372	root	1.9	RETVAL = !!SvNIOK (scalar);
373	root	1.5	OUTPUT:
374			RETVAL
375