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