This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix leak in Devel-PPPort
[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
94e22bd6
MH
46cBOOL
47OpHAS_SIBLING
48OpSIBLING
49OpMORESIB_set
50OpLASTSIB_set
51OpMAYBESIB_set
58329f0d
S
52MUTABLE_PTR
53MUTABLE_SV
adfe19db
MHM
54
55=implementation
56
94e22bd6
MH
57__UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
58__UNDEFINED__ OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
59__UNDEFINED__ OpSIBLING(o) (0 + (o)->op_sibling)
60__UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
61__UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
62__UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
58329f0d 63__UNDEFINED__ HEf_SVKEY -2
94e22bd6
MH
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 324
111bb900
CB
325#ifndef WIDEST_UTYPE
326# ifdef QUADKIND
327# ifdef U64TYPE
328# define WIDEST_UTYPE U64TYPE
329# else
330# define WIDEST_UTYPE Quad_t
331# endif
744ef08f 332# else
111bb900 333# define WIDEST_UTYPE U32
744ef08f 334# endif
b2049988
MHM
335#endif
336
337__UNDEFINED__ isALNUMC(c) (isALPHA(c) || isDIGIT(c))
338__UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
339__UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
340__UNDEFINED__ isGRAPH(c) (isALNUM(c) || isPUNCT(c))
341__UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127))
342__UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
343__UNDEFINED__ isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
db42c902
MHM
344#endif
345
ea4b7f32
JH
346/* Until we figure out how to support this in older perls... */
347#if { VERSION >= 5.8.0 }
348
349__UNDEFINED__ HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
350 SvUTF8(HeKEY_sv(he)) : \
351 (U32)HeKUTF8(he))
352
353#endif
354
94e22bd6
MH
355__UNDEFINED__ C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
356__UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
357
58329f0d
S
358#ifndef MUTABLE_PTR
359#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
360# define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
361#else
362# define MUTABLE_PTR(p) ((void *) (p))
363#endif
364#endif
365
366__UNDEFINED__ MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
367
9132e1a3
MHM
368=xsmisc
369
8565c31a
MHM
370typedef XSPROTO(XSPROTO_test_t);
371typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
372
9132e1a3
MHM
373XS(XS_Devel__PPPort_dXSTARG); /* prototype */
374XS(XS_Devel__PPPort_dXSTARG)
375{
376 dXSARGS;
377 dXSTARG;
2dd69576 378 IV iv;
e7368224
MH
379
380 PERL_UNUSED_VAR(cv);
9132e1a3 381 SP -= items;
2dd69576 382 iv = SvIV(ST(0)) + 1;
9132e1a3
MHM
383 PUSHi(iv);
384 XSRETURN(1);
385}
386
0d0f8426
MHM
387XS(XS_Devel__PPPort_dAXMARK); /* prototype */
388XS(XS_Devel__PPPort_dAXMARK)
389{
390 dSP;
391 dAXMARK;
392 dITEMS;
393 IV iv;
e7368224
MH
394
395 PERL_UNUSED_VAR(cv);
0d0f8426
MHM
396 SP -= items;
397 iv = SvIV(ST(0)) - 1;
c1a049cb 398 mPUSHi(iv);
0d0f8426
MHM
399 XSRETURN(1);
400}
401
94e22bd6
MH
402=xsinit
403
404#define NEED_SvRX
405
9132e1a3
MHM
406=xsboot
407
8565c31a
MHM
408{
409 XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
410 newXS("Devel::PPPort::dXSTARG", *p, file);
411}
0d0f8426 412newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3 413
adfe19db
MHM
414=xsubs
415
416int
94e22bd6
MH
417OpSIBLING_tests()
418 PREINIT:
419 OP *x;
420 OP *kid;
807c5598 421 OP *middlekid;
94e22bd6
MH
422 OP *lastkid;
423 int count = 0;
424 int failures = 0;
425 int i;
426 CODE:
427 x = newOP(OP_PUSHMARK, 0);
428
429 /* No siblings yet! */
430 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
431 failures++; warn("Op should not have had a sib");
432 }
433
434
435 /* Add 2 siblings */
436 kid = x;
437
438 for (i = 0; i < 2; i++) {
439 OP *newsib = newOP(OP_PUSHMARK, 0);
440 OpMORESIB_set(kid, newsib);
441
442 kid = OpSIBLING(kid);
443 lastkid = kid;
444 }
807c5598 445 middlekid = OpSIBLING(x);
94e22bd6
MH
446
447 /* Should now have a sibling */
448 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
449 failures++; warn("Op should have had a sib after moresib_set");
450 }
451
452 /* Count the siblings */
453 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
454 count++;
455 }
456
457 if (count != 2) {
458 failures++; warn("Kid had %d sibs, expected 2", count);
459 }
460
461 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
462 failures++; warn("Last kid should not have a sib");
463 }
464
465 /* Really sets the parent, and says 'no more siblings' */
466 OpLASTSIB_set(x, lastkid);
467
468 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
469 failures++; warn("OpLASTSIB_set failed?");
470 }
471
472 /* Restore the kid */
473 OpMORESIB_set(x, lastkid);
474
475 /* Try to remove it again */
476 OpLASTSIB_set(x, NULL);
477
478 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
479 failures++; warn("OpLASTSIB_set with NULL failed?");
480 }
481
482 /* Try to restore with maybesib_set */
483 OpMAYBESIB_set(x, lastkid, NULL);
484
485 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
486 failures++; warn("Op should have had a sib after maybesibset");
487 }
488
807c5598
DM
489 op_free(lastkid);
490 op_free(middlekid);
491 op_free(x);
94e22bd6
MH
492 RETVAL = failures;
493 OUTPUT:
494 RETVAL
495
496int
497SvRXOK(sv)
498 SV *sv
499 CODE:
500 RETVAL = SvRXOK(sv);
501 OUTPUT:
502 RETVAL
503
504int
7bb03b24 505ptrtests()
b2049988
MHM
506 PREINIT:
507 int var, *p = &var;
7bb03b24 508
b2049988
MHM
509 CODE:
510 RETVAL = 0;
511 RETVAL += PTR2nat(p) != 0 ? 1 : 0;
512 RETVAL += PTR2ul(p) != 0UL ? 2 : 0;
513 RETVAL += PTR2UV(p) != (UV) 0 ? 4 : 0;
514 RETVAL += PTR2IV(p) != (IV) 0 ? 8 : 0;
515 RETVAL += PTR2NV(p) != (NV) 0 ? 16 : 0;
516 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
7bb03b24 517
b2049988
MHM
518 OUTPUT:
519 RETVAL
7bb03b24
MHM
520
521int
adfe19db 522gv_stashpvn(name, create)
b2049988
MHM
523 char *name
524 I32 create
525 CODE:
526 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
527 OUTPUT:
528 RETVAL
adfe19db
MHM
529
530int
531get_sv(name, create)
b2049988
MHM
532 char *name
533 I32 create
534 CODE:
535 RETVAL = get_sv(name, create) != NULL;
536 OUTPUT:
537 RETVAL
adfe19db
MHM
538
539int
540get_av(name, create)
b2049988
MHM
541 char *name
542 I32 create
543 CODE:
544 RETVAL = get_av(name, create) != NULL;
545 OUTPUT:
546 RETVAL
adfe19db
MHM
547
548int
549get_hv(name, create)
b2049988
MHM
550 char *name
551 I32 create
552 CODE:
553 RETVAL = get_hv(name, create) != NULL;
554 OUTPUT:
555 RETVAL
adfe19db
MHM
556
557int
558get_cv(name, create)
b2049988
MHM
559 char *name
560 I32 create
561 CODE:
562 RETVAL = get_cv(name, create) != NULL;
563 OUTPUT:
564 RETVAL
adfe19db
MHM
565
566void
0d0f8426 567xsreturn(two)
b2049988
MHM
568 int two
569 PPCODE:
570 mXPUSHp("test1", 5);
571 if (two)
572 mXPUSHp("test2", 5);
573 if (two)
574 XSRETURN(2);
575 else
576 XSRETURN(1);
0d0f8426 577
adfe19db
MHM
578SV*
579boolSV(value)
b2049988
MHM
580 int value
581 CODE:
582 RETVAL = newSVsv(boolSV(value));
583 OUTPUT:
584 RETVAL
adfe19db
MHM
585
586SV*
587DEFSV()
b2049988
MHM
588 CODE:
589 RETVAL = newSVsv(DEFSV);
590 OUTPUT:
591 RETVAL
adfe19db 592
51d6c659
MHM
593void
594DEFSV_modify()
b2049988
MHM
595 PPCODE:
596 XPUSHs(sv_mortalcopy(DEFSV));
597 ENTER;
598 SAVE_DEFSV;
599 DEFSV_set(newSVpvs("DEFSV"));
600 XPUSHs(sv_mortalcopy(DEFSV));
601 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
602 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
603 /* sv_2mortal(DEFSV); */
604 LEAVE;
605 XPUSHs(sv_mortalcopy(DEFSV));
606 XSRETURN(3);
51d6c659 607
adfe19db
MHM
608int
609ERRSV()
b2049988
MHM
610 CODE:
611 RETVAL = SvTRUE(ERRSV);
612 OUTPUT:
613 RETVAL
adfe19db
MHM
614
615SV*
616UNDERBAR()
b2049988
MHM
617 CODE:
618 {
619 dUNDERBAR;
620 RETVAL = newSVsv(UNDERBAR);
621 }
622 OUTPUT:
623 RETVAL
adfe19db 624
0d0f8426
MHM
625void
626prepush()
b2049988
MHM
627 CODE:
628 {
629 dXSTARG;
630 XSprePUSH;
631 PUSHi(42);
632 XSRETURN(1);
633 }
0d0f8426 634
f2ab5a41
MHM
635int
636PERL_ABS(a)
b2049988 637 int a
f2ab5a41
MHM
638
639void
640SVf(x)
b2049988
MHM
641 SV *x
642 PPCODE:
f2ab5a41 643#if { VERSION >= 5.004 }
71d5fd3c 644 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
f2ab5a41 645#endif
b2049988
MHM
646 XPUSHs(x);
647 XSRETURN(1);
f2ab5a41 648
fd7af155
MHM
649void
650Perl_ppaddr_t(string)
b2049988
MHM
651 char *string
652 PREINIT:
653 Perl_ppaddr_t lower;
654 PPCODE:
655 lower = PL_ppaddr[OP_LC];
656 mXPUSHs(newSVpv(string, 0));
657 PUTBACK;
658 ENTER;
659 (void)*(lower)(aTHXR);
660 SPAGAIN;
661 LEAVE;
662 XSRETURN(1);
fd7af155 663
ea4b7f32
JH
664#if { VERSION >= 5.8.0 }
665
666void
667check_HeUTF8(utf8_key)
668 SV *utf8_key;
669 PREINIT:
670 HV *hash;
671 HE *ent;
672 STRLEN klen;
673 char *key;
674 PPCODE:
675 hash = newHV();
676
677 key = SvPV(utf8_key, klen);
678 if (SvUTF8(utf8_key)) klen *= -1;
679 hv_store(hash, key, klen, newSVpvs("string"), 0);
680 hv_iterinit(hash);
681 ent = hv_iternext(hash);
94e22bd6
MH
682 assert(ent);
683 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
ea4b7f32
JH
684 hv_undef(hash);
685
686
687#endif
688
94e22bd6
MH
689void
690check_c_array()
691 PREINIT:
692 int x[] = { 10, 11, 12, 13 };
693 PPCODE:
694 mXPUSHi(C_ARRAY_LENGTH(x)); /* 4 */
695 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
696
697=tests plan => 48
adfe19db
MHM
698
699use vars qw($my_sv @my_av %my_hv);
700
adfe19db
MHM
701ok(&Devel::PPPort::boolSV(1));
702ok(!&Devel::PPPort::boolSV(0));
703
704$_ = "Fred";
705ok(&Devel::PPPort::DEFSV(), "Fred");
706ok(&Devel::PPPort::UNDERBAR(), "Fred");
707
f551177d 708if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
0d0f8426 709 eval q{
b2049988 710 no warnings "deprecated";
e5b2cbd0 711 no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
0d0f8426
MHM
712 my $_ = "Tony";
713 ok(&Devel::PPPort::DEFSV(), "Fred");
714 ok(&Devel::PPPort::UNDERBAR(), "Tony");
715 };
716}
717else {
718 ok(1);
719 ok(1);
720}
721
51d6c659
MHM
722my @r = &Devel::PPPort::DEFSV_modify();
723
724ok(@r == 3);
725ok($r[0], 'Fred');
726ok($r[1], 'DEFSV');
727ok($r[2], 'Fred');
728
729ok(&Devel::PPPort::DEFSV(), "Fred");
730
adfe19db
MHM
731eval { 1 };
732ok(!&Devel::PPPort::ERRSV());
733eval { cannot_call_this_one() };
734ok(&Devel::PPPort::ERRSV());
735
736ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
737ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
738ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
739
740$my_sv = 1;
741ok(&Devel::PPPort::get_sv('my_sv', 0));
742ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
743ok(&Devel::PPPort::get_sv('not_my_sv', 1));
744
745@my_av = (1);
746ok(&Devel::PPPort::get_av('my_av', 0));
747ok(!&Devel::PPPort::get_av('not_my_av', 0));
748ok(&Devel::PPPort::get_av('not_my_av', 1));
749
750%my_hv = (a=>1);
751ok(&Devel::PPPort::get_hv('my_hv', 0));
752ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
753ok(&Devel::PPPort::get_hv('not_my_hv', 1));
754
755sub my_cv { 1 };
756ok(&Devel::PPPort::get_cv('my_cv', 0));
757ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
758ok(&Devel::PPPort::get_cv('not_my_cv', 1));
759
9132e1a3 760ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426
MHM
761ok(Devel::PPPort::dAXMARK(4711), 4710);
762
763ok(Devel::PPPort::prepush(), 42);
9132e1a3 764
0d0f8426
MHM
765ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
766ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41
MHM
767
768ok(Devel::PPPort::PERL_ABS(42), 42);
769ok(Devel::PPPort::PERL_ABS(-13), 13);
770
f551177d
S
771ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
772ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
f2ab5a41 773
fd7af155
MHM
774ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
775
7bb03b24 776ok(&Devel::PPPort::ptrtests(), 63);
ea4b7f32 777
94e22bd6
MH
778ok(&Devel::PPPort::OpSIBLING_tests(), 0);
779
f551177d 780if ("$]" >= 5.009000) {
ea4b7f32
JH
781 eval q{
782 ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
783 ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
784 };
785} else {
786 ok(1, 1);
787 ok(1, 1);
788}
94e22bd6
MH
789
790@r = &Devel::PPPort::check_c_array();
791ok($r[0], 4);
792ok($r[1], "13");
793
794ok(!Devel::PPPort::SvRXOK(""));
795ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
796
f551177d 797if ("$]" < 5.005) {
94e22bd6
MH
798 skip 'no qr// objects in this perl', 0;
799 skip 'no qr// objects in this perl', 0;
800} else {
801 my $qr = eval 'qr/./';
802 ok(Devel::PPPort::SvRXOK($qr));
803 ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
804}