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);             \
    }

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

bool
utf8 (SV *scalar, SV *mode = NO_INIT)
        PROTOTYPE: $;$
        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)
        PROTOTYPE: $
        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)
        PROTOTYPE: $
        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)
        PROTOTYPE: $
        CODE:
        STRLEN len;
        char *str = SvPV (scalar, len);
        RETVAL = !!is_utf8_string (str, len);
        OUTPUT:
        RETVAL

void
utf8_upgrade (SV *scalar)
        PROTOTYPE: $
        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)
        PROTOTYPE: $;$
        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)
        PROTOTYPE: $
        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)
        PROTOTYPE: $
        CODE:
        RETVAL = (UV) utf8_length (SvPV_nolen (scalar), SvEND (scalar));
        OUTPUT:
        RETVAL

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

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

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

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

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

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

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

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

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

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

void
extend (SV *scalar, STRLEN addlen)
        PROTOTYPE: $$
        PPCODE:
{
        if (SvTYPE (scalar) < SVt_PV)
          sv_upgrade (scalar, SVt_PV);

        if (SvCUR (scalar) + addlen >= SvLEN (scalar))
          {
            STRLEN l = SvLEN (scalar);
            STRLEN o = SvCUR (scalar) + 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 (SvCUR (scalar) + addlen >= l)
              l <<= 1;

            l -= o;

            sv_grow (scalar, l);
          }

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

int
refcnt (SV *scalar, U32 newrefcnt = NO_INIT)
        PROTOTYPE: $;$
        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
        PROTOTYPE: $
        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
        PROTOTYPE: $
        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)
        PROTOTYPE: $
        CODE:
        RETVAL = !!SvOK (scalar);
        OUTPUT:
        RETVAL

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

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

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

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

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

Revision:	1.10
Committed:	Thu Aug 18 19:07:04 2011 UTC (15 years, 1 month ago) by root
Branch:	MAIN
CVS Tags:	rel-1_1
Changes since 1.9:	+91 -51 lines
Log Message:	* empty log message *
#	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			{ \
8			dXSTARG; \
9			sv_setsv (TARG, (sv)); \
10			EXTEND (SP, 1); \
11			PUSHs (TARG); \
12			}
13
14	root	1.1	MODULE = Convert::Scalar PACKAGE = Convert::Scalar
15
16	root	1.7	bool
17	root	1.10	utf8 (SV scalar, SV mode = NO_INIT)
18	root	1.1	PROTOTYPE: $;$
19			CODE:
20			SvGETMAGIC (scalar);
21			RETVAL = !!SvUTF8 (scalar);
22			if (items > 1)
23			{
24	root	1.3	if (SvREADONLY (scalar))
25			croak ("Convert::Scalar::utf8 called on read only scalar");
26	root	1.1	if (SvTRUE (mode))
27			SvUTF8_on (scalar);
28			else
29			SvUTF8_off (scalar);
30			}
31			OUTPUT:
32			RETVAL
33
34			void
35	root	1.10	utf8_on (SV *scalar)
36	root	1.1	PROTOTYPE: $
37			PPCODE:
38	root	1.3	if (SvREADONLY (scalar))
39			croak ("Convert::Scalar::utf8_on called on read only scalar");
40
41	root	1.1	SvGETMAGIC (scalar);
42			SvUTF8_on (scalar);
43	root	1.6	RETCOPY (scalar);
44	root	1.1
45			void
46	root	1.10	utf8_off (SV *scalar)
47	root	1.1	PROTOTYPE: $
48			PPCODE:
49	root	1.3	if (SvREADONLY (scalar))
50			croak ("Convert::Scalar::utf8_off called on read only scalar");
51
52	root	1.1	SvGETMAGIC (scalar);
53			SvUTF8_off (scalar);
54	root	1.6	RETCOPY (scalar);
55	root	1.1
56			int
57	root	1.10	utf8_valid (SV *scalar)
58	root	1.1	PROTOTYPE: $
59			CODE:
60			STRLEN len;
61			char *str = SvPV (scalar, len);
62			RETVAL = !!is_utf8_string (str, len);
63			OUTPUT:
64			RETVAL
65
66			void
67	root	1.10	utf8_upgrade (SV *scalar)
68	root	1.1	PROTOTYPE: $
69			PPCODE:
70	root	1.3	if (SvREADONLY (scalar))
71			croak ("Convert::Scalar::utf8_upgrade called on read only scalar");
72
73	root	1.1	sv_utf8_upgrade(scalar);
74	root	1.6	RETCOPY (scalar);
75	root	1.1
76			bool
77	root	1.10	utf8_downgrade (SV *scalar, bool fail_ok = 0)
78	root	1.1	PROTOTYPE: $;$
79			CODE:
80	root	1.3	if (SvREADONLY (scalar))
81			croak ("Convert::Scalar::utf8_downgrade called on read only scalar");
82
83	root	1.9	RETVAL = !!sv_utf8_downgrade (scalar, fail_ok);
84	root	1.1	OUTPUT:
85			RETVAL
86
87			void
88	root	1.10	utf8_encode (SV *scalar)
89	root	1.1	PROTOTYPE: $
90			PPCODE:
91	root	1.3	if (SvREADONLY (scalar))
92			croak ("Convert::Scalar::utf8_encode called on read only scalar");
93
94	root	1.1	sv_utf8_encode (scalar);
95	root	1.6	RETCOPY (scalar);
96	root	1.1
97			UV
98	root	1.10	utf8_length (SV *scalar)
99	root	1.1	PROTOTYPE: $
100			CODE:
101	root	1.4	RETVAL = (UV) utf8_length (SvPV_nolen (scalar), SvEND (scalar));
102	root	1.1	OUTPUT:
103			RETVAL
104
105	root	1.10	bool
106			readonly (SV scalar, SV on = NO_INIT)
107			PROTOTYPE: $;$
108			CODE:
109			RETVAL = SvREADONLY (scalar);
110			if (items > 1)
111			{
112			if (SvTRUE (on))
113			SvREADONLY_on (scalar);
114			else
115			SvREADONLY_off (scalar);
116			}
117			OUTPUT:
118			RETVAL
119
120	root	1.1	void
121	root	1.10	readonly_on (SV *scalar)
122			PROTOTYPE: $
123			CODE:
124			SvREADONLY_on (scalar);
125
126			void
127			readonly_off (SV *scalar)
128			PROTOTYPE: $
129			CODE:
130			SvREADONLY_off (scalar);
131
132			void
133			unmagic (SV *scalar, char type)
134	root	1.1	PROTOTYPE: $
135			CODE:
136			sv_unmagic (scalar, type);
137
138			void
139	root	1.10	weaken (SV *scalar)
140	root	1.1	PROTOTYPE: $
141			CODE:
142			sv_rvweaken (scalar);
143
144			void
145	root	1.10	taint (SV *scalar)
146	root	1.1	PROTOTYPE: $
147			CODE:
148			SvTAINTED_on (scalar);
149
150	root	1.9	bool
151	root	1.10	tainted (SV *scalar)
152	root	1.1	PROTOTYPE: $
153			CODE:
154	root	1.9	RETVAL = !!SvTAINTED (scalar);
155	root	1.1	OUTPUT:
156			RETVAL
157
158			void
159	root	1.10	untaint (SV *scalar)
160	root	1.1	PROTOTYPE: $
161			CODE:
162			SvTAINTED_off (scalar);
163
164	root	1.10	STRLEN
165			len (SV *scalar)
166			PROTOTYPE: $
167			CODE:
168			if (SvTYPE (scalar) < SVt_PV)
169			XSRETURN_UNDEF;
170			RETVAL = SvLEN (scalar);
171			OUTPUT:
172			RETVAL
173
174	root	1.1	void
175	root	1.10	grow (SV *scalar, STRLEN newlen)
176	root	1.1	PROTOTYPE: $$
177			PPCODE:
178			sv_grow (scalar, newlen);
179			if (GIMME_V != G_VOID)
180			XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
181
182	root	1.10	void
183			extend (SV *scalar, STRLEN addlen)
184			PROTOTYPE: $$
185			PPCODE:
186			{
187			if (SvTYPE (scalar) < SVt_PV)
188			sv_upgrade (scalar, SVt_PV);
189
190			if (SvCUR (scalar) + addlen >= SvLEN (scalar))
191			{
192			STRLEN l = SvLEN (scalar);
193			STRLEN o = SvCUR (scalar) + addlen >= 4096 ? sizeof (void ) 4 : 0;
194
195			if (l < 64)
196			l = 64;
197
198			/* for big sizes, leave a bit of space for malloc management, and assume 4kb or smaller pages */
199			addlen += o;
200
201			while (SvCUR (scalar) + addlen >= l)
202			l <<= 1;
203
204			l -= o;
205
206			sv_grow (scalar, l);
207			}
208
209			if (GIMME_V != G_VOID)
210			XPUSHs (sv_2mortal (SvREFCNT_inc (scalar)));
211			}
212
213	root	1.2	int
214	root	1.10	refcnt (SV *scalar, U32 newrefcnt = NO_INIT)
215	root	1.2	PROTOTYPE: $;$
216			ALIAS:
217			refcnt_rv = 1
218			CODE:
219			if (ix)
220			{
221			if (!SvROK (scalar)) croak ("refcnt_rv requires a reference as it's first argument");
222			scalar = SvRV (scalar);
223			}
224			RETVAL = SvREFCNT (scalar);
225			if (items > 1)
226			SvREFCNT (scalar) = newrefcnt;
227			OUTPUT:
228			RETVAL
229
230			void
231	root	1.10	refcnt_inc (SV *scalar)
232	root	1.2	ALIAS:
233			refcnt_inc_rv = 1
234			PROTOTYPE: $
235			CODE:
236			if (ix)
237			{
238			if (!SvROK (scalar)) croak ("refcnt_inc_rv requires a reference as it's first argument");
239			scalar = SvRV (scalar);
240			}
241			SvREFCNT_inc (scalar);
242
243			void
244	root	1.10	refcnt_dec (SV *scalar)
245	root	1.2	ALIAS:
246			refcnt_dec_rv = 1
247			PROTOTYPE: $
248			CODE:
249			if (ix)
250			{
251			if (!SvROK (scalar)) croak ("refcnt_dec_rv requires a reference as it's first argument");
252			scalar = SvRV (scalar);
253			}
254			SvREFCNT_dec (scalar);
255	root	1.5
256			bool
257	root	1.10	ok (SV *scalar)
258	root	1.5	PROTOTYPE: $
259			CODE:
260	root	1.9	RETVAL = !!SvOK (scalar);
261	root	1.5	OUTPUT:
262			RETVAL
263
264			bool
265	root	1.10	uok (SV *scalar)
266	root	1.5	PROTOTYPE: $
267			CODE:
268	root	1.9	RETVAL = !!SvUOK (scalar);
269	root	1.5	OUTPUT:
270			RETVAL
271
272			bool
273	root	1.10	rok (SV *scalar)
274	root	1.5	PROTOTYPE: $
275			CODE:
276	root	1.9	RETVAL = !!SvROK (scalar);
277	root	1.5	OUTPUT:
278			RETVAL
279
280			bool
281	root	1.10	pok (SV *scalar)
282	root	1.5	PROTOTYPE: $
283			CODE:
284	root	1.9	RETVAL = !!SvPOK (scalar);
285	root	1.5	OUTPUT:
286			RETVAL
287
288			bool
289	root	1.10	nok (SV *scalar)
290	root	1.5	PROTOTYPE: $
291			CODE:
292	root	1.9	RETVAL = !!SvNOK (scalar);
293	root	1.5	OUTPUT:
294			RETVAL
295
296			bool
297	root	1.10	niok (SV *scalar)
298	root	1.5	PROTOTYPE: $
299			CODE:
300	root	1.9	RETVAL = !!SvNIOK (scalar);
301	root	1.5	OUTPUT:
302			RETVAL
303