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