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