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
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 cBOOL
47 OpHAS_SIBLING
48 OpSIBLING
49 OpMORESIB_set
50 OpLASTSIB_set
51 OpMAYBESIB_set
52 MUTABLE_PTR
53 MUTABLE_SV
54
55 =implementation
56
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))
63 __UNDEFINED__ HEf_SVKEY   -2
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 #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
368 =xsmisc
369
370 typedef XSPROTO(XSPROTO_test_t);
371 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
372
373 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
374 XS(XS_Devel__PPPort_dXSTARG)
375 {
376   dXSARGS;
377   dXSTARG;
378   IV iv;
379
380   PERL_UNUSED_VAR(cv);
381   SP -= items;
382   iv = SvIV(ST(0)) + 1;
383   PUSHi(iv);
384   XSRETURN(1);
385 }
386
387 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
388 XS(XS_Devel__PPPort_dAXMARK)
389 {
390   dSP;
391   dAXMARK;
392   dITEMS;
393   IV iv;
394
395   PERL_UNUSED_VAR(cv);
396   SP -= items;
397   iv = SvIV(ST(0)) - 1;
398   mPUSHi(iv);
399   XSRETURN(1);
400 }
401
402 =xsinit
403
404 #define NEED_SvRX
405
406 =xsboot
407
408 {
409   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
410   newXS("Devel::PPPort::dXSTARG", *p, file);
411 }
412 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
413
414 =xsubs
415
416 int
417 OpSIBLING_tests()
418         PREINIT:
419                 OP *x;
420                 OP *kid;
421                 OP *middlekid;
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                 }
445                 middlekid = OpSIBLING(x);
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
489                 op_free(lastkid);
490                 op_free(middlekid);
491                 op_free(x);
492                 RETVAL = failures;
493         OUTPUT:
494                 RETVAL
495
496 int
497 SvRXOK(sv)
498         SV *sv
499         CODE:
500                 RETVAL = SvRXOK(sv);
501         OUTPUT:
502                 RETVAL
503
504 int
505 ptrtests()
506         PREINIT:
507                 int var, *p = &var;
508
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;
517
518         OUTPUT:
519                 RETVAL
520
521 int
522 gv_stashpvn(name, create)
523         char *name
524         I32 create
525         CODE:
526                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
527         OUTPUT:
528                 RETVAL
529
530 int
531 get_sv(name, create)
532         char *name
533         I32 create
534         CODE:
535                 RETVAL = get_sv(name, create) != NULL;
536         OUTPUT:
537                 RETVAL
538
539 int
540 get_av(name, create)
541         char *name
542         I32 create
543         CODE:
544                 RETVAL = get_av(name, create) != NULL;
545         OUTPUT:
546                 RETVAL
547
548 int
549 get_hv(name, create)
550         char *name
551         I32 create
552         CODE:
553                 RETVAL = get_hv(name, create) != NULL;
554         OUTPUT:
555                 RETVAL
556
557 int
558 get_cv(name, create)
559         char *name
560         I32 create
561         CODE:
562                 RETVAL = get_cv(name, create) != NULL;
563         OUTPUT:
564                 RETVAL
565
566 void
567 xsreturn(two)
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);
577
578 SV*
579 boolSV(value)
580         int value
581         CODE:
582                 RETVAL = newSVsv(boolSV(value));
583         OUTPUT:
584                 RETVAL
585
586 SV*
587 DEFSV()
588         CODE:
589                 RETVAL = newSVsv(DEFSV);
590         OUTPUT:
591                 RETVAL
592
593 void
594 DEFSV_modify()
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);
607
608 int
609 ERRSV()
610         CODE:
611                 RETVAL = SvTRUE(ERRSV);
612         OUTPUT:
613                 RETVAL
614
615 SV*
616 UNDERBAR()
617         CODE:
618                 {
619                   dUNDERBAR;
620                   RETVAL = newSVsv(UNDERBAR);
621                 }
622         OUTPUT:
623                 RETVAL
624
625 void
626 prepush()
627         CODE:
628                 {
629                   dXSTARG;
630                   XSprePUSH;
631                   PUSHi(42);
632                   XSRETURN(1);
633                 }
634
635 int
636 PERL_ABS(a)
637         int a
638
639 void
640 SVf(x)
641         SV *x
642         PPCODE:
643 #if { VERSION >= 5.004 }
644                 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
645 #endif
646                 XPUSHs(x);
647                 XSRETURN(1);
648
649 void
650 Perl_ppaddr_t(string)
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);
663
664 #if { VERSION >= 5.8.0 }
665
666 void
667 check_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);
682                 assert(ent);
683                 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
684                 hv_undef(hash);
685
686
687 #endif
688
689 void
690 check_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
698
699 use vars qw($my_sv @my_av %my_hv);
700
701 ok(&Devel::PPPort::boolSV(1));
702 ok(!&Devel::PPPort::boolSV(0));
703
704 $_ = "Fred";
705 ok(&Devel::PPPort::DEFSV(), "Fred");
706 ok(&Devel::PPPort::UNDERBAR(), "Fred");
707
708 if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
709   eval q{
710     no warnings "deprecated";
711     no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
712     my $_ = "Tony";
713     ok(&Devel::PPPort::DEFSV(), "Fred");
714     ok(&Devel::PPPort::UNDERBAR(), "Tony");
715   };
716 }
717 else {
718   ok(1);
719   ok(1);
720 }
721
722 my @r = &Devel::PPPort::DEFSV_modify();
723
724 ok(@r == 3);
725 ok($r[0], 'Fred');
726 ok($r[1], 'DEFSV');
727 ok($r[2], 'Fred');
728
729 ok(&Devel::PPPort::DEFSV(), "Fred");
730
731 eval { 1 };
732 ok(!&Devel::PPPort::ERRSV());
733 eval { cannot_call_this_one() };
734 ok(&Devel::PPPort::ERRSV());
735
736 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
737 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
738 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
739
740 $my_sv = 1;
741 ok(&Devel::PPPort::get_sv('my_sv', 0));
742 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
743 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
744
745 @my_av = (1);
746 ok(&Devel::PPPort::get_av('my_av', 0));
747 ok(!&Devel::PPPort::get_av('not_my_av', 0));
748 ok(&Devel::PPPort::get_av('not_my_av', 1));
749
750 %my_hv = (a=>1);
751 ok(&Devel::PPPort::get_hv('my_hv', 0));
752 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
753 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
754
755 sub my_cv { 1 };
756 ok(&Devel::PPPort::get_cv('my_cv', 0));
757 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
758 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
759
760 ok(Devel::PPPort::dXSTARG(42), 43);
761 ok(Devel::PPPort::dAXMARK(4711), 4710);
762
763 ok(Devel::PPPort::prepush(), 42);
764
765 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
766 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
767
768 ok(Devel::PPPort::PERL_ABS(42), 42);
769 ok(Devel::PPPort::PERL_ABS(-13), 13);
770
771 ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
772 ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
773
774 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
775
776 ok(&Devel::PPPort::ptrtests(), 63);
777
778 ok(&Devel::PPPort::OpSIBLING_tests(), 0);
779
780 if ("$]" >= 5.009000) {
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 }
789
790 @r = &Devel::PPPort::check_c_array();
791 ok($r[0], 4);
792 ok($r[1], "13");
793
794 ok(!Devel::PPPort::SvRXOK(""));
795 ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
796
797 if ("$]" < 5.005) {
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 }