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
1 ################################################################################
2 ##
3 ##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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__
15 PERL_UNUSED_DECL
16 PERL_UNUSED_ARG
17 PERL_UNUSED_VAR
18 PERL_UNUSED_CONTEXT
19 PERL_UNUSED_RESULT
20 PERL_GCC_BRACE_GROUPS_FORBIDDEN
21 PERL_USE_GCC_BRACE_GROUPS
22 PERLIO_FUNCS_DECL
23 PERLIO_FUNCS_CAST
24 NVTYPE
25 INT2PTR
26 PTRV
27 NUM2PTR
28 PERL_HASH
29 PTR2IV
30 PTR2UV
31 PTR2NV
32 PTR2ul
33 START_EXTERN_C
34 END_EXTERN_C
35 EXTERN_C
36 STMT_START
37 STMT_END
38 UTF8_MAXBYTES
39 WIDEST_UTYPE
40 XSRETURN
41 HeUTF8
42 C_ARRAY_LENGTH
43 C_ARRAY_END
44 SvRX
45 SvRXOK
46 PERL_MAGIC_qr
47 cBOOL
48 OpHAS_SIBLING
49 OpSIBLING
50 OpMORESIB_set
51 OpLASTSIB_set
52 OpMAYBESIB_set
53
54 =implementation
55
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
68 void *
69 SvRX(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
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
94 #  else
95 #    define PERL_UNUSED_DECL
96 #  endif
97 #endif
98
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
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
128 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
129 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
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
137 typedef NVTYPE NV;
138 #endif
139
140 #ifndef INT2PTR
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
152 #endif
153
154 #ifndef PTR2ul
155 #  if PTRSIZE == LONGSIZE
156 #    define PTR2ul(p)     (unsigned long)(p)
157 #  else
158 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
159 #  endif
160 #endif
161
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)
167
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
181 #if defined(PERL_GCC_PEDANTIC)
182 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
183 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
184 #  endif
185 #endif
186
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
193 #undef STMT_START
194 #undef STMT_END
195 #ifdef PERL_USE_GCC_BRACE_GROUPS
196 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
197 #  define STMT_END      )
198 #else
199 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
200 #    define STMT_START  if (1)
201 #    define STMT_END    else (void)0
202 #  else
203 #    define STMT_START  do
204 #    define STMT_END    while (0)
205 #  endif
206 #endif
207
208 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
209
210 /* DEFSV appears first in 5.004_56 */
211 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
212 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
213 __UNDEFINED__  DEFSV_set(sv) (DEFSV = (sv))
214
215 /* Older perls (<=5.003) lack AvFILLp */
216 __UNDEFINED__  AvFILLp      AvFILL
217
218 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
219
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
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
242 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
243
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
259 __UNDEFINED__  XSPROTO(name)   void name(pTHX_ CV* cv)
260 __UNDEFINED__  SVfARG(p)       ((void*)(p))
261
262 __UNDEFINED__  PERL_ABS(x)     ((x) < 0 ? -(x) : (x))
263
264 __UNDEFINED__  dVAR            dNOOP
265
266 __UNDEFINED__  SVf             "_"
267
268 __UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN
269
270 __UNDEFINED__  CPERLscope(x)   x
271
272 __UNDEFINED__  PERL_HASH(hash,str,len) \
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; \
280     } STMT_END
281
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
292 /* provide these typedefs for older perls */
293 #if { VERSION < 5.9.3 }
294
295 # ifdef ARGSproto
296 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
297 # else
298 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
299 # endif
300
301 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
302
303 #endif
304
305 __UNDEFINED__ isPSXSPC(c)       (isSPACE(c) || (c) == '\v')
306 __UNDEFINED__ isBLANK(c)        ((c) == ' ' || (c) == '\t')
307 #ifdef EBCDIC
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)
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
324
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
332 # else
333 #  define WIDEST_UTYPE U32
334 # endif
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'))
344 #endif
345
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
355 __UNDEFINED__ C_ARRAY_LENGTH(a)         (sizeof(a)/sizeof((a)[0]))
356 __UNDEFINED__ C_ARRAY_END(a)            ((a) + C_ARRAY_LENGTH(a))
357
358 =xsmisc
359
360 typedef XSPROTO(XSPROTO_test_t);
361 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
362
363 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
364 XS(XS_Devel__PPPort_dXSTARG)
365 {
366   dXSARGS;
367   dXSTARG;
368   IV iv;
369
370   PERL_UNUSED_VAR(cv);
371   SP -= items;
372   iv = SvIV(ST(0)) + 1;
373   PUSHi(iv);
374   XSRETURN(1);
375 }
376
377 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
378 XS(XS_Devel__PPPort_dAXMARK)
379 {
380   dSP;
381   dAXMARK;
382   dITEMS;
383   IV iv;
384
385   PERL_UNUSED_VAR(cv);
386   SP -= items;
387   iv = SvIV(ST(0)) - 1;
388   mPUSHi(iv);
389   XSRETURN(1);
390 }
391
392 =xsinit
393
394 #define NEED_SvRX
395
396 =xsboot
397
398 {
399   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
400   newXS("Devel::PPPort::dXSTARG", *p, file);
401 }
402 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
403
404 =xsubs
405
406 int
407 OpSIBLING_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
481 int
482 SvRXOK(sv)
483         SV *sv
484         CODE:
485                 RETVAL = SvRXOK(sv);
486         OUTPUT:
487                 RETVAL
488
489 int
490 ptrtests()
491         PREINIT:
492                 int var, *p = &var;
493
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;
502
503         OUTPUT:
504                 RETVAL
505
506 int
507 gv_stashpvn(name, create)
508         char *name
509         I32 create
510         CODE:
511                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
512         OUTPUT:
513                 RETVAL
514
515 int
516 get_sv(name, create)
517         char *name
518         I32 create
519         CODE:
520                 RETVAL = get_sv(name, create) != NULL;
521         OUTPUT:
522                 RETVAL
523
524 int
525 get_av(name, create)
526         char *name
527         I32 create
528         CODE:
529                 RETVAL = get_av(name, create) != NULL;
530         OUTPUT:
531                 RETVAL
532
533 int
534 get_hv(name, create)
535         char *name
536         I32 create
537         CODE:
538                 RETVAL = get_hv(name, create) != NULL;
539         OUTPUT:
540                 RETVAL
541
542 int
543 get_cv(name, create)
544         char *name
545         I32 create
546         CODE:
547                 RETVAL = get_cv(name, create) != NULL;
548         OUTPUT:
549                 RETVAL
550
551 void
552 xsreturn(two)
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);
562
563 SV*
564 boolSV(value)
565         int value
566         CODE:
567                 RETVAL = newSVsv(boolSV(value));
568         OUTPUT:
569                 RETVAL
570
571 SV*
572 DEFSV()
573         CODE:
574                 RETVAL = newSVsv(DEFSV);
575         OUTPUT:
576                 RETVAL
577
578 void
579 DEFSV_modify()
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);
592
593 int
594 ERRSV()
595         CODE:
596                 RETVAL = SvTRUE(ERRSV);
597         OUTPUT:
598                 RETVAL
599
600 SV*
601 UNDERBAR()
602         CODE:
603                 {
604                   dUNDERBAR;
605                   RETVAL = newSVsv(UNDERBAR);
606                 }
607         OUTPUT:
608                 RETVAL
609
610 void
611 prepush()
612         CODE:
613                 {
614                   dXSTARG;
615                   XSprePUSH;
616                   PUSHi(42);
617                   XSRETURN(1);
618                 }
619
620 int
621 PERL_ABS(a)
622         int a
623
624 void
625 SVf(x)
626         SV *x
627         PPCODE:
628 #if { VERSION >= 5.004 }
629                 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
630 #endif
631                 XPUSHs(x);
632                 XSRETURN(1);
633
634 void
635 Perl_ppaddr_t(string)
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);
648
649 #if { VERSION >= 5.8.0 }
650
651 void
652 check_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);
667                 assert(ent);
668                 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
669                 hv_undef(hash);
670
671
672 #endif
673
674 void
675 check_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
683
684 use vars qw($my_sv @my_av %my_hv);
685
686 ok(&Devel::PPPort::boolSV(1));
687 ok(!&Devel::PPPort::boolSV(0));
688
689 $_ = "Fred";
690 ok(&Devel::PPPort::DEFSV(), "Fred");
691 ok(&Devel::PPPort::UNDERBAR(), "Fred");
692
693 if ($] >= 5.009002 && $] < 5.023 && $] < 5.023004) {
694   eval q{
695     no warnings "deprecated";
696     no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
697     my $_ = "Tony";
698     ok(&Devel::PPPort::DEFSV(), "Fred");
699     ok(&Devel::PPPort::UNDERBAR(), "Tony");
700   };
701 }
702 else {
703   ok(1);
704   ok(1);
705 }
706
707 my @r = &Devel::PPPort::DEFSV_modify();
708
709 ok(@r == 3);
710 ok($r[0], 'Fred');
711 ok($r[1], 'DEFSV');
712 ok($r[2], 'Fred');
713
714 ok(&Devel::PPPort::DEFSV(), "Fred");
715
716 eval { 1 };
717 ok(!&Devel::PPPort::ERRSV());
718 eval { cannot_call_this_one() };
719 ok(&Devel::PPPort::ERRSV());
720
721 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
722 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
723 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
724
725 $my_sv = 1;
726 ok(&Devel::PPPort::get_sv('my_sv', 0));
727 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
728 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
729
730 @my_av = (1);
731 ok(&Devel::PPPort::get_av('my_av', 0));
732 ok(!&Devel::PPPort::get_av('not_my_av', 0));
733 ok(&Devel::PPPort::get_av('not_my_av', 1));
734
735 %my_hv = (a=>1);
736 ok(&Devel::PPPort::get_hv('my_hv', 0));
737 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
738 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
739
740 sub my_cv { 1 };
741 ok(&Devel::PPPort::get_cv('my_cv', 0));
742 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
743 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
744
745 ok(Devel::PPPort::dXSTARG(42), 43);
746 ok(Devel::PPPort::dAXMARK(4711), 4710);
747
748 ok(Devel::PPPort::prepush(), 42);
749
750 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
751 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
752
753 ok(Devel::PPPort::PERL_ABS(42), 42);
754 ok(Devel::PPPort::PERL_ABS(-13), 13);
755
756 ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
757 ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
758
759 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
760
761 ok(&Devel::PPPort::ptrtests(), 63);
762
763 ok(&Devel::PPPort::OpSIBLING_tests(), 0);
764
765 if ($] >= 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 }
774
775 @r = &Devel::PPPort::check_c_array();
776 ok($r[0], 4);
777 ok($r[1], "13");
778
779 ok(!Devel::PPPort::SvRXOK(""));
780 ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
781
782 if ($] < 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 }