This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
PATCH: [perl #132548] regcomp.c Fix memory leak
[perl5.git] / dist / Devel-PPPort / parts / inc / misc
CommitLineData
adfe19db
MHM
1################################################################################
2##
b2049988 3## Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db
MHM
4## Version 2.x, Copyright (C) 2001, Paul Marquess.
5## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
6##
7## This program is free software; you can redistribute it and/or
8## modify it under the same terms as Perl itself.
9##
10################################################################################
11
12=provides
13
14__UNDEFINED__
15PERL_UNUSED_DECL
f2ab5a41
MHM
16PERL_UNUSED_ARG
17PERL_UNUSED_VAR
18PERL_UNUSED_CONTEXT
94e22bd6 19PERL_UNUSED_RESULT
a745474a 20PERL_GCC_BRACE_GROUPS_FORBIDDEN
c07deaaf 21PERL_USE_GCC_BRACE_GROUPS
9c0a17a0
MHM
22PERLIO_FUNCS_DECL
23PERLIO_FUNCS_CAST
adfe19db
MHM
24NVTYPE
25INT2PTR
26PTRV
27NUM2PTR
c83e6f19 28PERL_HASH
adfe19db
MHM
29PTR2IV
30PTR2UV
31PTR2NV
32PTR2ul
a745474a
MHM
33START_EXTERN_C
34END_EXTERN_C
35EXTERN_C
36STMT_START
37STMT_END
679ad62d 38UTF8_MAXBYTES
b2049988 39WIDEST_UTYPE
0d0f8426 40XSRETURN
ea4b7f32 41HeUTF8
94e22bd6
MH
42C_ARRAY_LENGTH
43C_ARRAY_END
44SvRX
45SvRXOK
46PERL_MAGIC_qr
47cBOOL
48OpHAS_SIBLING
49OpSIBLING
50OpMORESIB_set
51OpLASTSIB_set
52OpMAYBESIB_set
adfe19db
MHM
53
54=implementation
55
94e22bd6
MH
56__UNDEFINED__ PERL_MAGIC_qr 'r'
57
58__UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
59__UNDEFINED__ OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
60__UNDEFINED__ OpSIBLING(o) (0 + (o)->op_sibling)
61__UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
62__UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
63__UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
64
65#ifndef SvRX
66#if { NEED SvRX }
67
68void *
69SvRX(pTHX_ SV *rv)
70{
71 if (SvROK(rv)) {
72 SV *sv = SvRV(rv);
73 if (SvMAGICAL(sv)) {
74 MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
75 if (mg && mg->mg_obj) {
76 return mg->mg_obj;
77 }
78 }
79 }
80 return 0;
81}
82#endif
83#endif
84
85__UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))
86
62093c1c
NC
87#ifndef PERL_UNUSED_DECL
88# ifdef HASATTRIBUTE
89# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
90# define PERL_UNUSED_DECL
91# else
92# define PERL_UNUSED_DECL __attribute__((unused))
93# endif
adfe19db 94# else
62093c1c 95# define PERL_UNUSED_DECL
adfe19db 96# endif
adfe19db
MHM
97#endif
98
f2ab5a41
MHM
99#ifndef PERL_UNUSED_ARG
100# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
101# include <note.h>
102# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
103# else
104# define PERL_UNUSED_ARG(x) ((void)x)
105# endif
106#endif
107
108#ifndef PERL_UNUSED_VAR
109# define PERL_UNUSED_VAR(x) ((void)x)
110#endif
111
112#ifndef PERL_UNUSED_CONTEXT
113# ifdef USE_ITHREADS
114# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
115# else
116# define PERL_UNUSED_CONTEXT
117# endif
118#endif
119
94e22bd6
MH
120#ifndef PERL_UNUSED_RESULT
121# if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
122# define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
123# else
124# define PERL_UNUSED_RESULT(v) ((void)(v))
125# endif
126#endif
127
f2ab5a41
MHM
128__UNDEFINED__ NOOP /*EMPTY*/(void)0
129__UNDEFINED__ dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
adfe19db
MHM
130
131#ifndef NVTYPE
132# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
133# define NVTYPE long double
134# else
135# define NVTYPE double
136# endif
137typedef NVTYPE NV;
138#endif
139
140#ifndef INT2PTR
adfe19db
MHM
141# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
142# define PTRV UV
143# define INT2PTR(any,d) (any)(d)
144# else
145# if PTRSIZE == LONGSIZE
146# define PTRV unsigned long
147# else
148# define PTRV unsigned
149# endif
150# define INT2PTR(any,d) (any)(PTRV)(d)
151# endif
7bb03b24 152#endif
adfe19db 153
7bb03b24 154#ifndef PTR2ul
adfe19db
MHM
155# if PTRSIZE == LONGSIZE
156# define PTR2ul(p) (unsigned long)(p)
157# else
4a582685 158# define PTR2ul(p) INT2PTR(unsigned long,p)
adfe19db 159# endif
7bb03b24 160#endif
adfe19db 161
7bb03b24
MHM
162__UNDEFINED__ PTR2nat(p) (PTRV)(p)
163__UNDEFINED__ NUM2PTR(any,d) (any)PTR2nat(d)
164__UNDEFINED__ PTR2IV(p) INT2PTR(IV,p)
165__UNDEFINED__ PTR2UV(p) INT2PTR(UV,p)
166__UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p)
adfe19db 167
a745474a
MHM
168#undef START_EXTERN_C
169#undef END_EXTERN_C
170#undef EXTERN_C
171#ifdef __cplusplus
172# define START_EXTERN_C extern "C" {
173# define END_EXTERN_C }
174# define EXTERN_C extern "C"
175#else
176# define START_EXTERN_C
177# define END_EXTERN_C
178# define EXTERN_C extern
179#endif
180
c07deaaf
MHM
181#if defined(PERL_GCC_PEDANTIC)
182# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a
MHM
183# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
184# endif
185#endif
186
c07deaaf
MHM
187#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
188# ifndef PERL_USE_GCC_BRACE_GROUPS
189# define PERL_USE_GCC_BRACE_GROUPS
190# endif
191#endif
192
a745474a
MHM
193#undef STMT_START
194#undef STMT_END
c07deaaf 195#ifdef PERL_USE_GCC_BRACE_GROUPS
b2049988
MHM
196# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
197# define STMT_END )
a745474a
MHM
198#else
199# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
b2049988
MHM
200# define STMT_START if (1)
201# define STMT_END else (void)0
a745474a 202# else
b2049988
MHM
203# define STMT_START do
204# define STMT_END while (0)
a745474a
MHM
205# endif
206#endif
207
adfe19db
MHM
208__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
209
210/* DEFSV appears first in 5.004_56 */
b2049988 211__UNDEFINED__ DEFSV GvSV(PL_defgv)
adfe19db 212__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
ac2e3cea 213__UNDEFINED__ DEFSV_set(sv) (DEFSV = (sv))
adfe19db
MHM
214
215/* Older perls (<=5.003) lack AvFILLp */
216__UNDEFINED__ AvFILLp AvFILL
217
218__UNDEFINED__ ERRSV get_sv("@",FALSE)
219
adfe19db
MHM
220/* Hint: gv_stashpvn
221 * This function's backport doesn't support the length parameter, but
222 * rather ignores it. Portability can only be ensured if the length
223 * parameter is used for speed reasons, but the length can always be
224 * correctly computed from the string argument.
225 */
226
227__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
228
229/* Replace: 1 */
230__UNDEFINED__ get_cv perl_get_cv
231__UNDEFINED__ get_sv perl_get_sv
232__UNDEFINED__ get_av perl_get_av
233__UNDEFINED__ get_hv perl_get_hv
234/* Replace: 0 */
235
adfe19db
MHM
236__UNDEFINED__ dUNDERBAR dNOOP
237__UNDEFINED__ UNDERBAR DEFSV
238
239__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
240__UNDEFINED__ dITEMS I32 items = SP - MARK
241
9132e1a3
MHM
242__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
243
0d0f8426
MHM
244__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
245 register SV ** const mark = PL_stack_base + ax++
246
247
248__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
249
250#if { VERSION < 5.005 }
251# undef XSRETURN
252# define XSRETURN(off) \
253 STMT_START { \
254 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
255 return; \
256 } STMT_END
257#endif
258
8565c31a
MHM
259__UNDEFINED__ XSPROTO(name) void name(pTHX_ CV* cv)
260__UNDEFINED__ SVfARG(p) ((void*)(p))
261
f2ab5a41
MHM
262__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
263
264__UNDEFINED__ dVAR dNOOP
265
266__UNDEFINED__ SVf "_"
267
c83e6f19
MHM
268__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
269
fd7af155
MHM
270__UNDEFINED__ CPERLscope(x) x
271
c83e6f19 272__UNDEFINED__ PERL_HASH(hash,str,len) \
b2049988
MHM
273 STMT_START { \
274 const char *s_PeRlHaSh = str; \
275 I32 i_PeRlHaSh = len; \
276 U32 hash_PeRlHaSh = 0; \
277 while (i_PeRlHaSh--) \
278 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
279 (hash) = hash_PeRlHaSh; \
c83e6f19 280 } STMT_END
679ad62d 281
9c0a17a0
MHM
282#ifndef PERLIO_FUNCS_DECL
283# ifdef PERLIO_FUNCS_CONST
284# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
285# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
286# else
287# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
288# define PERLIO_FUNCS_CAST(funcs) (funcs)
289# endif
290#endif
291
fd7af155
MHM
292/* provide these typedefs for older perls */
293#if { VERSION < 5.9.3 }
294
295# ifdef ARGSproto
296typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
297# else
298typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
299# endif
300
301typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
302
303#endif
304
b2049988
MHM
305__UNDEFINED__ isPSXSPC(c) (isSPACE(c) || (c) == '\v')
306__UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t')
db42c902 307#ifdef EBCDIC
b2049988
MHM
308__UNDEFINED__ isALNUMC(c) isalnum(c)
309__UNDEFINED__ isASCII(c) isascii(c)
310__UNDEFINED__ isCNTRL(c) iscntrl(c)
311__UNDEFINED__ isGRAPH(c) isgraph(c)
312__UNDEFINED__ isPRINT(c) isprint(c)
313__UNDEFINED__ isPUNCT(c) ispunct(c)
314__UNDEFINED__ isXDIGIT(c) isxdigit(c)
db42c902
MHM
315#else
316# if { VERSION < 5.10.0 }
317/* Hint: isPRINT
318 * The implementation in older perl versions includes all of the
319 * isSPACE() characters, which is wrong. The version provided by
320 * Devel::PPPort always overrides a present buggy version.
321 */
322# undef isPRINT
323# endif
b2049988
MHM
324
325#ifdef HAS_QUAD
744ef08f
CBW
326# ifdef U64TYPE
327# define WIDEST_UTYPE U64TYPE
328# else
329# define WIDEST_UTYPE Quad_t
330# endif
b2049988
MHM
331#else
332# define WIDEST_UTYPE U32
333#endif
334
335__UNDEFINED__ isALNUMC(c) (isALPHA(c) || isDIGIT(c))
336__UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
337__UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
338__UNDEFINED__ isGRAPH(c) (isALNUM(c) || isPUNCT(c))
339__UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127))
340__UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
341__UNDEFINED__ isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
db42c902
MHM
342#endif
343
ea4b7f32
JH
344/* Until we figure out how to support this in older perls... */
345#if { VERSION >= 5.8.0 }
346
347__UNDEFINED__ HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
348 SvUTF8(HeKEY_sv(he)) : \
349 (U32)HeKUTF8(he))
350
351#endif
352
94e22bd6
MH
353__UNDEFINED__ C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
354__UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
355
9132e1a3
MHM
356=xsmisc
357
8565c31a
MHM
358typedef XSPROTO(XSPROTO_test_t);
359typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
360
9132e1a3
MHM
361XS(XS_Devel__PPPort_dXSTARG); /* prototype */
362XS(XS_Devel__PPPort_dXSTARG)
363{
364 dXSARGS;
365 dXSTARG;
2dd69576 366 IV iv;
e7368224
MH
367
368 PERL_UNUSED_VAR(cv);
9132e1a3 369 SP -= items;
2dd69576 370 iv = SvIV(ST(0)) + 1;
9132e1a3
MHM
371 PUSHi(iv);
372 XSRETURN(1);
373}
374
0d0f8426
MHM
375XS(XS_Devel__PPPort_dAXMARK); /* prototype */
376XS(XS_Devel__PPPort_dAXMARK)
377{
378 dSP;
379 dAXMARK;
380 dITEMS;
381 IV iv;
e7368224
MH
382
383 PERL_UNUSED_VAR(cv);
0d0f8426
MHM
384 SP -= items;
385 iv = SvIV(ST(0)) - 1;
c1a049cb 386 mPUSHi(iv);
0d0f8426
MHM
387 XSRETURN(1);
388}
389
94e22bd6
MH
390=xsinit
391
392#define NEED_SvRX
393
9132e1a3
MHM
394=xsboot
395
8565c31a
MHM
396{
397 XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
398 newXS("Devel::PPPort::dXSTARG", *p, file);
399}
0d0f8426 400newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 401
adfe19db
MHM
402=xsubs
403
404int
94e22bd6
MH
405OpSIBLING_tests()
406 PREINIT:
407 OP *x;
408 OP *kid;
409 OP *lastkid;
410 int count = 0;
411 int failures = 0;
412 int i;
413 CODE:
414 x = newOP(OP_PUSHMARK, 0);
415
416 /* No siblings yet! */
417 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
418 failures++; warn("Op should not have had a sib");
419 }
420
421
422 /* Add 2 siblings */
423 kid = x;
424
425 for (i = 0; i < 2; i++) {
426 OP *newsib = newOP(OP_PUSHMARK, 0);
427 OpMORESIB_set(kid, newsib);
428
429 kid = OpSIBLING(kid);
430 lastkid = kid;
431 }
432
433 /* Should now have a sibling */
434 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
435 failures++; warn("Op should have had a sib after moresib_set");
436 }
437
438 /* Count the siblings */
439 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
440 count++;
441 }
442
443 if (count != 2) {
444 failures++; warn("Kid had %d sibs, expected 2", count);
445 }
446
447 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
448 failures++; warn("Last kid should not have a sib");
449 }
450
451 /* Really sets the parent, and says 'no more siblings' */
452 OpLASTSIB_set(x, lastkid);
453
454 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
455 failures++; warn("OpLASTSIB_set failed?");
456 }
457
458 /* Restore the kid */
459 OpMORESIB_set(x, lastkid);
460
461 /* Try to remove it again */
462 OpLASTSIB_set(x, NULL);
463
464 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
465 failures++; warn("OpLASTSIB_set with NULL failed?");
466 }
467
468 /* Try to restore with maybesib_set */
469 OpMAYBESIB_set(x, lastkid, NULL);
470
471 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
472 failures++; warn("Op should have had a sib after maybesibset");
473 }
474
475 RETVAL = failures;
476 OUTPUT:
477 RETVAL
478
479int
480SvRXOK(sv)
481 SV *sv
482 CODE:
483 RETVAL = SvRXOK(sv);
484 OUTPUT:
485 RETVAL
486
487int
7bb03b24 488ptrtests()
b2049988
MHM
489 PREINIT:
490 int var, *p = &var;
7bb03b24 491
b2049988
MHM
492 CODE:
493 RETVAL = 0;
494 RETVAL += PTR2nat(p) != 0 ? 1 : 0;
495 RETVAL += PTR2ul(p) != 0UL ? 2 : 0;
496 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0;
497 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0;
498 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0;
499 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
7bb03b24 500
b2049988
MHM
501 OUTPUT:
502 RETVAL
7bb03b24
MHM
503
504int
adfe19db 505gv_stashpvn(name, create)
b2049988
MHM
506 char *name
507 I32 create
508 CODE:
509 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
510 OUTPUT:
511 RETVAL
adfe19db
MHM
512
513int
514get_sv(name, create)
b2049988
MHM
515 char *name
516 I32 create
517 CODE:
518 RETVAL = get_sv(name, create) != NULL;
519 OUTPUT:
520 RETVAL
adfe19db
MHM
521
522int
523get_av(name, create)
b2049988
MHM
524 char *name
525 I32 create
526 CODE:
527 RETVAL = get_av(name, create) != NULL;
528 OUTPUT:
529 RETVAL
adfe19db
MHM
530
531int
532get_hv(name, create)
b2049988
MHM
533 char *name
534 I32 create
535 CODE:
536 RETVAL = get_hv(name, create) != NULL;
537 OUTPUT:
538 RETVAL
adfe19db
MHM
539
540int
541get_cv(name, create)
b2049988
MHM
542 char *name
543 I32 create
544 CODE:
545 RETVAL = get_cv(name, create) != NULL;
546 OUTPUT:
547 RETVAL
adfe19db
MHM
548
549void
0d0f8426 550xsreturn(two)
b2049988
MHM
551 int two
552 PPCODE:
553 mXPUSHp("test1", 5);
554 if (two)
555 mXPUSHp("test2", 5);
556 if (two)
557 XSRETURN(2);
558 else
559 XSRETURN(1);
0d0f8426 560
adfe19db
MHM
561SV*
562boolSV(value)
b2049988
MHM
563 int value
564 CODE:
565 RETVAL = newSVsv(boolSV(value));
566 OUTPUT:
567 RETVAL
adfe19db
MHM
568
569SV*
570DEFSV()
b2049988
MHM
571 CODE:
572 RETVAL = newSVsv(DEFSV);
573 OUTPUT:
574 RETVAL
adfe19db 575
51d6c659
MHM
576void
577DEFSV_modify()
b2049988
MHM
578 PPCODE:
579 XPUSHs(sv_mortalcopy(DEFSV));
580 ENTER;
581 SAVE_DEFSV;
582 DEFSV_set(newSVpvs("DEFSV"));
583 XPUSHs(sv_mortalcopy(DEFSV));
584 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
585 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
586 /* sv_2mortal(DEFSV); */
587 LEAVE;
588 XPUSHs(sv_mortalcopy(DEFSV));
589 XSRETURN(3);
51d6c659 590
adfe19db
MHM
591int
592ERRSV()
b2049988
MHM
593 CODE:
594 RETVAL = SvTRUE(ERRSV);
595 OUTPUT:
596 RETVAL
adfe19db
MHM
597
598SV*
599UNDERBAR()
b2049988
MHM
600 CODE:
601 {
602 dUNDERBAR;
603 RETVAL = newSVsv(UNDERBAR);
604 }
605 OUTPUT:
606 RETVAL
adfe19db 607
0d0f8426
MHM
608void
609prepush()
b2049988
MHM
610 CODE:
611 {
612 dXSTARG;
613 XSprePUSH;
614 PUSHi(42);
615 XSRETURN(1);
616 }
0d0f8426 617
f2ab5a41
MHM
618int
619PERL_ABS(a)
b2049988 620 int a
f2ab5a41
MHM
621
622void
623SVf(x)
b2049988
MHM
624 SV *x
625 PPCODE:
f2ab5a41 626#if { VERSION >= 5.004 }
b2049988 627 x = sv_2mortal(newSVpvf("[%"SVf"]", SVfARG(x)));
f2ab5a41 628#endif
b2049988
MHM
629 XPUSHs(x);
630 XSRETURN(1);
f2ab5a41 631
fd7af155
MHM
632void
633Perl_ppaddr_t(string)
b2049988
MHM
634 char *string
635 PREINIT:
636 Perl_ppaddr_t lower;
637 PPCODE:
638 lower = PL_ppaddr[OP_LC];
639 mXPUSHs(newSVpv(string, 0));
640 PUTBACK;
641 ENTER;
642 (void)*(lower)(aTHXR);
643 SPAGAIN;
644 LEAVE;
645 XSRETURN(1);
fd7af155 646
ea4b7f32
JH
647#if { VERSION >= 5.8.0 }
648
649void
650check_HeUTF8(utf8_key)
651 SV *utf8_key;
652 PREINIT:
653 HV *hash;
654 HE *ent;
655 STRLEN klen;
656 char *key;
657 PPCODE:
658 hash = newHV();
659
660 key = SvPV(utf8_key, klen);
661 if (SvUTF8(utf8_key)) klen *= -1;
662 hv_store(hash, key, klen, newSVpvs("string"), 0);
663 hv_iterinit(hash);
664 ent = hv_iternext(hash);
94e22bd6
MH
665 assert(ent);
666 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
ea4b7f32
JH
667 hv_undef(hash);
668
669
670#endif
671
94e22bd6
MH
672void
673check_c_array()
674 PREINIT:
675 int x[] = { 10, 11, 12, 13 };
676 PPCODE:
677 mXPUSHi(C_ARRAY_LENGTH(x)); /* 4 */
678 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
679
680=tests plan => 48
adfe19db
MHM
681
682use vars qw($my_sv @my_av %my_hv);
683
adfe19db
MHM
684ok(&Devel::PPPort::boolSV(1));
685ok(!&Devel::PPPort::boolSV(0));
686
687$_ = "Fred";
688ok(&Devel::PPPort::DEFSV(), "Fred");
689ok(&Devel::PPPort::UNDERBAR(), "Fred");
690
94e22bd6 691if ($] >= 5.009002 && $] < 5.023 && $] < 5.023004) {
0d0f8426 692 eval q{
b2049988 693 no warnings "deprecated";
e5b2cbd0 694 no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
0d0f8426
MHM
695 my $_ = "Tony";
696 ok(&Devel::PPPort::DEFSV(), "Fred");
697 ok(&Devel::PPPort::UNDERBAR(), "Tony");
698 };
699}
700else {
701 ok(1);
702 ok(1);
703}
704
51d6c659
MHM
705my @r = &Devel::PPPort::DEFSV_modify();
706
707ok(@r == 3);
708ok($r[0], 'Fred');
709ok($r[1], 'DEFSV');
710ok($r[2], 'Fred');
711
712ok(&Devel::PPPort::DEFSV(), "Fred");
713
adfe19db
MHM
714eval { 1 };
715ok(!&Devel::PPPort::ERRSV());
716eval { cannot_call_this_one() };
717ok(&Devel::PPPort::ERRSV());
718
719ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
720ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
721ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
722
723$my_sv = 1;
724ok(&Devel::PPPort::get_sv('my_sv', 0));
725ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
726ok(&Devel::PPPort::get_sv('not_my_sv', 1));
727
728@my_av = (1);
729ok(&Devel::PPPort::get_av('my_av', 0));
730ok(!&Devel::PPPort::get_av('not_my_av', 0));
731ok(&Devel::PPPort::get_av('not_my_av', 1));
732
733%my_hv = (a=>1);
734ok(&Devel::PPPort::get_hv('my_hv', 0));
735ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
736ok(&Devel::PPPort::get_hv('not_my_hv', 1));
737
738sub my_cv { 1 };
739ok(&Devel::PPPort::get_cv('my_cv', 0));
740ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
741ok(&Devel::PPPort::get_cv('not_my_cv', 1));
742
9132e1a3 743ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426
MHM
744ok(Devel::PPPort::dAXMARK(4711), 4710);
745
746ok(Devel::PPPort::prepush(), 42);
9132e1a3 747
0d0f8426
MHM
748ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
749ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41
MHM
750
751ok(Devel::PPPort::PERL_ABS(42), 42);
752ok(Devel::PPPort::PERL_ABS(-13), 13);
753
754ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
755ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
756
fd7af155
MHM
757ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
758
7bb03b24 759ok(&Devel::PPPort::ptrtests(), 63);
ea4b7f32 760
94e22bd6
MH
761ok(&Devel::PPPort::OpSIBLING_tests(), 0);
762
ea4b7f32
JH
763if ($] >= 5.009000) {
764 eval q{
765 ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
766 ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
767 };
768} else {
769 ok(1, 1);
770 ok(1, 1);
771}
94e22bd6
MH
772
773@r = &Devel::PPPort::check_c_array();
774ok($r[0], 4);
775ok($r[1], "13");
776
777ok(!Devel::PPPort::SvRXOK(""));
778ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
779
780if ($] < 5.005) {
781 skip 'no qr// objects in this perl', 0;
782 skip 'no qr// objects in this perl', 0;
783} else {
784 my $qr = eval 'qr/./';
785 ok(Devel::PPPort::SvRXOK($qr));
786 ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
787}