This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
re-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 END_EXTERN_C
16 EXTERN_C
17 INT2PTR
18 MUTABLE_PTR
19 NVTYPE
20 PERL_GCC_BRACE_GROUPS_FORBIDDEN
21 PERLIO_FUNCS_CAST
22 PERLIO_FUNCS_DECL
23 PERL_UNUSED_ARG
24 PERL_UNUSED_CONTEXT
25 PERL_UNUSED_DECL
26 PERL_UNUSED_RESULT
27 PERL_UNUSED_VAR
28 PERL_USE_GCC_BRACE_GROUPS
29 PTR2ul
30 PTRV
31 START_EXTERN_C
32 STMT_END
33 STMT_START
34 SvRX
35 UTF8_MAXBYTES
36 WIDEST_UTYPE
37 XSRETURN
38
39 =implementation
40
41 __UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
42 __UNDEFINED__ OpHAS_SIBLING(o)      (cBOOL((o)->op_sibling))
43 __UNDEFINED__ OpSIBLING(o)          (0 + (o)->op_sibling)
44 __UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
45 __UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
46 __UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
47 __UNDEFINED__ HEf_SVKEY   -2
48
49 #if defined(DEBUGGING) && !defined(__COVERITY__)
50 __UNDEFINED__ __ASSERT_(statement)  assert(statement),
51 #else
52 __UNDEFINED__ __ASSERT_(statement)
53 #endif
54
55 #ifndef SvRX
56 #if { NEED SvRX }
57
58 void *
59 SvRX(pTHX_ SV *rv)
60 {
61         if (SvROK(rv)) {
62                 SV *sv = SvRV(rv);
63                 if (SvMAGICAL(sv)) {
64                         MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
65                         if (mg && mg->mg_obj) {
66                                 return mg->mg_obj;
67                         }
68                 }
69         }
70         return 0;
71 }
72 #endif
73 #endif
74
75 __UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))
76
77 #ifndef PERL_UNUSED_DECL
78 #  ifdef HASATTRIBUTE
79 #    if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
80 #      define PERL_UNUSED_DECL
81 #    else
82 #      define PERL_UNUSED_DECL __attribute__((unused))
83 #    endif
84 #  else
85 #    define PERL_UNUSED_DECL
86 #  endif
87 #endif
88
89 #ifndef PERL_UNUSED_ARG
90 #  if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
91 #    include <note.h>
92 #    define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
93 #  else
94 #    define PERL_UNUSED_ARG(x) ((void)x)
95 #  endif
96 #endif
97
98 #ifndef PERL_UNUSED_VAR
99 #  define PERL_UNUSED_VAR(x) ((void)x)
100 #endif
101
102 #ifndef PERL_UNUSED_CONTEXT
103 #  ifdef USE_ITHREADS
104 #    define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
105 #  else
106 #    define PERL_UNUSED_CONTEXT
107 #  endif
108 #endif
109
110 #ifndef PERL_UNUSED_RESULT
111 #  if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
112 #    define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
113 #  else
114 #    define PERL_UNUSED_RESULT(v) ((void)(v))
115 #  endif
116 #endif
117
118 __UNDEFINED__  NOOP          /*EMPTY*/(void)0
119 __UNDEFINED__  dNOOP         extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
120
121 #ifndef NVTYPE
122 #  if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
123 #    define NVTYPE long double
124 #  else
125 #    define NVTYPE double
126 #  endif
127 typedef NVTYPE NV;
128 #endif
129
130 #ifndef INT2PTR
131 #  if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
132 #    define PTRV                  UV
133 #    define INT2PTR(any,d)        (any)(d)
134 #  else
135 #    if PTRSIZE == LONGSIZE
136 #      define PTRV                unsigned long
137 #    else
138 #      define PTRV                unsigned
139 #    endif
140 #    define INT2PTR(any,d)        (any)(PTRV)(d)
141 #  endif
142 #endif
143
144 #ifndef PTR2ul
145 #  if PTRSIZE == LONGSIZE
146 #    define PTR2ul(p)     (unsigned long)(p)
147 #  else
148 #    define PTR2ul(p)     INT2PTR(unsigned long,p)
149 #  endif
150 #endif
151
152 __UNDEFINED__  PTR2nat(p)      (PTRV)(p)
153 __UNDEFINED__  NUM2PTR(any,d)  (any)PTR2nat(d)
154 __UNDEFINED__  PTR2IV(p)       INT2PTR(IV,p)
155 __UNDEFINED__  PTR2UV(p)       INT2PTR(UV,p)
156 __UNDEFINED__  PTR2NV(p)       NUM2PTR(NV,p)
157
158 #undef START_EXTERN_C
159 #undef END_EXTERN_C
160 #undef EXTERN_C
161 #ifdef __cplusplus
162 #  define START_EXTERN_C extern "C" {
163 #  define END_EXTERN_C }
164 #  define EXTERN_C extern "C"
165 #else
166 #  define START_EXTERN_C
167 #  define END_EXTERN_C
168 #  define EXTERN_C extern
169 #endif
170
171 #if defined(PERL_GCC_PEDANTIC)
172 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
173 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
174 #  endif
175 #endif
176
177 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
178 #  ifndef PERL_USE_GCC_BRACE_GROUPS
179 #    define PERL_USE_GCC_BRACE_GROUPS
180 #  endif
181 #endif
182
183 #undef STMT_START
184 #undef STMT_END
185 #ifdef PERL_USE_GCC_BRACE_GROUPS
186 #  define STMT_START    (void)( /* gcc supports ``({ STATEMENTS; })'' */
187 #  define STMT_END      )
188 #else
189 #  if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
190 #    define STMT_START  if (1)
191 #    define STMT_END    else (void)0
192 #  else
193 #    define STMT_START  do
194 #    define STMT_END    while (0)
195 #  endif
196 #endif
197
198 __UNDEFINED__  boolSV(b)    ((b) ? &PL_sv_yes : &PL_sv_no)
199
200 /* DEFSV appears first in 5.004_56 */
201 __UNDEFINED__  DEFSV        GvSV(PL_defgv)
202 __UNDEFINED__  SAVE_DEFSV   SAVESPTR(GvSV(PL_defgv))
203 __UNDEFINED__  DEFSV_set(sv) (DEFSV = (sv))
204
205 /* Older perls (<=5.003) lack AvFILLp */
206 __UNDEFINED__  AvFILLp      AvFILL
207
208 __UNDEFINED__  av_tindex    AvFILL
209 __UNDEFINED__  av_top_index AvFILL
210
211 __UNDEFINED__  ERRSV        get_sv("@",FALSE)
212
213 /* Hint: gv_stashpvn
214  * This function's backport doesn't support the length parameter, but
215  * rather ignores it. Portability can only be ensured if the length
216  * parameter is used for speed reasons, but the length can always be
217  * correctly computed from the string argument.
218  */
219
220 __UNDEFINED__  gv_stashpvn(str,len,create)  gv_stashpv(str,create)
221
222 /* Replace: 1 */
223 __UNDEFINED__  get_cv          perl_get_cv
224 __UNDEFINED__  get_sv          perl_get_sv
225 __UNDEFINED__  get_av          perl_get_av
226 __UNDEFINED__  get_hv          perl_get_hv
227 /* Replace: 0 */
228
229 __UNDEFINED__  dUNDERBAR       dNOOP
230 __UNDEFINED__  UNDERBAR        DEFSV
231
232 __UNDEFINED__  dAX             I32 ax = MARK - PL_stack_base + 1
233 __UNDEFINED__  dITEMS          I32 items = SP - MARK
234
235 __UNDEFINED__  dXSTARG         SV * targ = sv_newmortal()
236
237 __UNDEFINED__  dAXMARK         I32 ax = POPMARK; \
238                                register SV ** const mark = PL_stack_base + ax++
239
240
241 __UNDEFINED__  XSprePUSH       (sp = PL_stack_base + ax - 1)
242
243 #if { VERSION < 5.005 }
244 #  undef XSRETURN
245 #  define XSRETURN(off)                                   \
246       STMT_START {                                        \
247           PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
248           return;                                         \
249       } STMT_END
250 #endif
251
252 __UNDEFINED__  XSPROTO(name)   void name(pTHX_ CV* cv)
253 __UNDEFINED__  SVfARG(p)       ((void*)(p))
254
255 __UNDEFINED__  PERL_ABS(x)     ((x) < 0 ? -(x) : (x))
256
257 __UNDEFINED__  dVAR            dNOOP
258
259 __UNDEFINED__  SVf             "_"
260
261 __UNDEFINED__  UTF8_MAXBYTES   UTF8_MAXLEN
262
263 __UNDEFINED__  CPERLscope(x)   x
264
265 __UNDEFINED__  PERL_HASH(hash,str,len) \
266      STMT_START { \
267         const char *s_PeRlHaSh = str; \
268         I32 i_PeRlHaSh = len; \
269         U32 hash_PeRlHaSh = 0; \
270         while (i_PeRlHaSh--) \
271             hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
272         (hash) = hash_PeRlHaSh; \
273     } STMT_END
274
275 #ifndef PERLIO_FUNCS_DECL
276 # ifdef PERLIO_FUNCS_CONST
277 #  define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
278 #  define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
279 # else
280 #  define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
281 #  define PERLIO_FUNCS_CAST(funcs) (funcs)
282 # endif
283 #endif
284
285 /* provide these typedefs for older perls */
286 #if { VERSION < 5.9.3 }
287
288 # ifdef ARGSproto
289 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
290 # else
291 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
292 # endif
293
294 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
295
296 #endif
297
298 #ifndef WIDEST_UTYPE
299 # ifdef QUADKIND
300 #  ifdef U64TYPE
301 #   define WIDEST_UTYPE U64TYPE
302 #  else
303 #   define WIDEST_UTYPE Quad_t
304 #  endif
305 # else
306 #  define WIDEST_UTYPE U32
307 # endif
308 #endif
309
310 #ifdef EBCDIC
311
312 /* This is the first version where these macros are fully correct.  Relying on
313  * the C library functions, as earlier releases did, causes problems with
314  * locales */
315 # if { VERSION < 5.22.0 }
316 #  undef isALNUM
317 #  undef isALNUM_A
318 #  undef isALNUMC
319 #  undef isALNUMC_A
320 #  undef isALPHA
321 #  undef isALPHA_A
322 #  undef isALPHANUMERIC
323 #  undef isALPHANUMERIC_A
324 #  undef isASCII
325 #  undef isASCII_A
326 #  undef isBLANK
327 #  undef isBLANK_A
328 #  undef isCNTRL
329 #  undef isCNTRL_A
330 #  undef isDIGIT
331 #  undef isDIGIT_A
332 #  undef isGRAPH
333 #  undef isGRAPH_A
334 #  undef isIDCONT
335 #  undef isIDCONT_A
336 #  undef isIDFIRST
337 #  undef isIDFIRST_A
338 #  undef isLOWER
339 #  undef isLOWER_A
340 #  undef isOCTAL
341 #  undef isOCTAL_A
342 #  undef isPRINT
343 #  undef isPRINT_A
344 #  undef isPSXSPC
345 #  undef isPSXSPC_A
346 #  undef isPUNCT
347 #  undef isPUNCT_A
348 #  undef isSPACE
349 #  undef isSPACE_A
350 #  undef isUPPER
351 #  undef isUPPER_A
352 #  undef isWORDCHAR
353 #  undef isWORDCHAR_A
354 #  undef isXDIGIT
355 #  undef isXDIGIT_A
356 # endif
357
358 __UNDEFINED__ isASCII(c)    (isCNTRL(c) || isPRINT(c))
359
360         /* The below is accurate for all EBCDIC code pages supported by
361          * all the versions of Perl overridden by this */
362 __UNDEFINED__ isCNTRL(c)    (    (c) == '\0' || (c) == '\a' || (c) == '\b'      \
363                              ||  (c) == '\f' || (c) == '\n' || (c) == '\r'      \
364                              ||  (c) == '\t' || (c) == '\v'                     \
365                              || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */      \
366                              ||  (c) == 7    /* U+7F DEL */                     \
367                              || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */       \
368                                                       /* DLE, DC[1-3] */        \
369                              ||  (c) == 0x18 /* U+18 CAN */                     \
370                              ||  (c) == 0x19 /* U+19 EOM */                     \
371                              || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */      \
372                              ||  (c) == 0x26 /* U+17 ETB */                     \
373                              ||  (c) == 0x27 /* U+1B ESC */                     \
374                              ||  (c) == 0x2D /* U+05 ENQ */                     \
375                              ||  (c) == 0x2E /* U+06 ACK */                     \
376                              ||  (c) == 0x32 /* U+16 SYN */                     \
377                              ||  (c) == 0x37 /* U+04 EOT */                     \
378                              ||  (c) == 0x3C /* U+14 DC4 */                     \
379                              ||  (c) == 0x3D /* U+15 NAK */                     \
380                              ||  (c) == 0x3F /* U+1A SUB */                     \
381                             )
382 /* The ordering of the tests in this and isUPPER are to exclude most characters
383  * early */
384 __UNDEFINED__ isLOWER(c)    (        (c) >= 'a' && (c) <= 'z'                   \
385                              &&  (   (c) <= 'i'                                 \
386                                  || ((c) >= 'j' && (c) <= 'r')                  \
387                                  ||  (c) >= 's'))
388 __UNDEFINED__ isUPPER(c)    (        (c) >= 'A' && (c) <= 'Z'                   \
389                              && (    (c) <= 'I'                                 \
390                                  || ((c) >= 'J' && (c) <= 'R')                  \
391                                  ||  (c) >= 'S'))
392
393 #else   /* Above is EBCDIC; below is ASCII */
394
395 # if { VERSION < 5.4.0 }
396 /* The implementation of these in older perl versions can give wrong results if
397  * the C program locale is set to other than the C locale */
398 #  undef isALNUM
399 #  undef isALNUM_A
400 #  undef isALPHA
401 #  undef isALPHA_A
402 #  undef isDIGIT
403 #  undef isDIGIT_A
404 #  undef isIDFIRST
405 #  undef isIDFIRST_A
406 #  undef isLOWER
407 #  undef isLOWER_A
408 #  undef isUPPER
409 #  undef isUPPER_A
410 # endif
411
412 # if { VERSION < 5.8.0 }
413 /* Hint: isCNTRL
414  * Earlier perls omitted DEL */
415 #  undef isCNTRL
416 # endif
417
418 # if { VERSION < 5.10.0 }
419 /* Hint: isPRINT
420  * The implementation in older perl versions includes all of the
421  * isSPACE() characters, which is wrong. The version provided by
422  * Devel::PPPort always overrides a present buggy version.
423  */
424 #  undef isPRINT
425 #  undef isPRINT_A
426 # endif
427
428 # if { VERSION < 5.14.0 }
429 /* Hint: isASCII
430  * The implementation in older perl versions always returned true if the
431  * parameter was a signed char
432  */
433 #  undef isASCII
434 #  undef isASCII_A
435 # endif
436
437 # if { VERSION < 5.20.0 }
438 /* Hint: isSPACE
439  * The implementation in older perl versions didn't include \v */
440 #  undef isSPACE
441 #  undef isSPACE_A
442 # endif
443
444 __UNDEFINED__ isASCII(c)        ((WIDEST_UTYPE) (c) <= 127)
445 __UNDEFINED__ isCNTRL(c)        ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
446 __UNDEFINED__ isLOWER(c)        ((c) >= 'a' && (c) <= 'z')
447 __UNDEFINED__ isUPPER(c)        ((c) <= 'Z' && (c) >= 'A')
448 #endif /* Below are definitions common to EBCDIC and ASCII */
449
450 __UNDEFINED__ isALNUM(c)        isWORDCHAR(c)
451 __UNDEFINED__ isALNUMC(c)       isALPHANUMERIC(c)
452 __UNDEFINED__ isALPHA(c)        (isUPPER(c) || isLOWER(c))
453 __UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
454 __UNDEFINED__ isBLANK(c)        ((c) == ' ' || (c) == '\t')
455 __UNDEFINED__ isDIGIT(c)        ((c) <= '9' && (c) >= '0')
456 __UNDEFINED__ isGRAPH(c)        (isWORDCHAR(c) || isPUNCT(c))
457 __UNDEFINED__ isIDCONT(c)       isWORDCHAR(c)
458 __UNDEFINED__ isIDFIRST(c)      (isALPHA(c) || (c) == '_')
459 __UNDEFINED__ isOCTAL(c)        (((WIDEST_UTYPE)((c)) & ~7) == '0')
460 __UNDEFINED__ isPRINT(c)        (isGRAPH(c) || (c) == ' ')
461 __UNDEFINED__ isPSXSPC(c)       isSPACE(c)
462 __UNDEFINED__ isPUNCT(c)    (   (c) == '-' || (c) == '!' || (c) == '"'          \
463                              || (c) == '#' || (c) == '$' || (c) == '%'          \
464                              || (c) == '&' || (c) == '\'' || (c) == '('         \
465                              || (c) == ')' || (c) == '*' || (c) == '+'          \
466                              || (c) == ',' || (c) == '.' || (c) == '/'          \
467                              || (c) == ':' || (c) == ';' || (c) == '<'          \
468                              || (c) == '=' || (c) == '>' || (c) == '?'          \
469                              || (c) == '@' || (c) == '[' || (c) == '\\'         \
470                              || (c) == ']' || (c) == '^' || (c) == '_'          \
471                              || (c) == '`' || (c) == '{' || (c) == '|'          \
472                              || (c) == '}' || (c) == '~')
473 __UNDEFINED__ isSPACE(c)        (   isBLANK(c) || (c) == '\n' || (c) == '\r'    \
474                                  || (c) == '\v' || (c) == '\f')
475 __UNDEFINED__ isWORDCHAR(c)     (isALPHANUMERIC(c) || (c) == '_')
476 __UNDEFINED__ isXDIGIT(c)       (   isDIGIT(c)                                  \
477                                  || ((c) >= 'a' && (c) <= 'f')                  \
478                                  || ((c) >= 'A' && (c) <= 'F'))
479
480 __UNDEFINED__ isALNUM_A         isALNUM
481 __UNDEFINED__ isALNUMC_A        isALNUMC
482 __UNDEFINED__ isALPHA_A         isALPHA
483 __UNDEFINED__ isALPHANUMERIC_A  isALPHANUMERIC
484 __UNDEFINED__ isASCII_A         isASCII
485 __UNDEFINED__ isBLANK_A         isBLANK
486 __UNDEFINED__ isCNTRL_A         isCNTRL
487 __UNDEFINED__ isDIGIT_A         isDIGIT
488 __UNDEFINED__ isGRAPH_A         isGRAPH
489 __UNDEFINED__ isIDCONT_A        isIDCONT
490 __UNDEFINED__ isIDFIRST_A       isIDFIRST
491 __UNDEFINED__ isLOWER_A         isLOWER
492 __UNDEFINED__ isOCTAL_A         isOCTAL
493 __UNDEFINED__ isPRINT_A         isPRINT
494 __UNDEFINED__ isPSXSPC_A        isPSXSPC
495 __UNDEFINED__ isPUNCT_A         isPUNCT
496 __UNDEFINED__ isSPACE_A         isSPACE
497 __UNDEFINED__ isUPPER_A         isUPPER
498 __UNDEFINED__ isWORDCHAR_A      isWORDCHAR
499 __UNDEFINED__ isXDIGIT_A        isXDIGIT
500
501 /* Until we figure out how to support this in older perls... */
502 #if { VERSION >= 5.8.0 }
503
504 __UNDEFINED__ HeUTF8(he)        ((HeKLEN(he) == HEf_SVKEY) ?            \
505                                  SvUTF8(HeKEY_sv(he)) :                 \
506                                  (U32)HeKUTF8(he))
507
508 #endif
509
510 __UNDEFINED__ C_ARRAY_LENGTH(a)         (sizeof(a)/sizeof((a)[0]))
511 __UNDEFINED__ C_ARRAY_END(a)            ((a) + C_ARRAY_LENGTH(a))
512
513 __UNDEFINED__ LIKELY(x) (x)
514 __UNDEFINED__ UNLIKELY(x) (x)
515
516 __UNDEFINED__ UNICODE_REPLACEMENT  0xFFFD
517
518 #ifndef MUTABLE_PTR
519 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
520 #  define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
521 #else
522 #  define MUTABLE_PTR(p) ((void *) (p))
523 #endif
524 #endif
525
526 __UNDEFINED__ MUTABLE_SV(p)   ((SV *)MUTABLE_PTR(p))
527
528 =xsmisc
529
530 typedef XSPROTO(XSPROTO_test_t);
531 typedef XSPROTO_test_t *XSPROTO_test_t_ptr;
532
533 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
534 XS(XS_Devel__PPPort_dXSTARG)
535 {
536   dXSARGS;
537   dXSTARG;
538   IV iv;
539
540   PERL_UNUSED_VAR(cv);
541   SP -= items;
542   iv = SvIV(ST(0)) + 1;
543   PUSHi(iv);
544   XSRETURN(1);
545 }
546
547 XS(XS_Devel__PPPort_dAXMARK);  /* prototype */
548 XS(XS_Devel__PPPort_dAXMARK)
549 {
550   dSP;
551   dAXMARK;
552   dITEMS;
553   IV iv;
554
555   PERL_UNUSED_VAR(cv);
556   SP -= items;
557   iv = SvIV(ST(0)) - 1;
558   mPUSHi(iv);
559   XSRETURN(1);
560 }
561
562 =xsinit
563
564 #define NEED_SvRX
565
566 =xsboot
567
568 {
569   XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG;
570   newXS("Devel::PPPort::dXSTARG", *p, file);
571 }
572 newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
573
574 =xsubs
575
576 int
577 OpSIBLING_tests()
578         PREINIT:
579                 OP *x;
580                 OP *kid;
581                 OP *middlekid;
582                 OP *lastkid;
583                 int count = 0;
584                 int failures = 0;
585                 int i;
586         CODE:
587                 x = newOP(OP_PUSHMARK, 0);
588
589                 /* No siblings yet! */
590                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
591                         failures++; warn("Op should not have had a sib");
592                 }
593
594
595                 /* Add 2 siblings */
596                 kid = x;
597
598                 for (i = 0; i < 2; i++) {
599                         OP *newsib = newOP(OP_PUSHMARK, 0);
600                         OpMORESIB_set(kid, newsib);
601
602                         kid = OpSIBLING(kid);
603                         lastkid = kid;
604                 }
605                 middlekid = OpSIBLING(x);
606
607                 /* Should now have a sibling */
608                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
609                         failures++; warn("Op should have had a sib after moresib_set");
610                 }
611
612                 /* Count the siblings */
613                 for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
614                         count++;
615                 }
616
617                 if (count != 2) {
618                         failures++; warn("Kid had %d sibs, expected 2", count);
619                 }
620
621                 if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
622                         failures++; warn("Last kid should not have a sib");
623                 }
624
625                 /* Really sets the parent, and says 'no more siblings' */
626                 OpLASTSIB_set(x, lastkid);
627
628                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
629                         failures++; warn("OpLASTSIB_set failed?");
630                 }
631
632                 /* Restore the kid */
633                 OpMORESIB_set(x, lastkid);
634
635                 /* Try to remove it again */
636                 OpLASTSIB_set(x, NULL);
637
638                 if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
639                         failures++; warn("OpLASTSIB_set with NULL failed?");
640                 }
641
642                 /* Try to restore with maybesib_set */
643                 OpMAYBESIB_set(x, lastkid, NULL);
644
645                 if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
646                         failures++; warn("Op should have had a sib after maybesibset");
647                 }
648
649                 op_free(lastkid);
650                 op_free(middlekid);
651                 op_free(x);
652                 RETVAL = failures;
653         OUTPUT:
654                 RETVAL
655
656 int
657 SvRXOK(sv)
658         SV *sv
659         CODE:
660                 RETVAL = SvRXOK(sv);
661         OUTPUT:
662                 RETVAL
663
664 int
665 ptrtests()
666         PREINIT:
667                 int var, *p = &var;
668
669         CODE:
670                 RETVAL = 0;
671                 RETVAL += PTR2nat(p) != 0       ?  1 : 0;
672                 RETVAL += PTR2ul(p) != 0UL      ?  2 : 0;
673                 RETVAL += PTR2UV(p) != (UV) 0   ?  4 : 0;
674                 RETVAL += PTR2IV(p) != (IV) 0   ?  8 : 0;
675                 RETVAL += PTR2NV(p) != (NV) 0   ? 16 : 0;
676                 RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;
677
678         OUTPUT:
679                 RETVAL
680
681 int
682 gv_stashpvn(name, create)
683         char *name
684         I32 create
685         CODE:
686                 RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
687         OUTPUT:
688                 RETVAL
689
690 int
691 get_sv(name, create)
692         char *name
693         I32 create
694         CODE:
695                 RETVAL = get_sv(name, create) != NULL;
696         OUTPUT:
697                 RETVAL
698
699 int
700 get_av(name, create)
701         char *name
702         I32 create
703         CODE:
704                 RETVAL = get_av(name, create) != NULL;
705         OUTPUT:
706                 RETVAL
707
708 int
709 get_hv(name, create)
710         char *name
711         I32 create
712         CODE:
713                 RETVAL = get_hv(name, create) != NULL;
714         OUTPUT:
715                 RETVAL
716
717 int
718 get_cv(name, create)
719         char *name
720         I32 create
721         CODE:
722                 RETVAL = get_cv(name, create) != NULL;
723         OUTPUT:
724                 RETVAL
725
726 void
727 xsreturn(two)
728         int two
729         PPCODE:
730                 mXPUSHp("test1", 5);
731                 if (two)
732                   mXPUSHp("test2", 5);
733                 if (two)
734                   XSRETURN(2);
735                 else
736                   XSRETURN(1);
737
738 SV*
739 boolSV(value)
740         int value
741         CODE:
742                 RETVAL = newSVsv(boolSV(value));
743         OUTPUT:
744                 RETVAL
745
746 SV*
747 DEFSV()
748         CODE:
749                 RETVAL = newSVsv(DEFSV);
750         OUTPUT:
751                 RETVAL
752
753 void
754 DEFSV_modify()
755         PPCODE:
756                 XPUSHs(sv_mortalcopy(DEFSV));
757                 ENTER;
758                 SAVE_DEFSV;
759                 DEFSV_set(newSVpvs("DEFSV"));
760                 XPUSHs(sv_mortalcopy(DEFSV));
761                 /* Yes, this leaks the above scalar; 5.005 with threads for some reason */
762                 /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */
763                 /* sv_2mortal(DEFSV); */
764                 LEAVE;
765                 XPUSHs(sv_mortalcopy(DEFSV));
766                 XSRETURN(3);
767
768 int
769 ERRSV()
770         CODE:
771                 RETVAL = SvTRUE(ERRSV);
772         OUTPUT:
773                 RETVAL
774
775 SV*
776 UNDERBAR()
777         CODE:
778                 {
779                   dUNDERBAR;
780                   RETVAL = newSVsv(UNDERBAR);
781                 }
782         OUTPUT:
783                 RETVAL
784
785 void
786 prepush()
787         CODE:
788                 {
789                   dXSTARG;
790                   XSprePUSH;
791                   PUSHi(42);
792                   XSRETURN(1);
793                 }
794
795 int
796 PERL_ABS(a)
797         int a
798
799 void
800 SVf(x)
801         SV *x
802         PPCODE:
803 #if { VERSION >= 5.004 }
804                 x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x)));
805 #endif
806                 XPUSHs(x);
807                 XSRETURN(1);
808
809 void
810 Perl_ppaddr_t(string)
811         char *string
812         PREINIT:
813                 Perl_ppaddr_t lower;
814         PPCODE:
815                 lower = PL_ppaddr[OP_LC];
816                 mXPUSHs(newSVpv(string, 0));
817                 PUTBACK;
818                 ENTER;
819                 (void)*(lower)(aTHXR);
820                 SPAGAIN;
821                 LEAVE;
822                 XSRETURN(1);
823
824 #if { VERSION >= 5.8.0 }
825
826 void
827 check_HeUTF8(utf8_key)
828         SV *utf8_key;
829         PREINIT:
830                 HV *hash;
831                 HE *ent;
832                 STRLEN klen;
833                 char *key;
834         PPCODE:
835                 hash = newHV();
836
837                 key = SvPV(utf8_key, klen);
838                 if (SvUTF8(utf8_key)) klen *= -1;
839                 hv_store(hash, key, klen, newSVpvs("string"), 0);
840                 hv_iterinit(hash);
841                 ent = hv_iternext(hash);
842                 assert(ent);
843                 mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
844                 hv_undef(hash);
845
846
847 #endif
848
849 void
850 check_c_array()
851         PREINIT:
852                 int x[] = { 10, 11, 12, 13 };
853         PPCODE:
854                 mXPUSHi(C_ARRAY_LENGTH(x));  /* 4 */
855                 mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */
856
857 bool
858 test_isBLANK(UV ord)
859     CODE:
860         RETVAL = isBLANK(ord);
861     OUTPUT:
862         RETVAL
863
864 bool
865 test_isBLANK_A(UV ord)
866     CODE:
867         RETVAL = isBLANK_A(ord);
868     OUTPUT:
869         RETVAL
870
871 bool
872 test_isUPPER(UV ord)
873     CODE:
874         RETVAL = isUPPER(ord);
875     OUTPUT:
876         RETVAL
877
878 bool
879 test_isUPPER_A(UV ord)
880     CODE:
881         RETVAL = isUPPER_A(ord);
882     OUTPUT:
883         RETVAL
884
885 bool
886 test_isLOWER(UV ord)
887     CODE:
888         RETVAL = isLOWER(ord);
889     OUTPUT:
890         RETVAL
891
892 bool
893 test_isLOWER_A(UV ord)
894     CODE:
895         RETVAL = isLOWER_A(ord);
896     OUTPUT:
897         RETVAL
898
899 bool
900 test_isALPHA(UV ord)
901     CODE:
902         RETVAL = isALPHA(ord);
903     OUTPUT:
904         RETVAL
905
906 bool
907 test_isALPHA_A(UV ord)
908     CODE:
909         RETVAL = isALPHA_A(ord);
910     OUTPUT:
911         RETVAL
912
913 bool
914 test_isWORDCHAR(UV ord)
915     CODE:
916         RETVAL = isWORDCHAR(ord);
917     OUTPUT:
918         RETVAL
919
920 bool
921 test_isWORDCHAR_A(UV ord)
922     CODE:
923         RETVAL = isWORDCHAR_A(ord);
924     OUTPUT:
925         RETVAL
926
927 bool
928 test_isALPHANUMERIC(UV ord)
929     CODE:
930         RETVAL = isALPHANUMERIC(ord);
931     OUTPUT:
932         RETVAL
933
934 bool
935 test_isALPHANUMERIC_A(UV ord)
936     CODE:
937         RETVAL = isALPHANUMERIC_A(ord);
938     OUTPUT:
939         RETVAL
940
941 bool
942 test_isALNUM(UV ord)
943     CODE:
944         RETVAL = isALNUM(ord);
945     OUTPUT:
946         RETVAL
947
948 bool
949 test_isALNUM_A(UV ord)
950     CODE:
951         RETVAL = isALNUM_A(ord);
952     OUTPUT:
953         RETVAL
954
955 bool
956 test_isDIGIT(UV ord)
957     CODE:
958         RETVAL = isDIGIT(ord);
959     OUTPUT:
960         RETVAL
961
962 bool
963 test_isDIGIT_A(UV ord)
964     CODE:
965         RETVAL = isDIGIT_A(ord);
966     OUTPUT:
967         RETVAL
968
969 bool
970 test_isOCTAL(UV ord)
971     CODE:
972         RETVAL = isOCTAL(ord);
973     OUTPUT:
974         RETVAL
975
976 bool
977 test_isOCTAL_A(UV ord)
978     CODE:
979         RETVAL = isOCTAL_A(ord);
980     OUTPUT:
981         RETVAL
982
983 bool
984 test_isIDFIRST(UV ord)
985     CODE:
986         RETVAL = isIDFIRST(ord);
987     OUTPUT:
988         RETVAL
989
990 bool
991 test_isIDFIRST_A(UV ord)
992     CODE:
993         RETVAL = isIDFIRST_A(ord);
994     OUTPUT:
995         RETVAL
996
997 bool
998 test_isIDCONT(UV ord)
999     CODE:
1000         RETVAL = isIDCONT(ord);
1001     OUTPUT:
1002         RETVAL
1003
1004 bool
1005 test_isIDCONT_A(UV ord)
1006     CODE:
1007         RETVAL = isIDCONT_A(ord);
1008     OUTPUT:
1009         RETVAL
1010
1011 bool
1012 test_isSPACE(UV ord)
1013     CODE:
1014         RETVAL = isSPACE(ord);
1015     OUTPUT:
1016         RETVAL
1017
1018 bool
1019 test_isSPACE_A(UV ord)
1020     CODE:
1021         RETVAL = isSPACE_A(ord);
1022     OUTPUT:
1023         RETVAL
1024
1025 bool
1026 test_isASCII(UV ord)
1027     CODE:
1028         RETVAL = isASCII(ord);
1029     OUTPUT:
1030         RETVAL
1031
1032 bool
1033 test_isASCII_A(UV ord)
1034     CODE:
1035         RETVAL = isASCII_A(ord);
1036     OUTPUT:
1037         RETVAL
1038
1039 bool
1040 test_isCNTRL(UV ord)
1041     CODE:
1042         RETVAL = isCNTRL(ord);
1043     OUTPUT:
1044         RETVAL
1045
1046 bool
1047 test_isCNTRL_A(UV ord)
1048     CODE:
1049         RETVAL = isCNTRL_A(ord);
1050     OUTPUT:
1051         RETVAL
1052
1053 bool
1054 test_isPRINT(UV ord)
1055     CODE:
1056         RETVAL = isPRINT(ord);
1057     OUTPUT:
1058         RETVAL
1059
1060 bool
1061 test_isPRINT_A(UV ord)
1062     CODE:
1063         RETVAL = isPRINT_A(ord);
1064     OUTPUT:
1065         RETVAL
1066
1067 bool
1068 test_isGRAPH(UV ord)
1069     CODE:
1070         RETVAL = isGRAPH(ord);
1071     OUTPUT:
1072         RETVAL
1073
1074 bool
1075 test_isGRAPH_A(UV ord)
1076     CODE:
1077         RETVAL = isGRAPH_A(ord);
1078     OUTPUT:
1079         RETVAL
1080
1081 bool
1082 test_isPUNCT(UV ord)
1083     CODE:
1084         RETVAL = isPUNCT(ord);
1085     OUTPUT:
1086         RETVAL
1087
1088 bool
1089 test_isPUNCT_A(UV ord)
1090     CODE:
1091         RETVAL = isPUNCT_A(ord);
1092     OUTPUT:
1093         RETVAL
1094
1095 bool
1096 test_isXDIGIT(UV ord)
1097     CODE:
1098         RETVAL = isXDIGIT(ord);
1099     OUTPUT:
1100         RETVAL
1101
1102 bool
1103 test_isXDIGIT_A(UV ord)
1104     CODE:
1105         RETVAL = isXDIGIT_A(ord);
1106     OUTPUT:
1107         RETVAL
1108
1109 bool
1110 test_isPSXSPC(UV ord)
1111     CODE:
1112         RETVAL = isPSXSPC(ord);
1113     OUTPUT:
1114         RETVAL
1115
1116 bool
1117 test_isPSXSPC_A(UV ord)
1118     CODE:
1119         RETVAL = isPSXSPC_A(ord);
1120     OUTPUT:
1121         RETVAL
1122
1123 STRLEN
1124 av_tindex(av)
1125         AV *av
1126         CODE:
1127                 RETVAL = av_tindex(av);
1128         OUTPUT:
1129                 RETVAL
1130
1131 STRLEN
1132 av_top_index(av)
1133         AV *av
1134         CODE:
1135                 RETVAL = av_top_index(av);
1136         OUTPUT:
1137                 RETVAL
1138
1139 =tests plan => 128
1140
1141 use vars qw($my_sv @my_av %my_hv);
1142
1143 ok(&Devel::PPPort::boolSV(1));
1144 ok(!&Devel::PPPort::boolSV(0));
1145
1146 $_ = "Fred";
1147 ok(&Devel::PPPort::DEFSV(), "Fred");
1148 ok(&Devel::PPPort::UNDERBAR(), "Fred");
1149
1150 if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) {
1151   eval q{
1152     no warnings "deprecated";
1153     no if $^V > v5.17.9, warnings => "experimental::lexical_topic";
1154     my $_ = "Tony";
1155     ok(&Devel::PPPort::DEFSV(), "Fred");
1156     ok(&Devel::PPPort::UNDERBAR(), "Tony");
1157   };
1158 }
1159 else {
1160   ok(1);
1161   ok(1);
1162 }
1163
1164 my @r = &Devel::PPPort::DEFSV_modify();
1165
1166 ok(@r == 3);
1167 ok($r[0], 'Fred');
1168 ok($r[1], 'DEFSV');
1169 ok($r[2], 'Fred');
1170
1171 ok(&Devel::PPPort::DEFSV(), "Fred");
1172
1173 eval { 1 };
1174 ok(!&Devel::PPPort::ERRSV());
1175 eval { cannot_call_this_one() };
1176 ok(&Devel::PPPort::ERRSV());
1177
1178 ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
1179 ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
1180 ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
1181
1182 $my_sv = 1;
1183 ok(&Devel::PPPort::get_sv('my_sv', 0));
1184 ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
1185 ok(&Devel::PPPort::get_sv('not_my_sv', 1));
1186
1187 @my_av = (1);
1188 ok(&Devel::PPPort::get_av('my_av', 0));
1189 ok(!&Devel::PPPort::get_av('not_my_av', 0));
1190 ok(&Devel::PPPort::get_av('not_my_av', 1));
1191
1192 %my_hv = (a=>1);
1193 ok(&Devel::PPPort::get_hv('my_hv', 0));
1194 ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
1195 ok(&Devel::PPPort::get_hv('not_my_hv', 1));
1196
1197 sub my_cv { 1 };
1198 ok(&Devel::PPPort::get_cv('my_cv', 0));
1199 ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
1200 ok(&Devel::PPPort::get_cv('not_my_cv', 1));
1201
1202 ok(Devel::PPPort::dXSTARG(42), 43);
1203 ok(Devel::PPPort::dAXMARK(4711), 4710);
1204
1205 ok(Devel::PPPort::prepush(), 42);
1206
1207 ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
1208 ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
1209
1210 ok(Devel::PPPort::PERL_ABS(42), 42);
1211 ok(Devel::PPPort::PERL_ABS(-13), 13);
1212
1213 ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42');
1214 ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');
1215
1216 ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
1217
1218 ok(&Devel::PPPort::ptrtests(), 63);
1219
1220 ok(&Devel::PPPort::OpSIBLING_tests(), 0);
1221
1222 if ("$]" >= 5.009000) {
1223   eval q{
1224     ok(&Devel::PPPort::check_HeUTF8("hello"), "norm");
1225     ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8");
1226   };
1227 } else {
1228   ok(1, 1);
1229   ok(1, 1);
1230 }
1231
1232 @r = &Devel::PPPort::check_c_array();
1233 ok($r[0], 4);
1234 ok($r[1], "13");
1235
1236 ok(!Devel::PPPort::SvRXOK(""));
1237 ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));
1238
1239 if ("$]" < 5.005) {
1240         skip 'no qr// objects in this perl', 0;
1241         skip 'no qr// objects in this perl', 0;
1242 } else {
1243         my $qr = eval 'qr/./';
1244         ok(Devel::PPPort::SvRXOK($qr));
1245         ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise"));
1246 }
1247
1248 ok(  Devel::PPPort::test_isBLANK(ord(" ")));
1249 ok(! Devel::PPPort::test_isBLANK(ord("\n")));
1250
1251 ok(  Devel::PPPort::test_isBLANK_A(ord("\t")));
1252 ok(! Devel::PPPort::test_isBLANK_A(ord("\r")));
1253
1254 ok(  Devel::PPPort::test_isUPPER(ord("A")));
1255 ok(! Devel::PPPort::test_isUPPER(ord("a")));
1256
1257 ok(  Devel::PPPort::test_isUPPER_A(ord("Z")));
1258
1259 # One of these two is uppercase in EBCDIC; the other in Latin1, but neither are
1260 # ASCII uppercase.
1261 ok(! Devel::PPPort::test_isUPPER_A(ord(0xDC)));
1262 ok(! Devel::PPPort::test_isUPPER_A(ord(0xFC)));
1263
1264 ok(  Devel::PPPort::test_isLOWER(ord("b")));
1265 ok(! Devel::PPPort::test_isLOWER(ord("B")));
1266
1267 ok(  Devel::PPPort::test_isLOWER_A(ord("y")));
1268
1269 # One of these two is lowercase in EBCDIC; the other in Latin1, but neither are
1270 # ASCII lowercase.
1271 ok(! Devel::PPPort::test_isLOWER_A(ord(0xDC)));
1272 ok(! Devel::PPPort::test_isLOWER_A(ord(0xFC)));
1273
1274 ok(  Devel::PPPort::test_isALPHA(ord("C")));
1275 ok(! Devel::PPPort::test_isALPHA(ord("1")));
1276
1277 ok(  Devel::PPPort::test_isALPHA_A(ord("x")));
1278 ok(! Devel::PPPort::test_isALPHA_A(0xDC));
1279
1280 ok(  Devel::PPPort::test_isWORDCHAR(ord("_")));
1281 ok(! Devel::PPPort::test_isWORDCHAR(ord("@")));
1282
1283 ok(  Devel::PPPort::test_isWORDCHAR_A(ord("2")));
1284 ok(! Devel::PPPort::test_isWORDCHAR_A(0xFC));
1285
1286 ok(  Devel::PPPort::test_isALPHANUMERIC(ord("4")));
1287 ok(! Devel::PPPort::test_isALPHANUMERIC(ord("_")));
1288
1289 ok(  Devel::PPPort::test_isALPHANUMERIC_A(ord("l")));
1290 ok(! Devel::PPPort::test_isALPHANUMERIC_A(0xDC));
1291
1292 ok(  Devel::PPPort::test_isALNUM(ord("c")));
1293 ok(! Devel::PPPort::test_isALNUM(ord("}")));
1294
1295 ok(  Devel::PPPort::test_isALNUM_A(ord("5")));
1296 ok(! Devel::PPPort::test_isALNUM_A(0xFC));
1297
1298 ok(  Devel::PPPort::test_isDIGIT(ord("6")));
1299 ok(! Devel::PPPort::test_isDIGIT(ord("_")));
1300
1301 ok(  Devel::PPPort::test_isDIGIT_A(ord("7")));
1302 ok(! Devel::PPPort::test_isDIGIT_A(0xDC));
1303
1304 ok(  Devel::PPPort::test_isOCTAL(ord("7")));
1305 ok(! Devel::PPPort::test_isOCTAL(ord("8")));
1306
1307 ok(  Devel::PPPort::test_isOCTAL_A(ord("0")));
1308 ok(! Devel::PPPort::test_isOCTAL_A(ord("9")));
1309
1310 ok(  Devel::PPPort::test_isIDFIRST(ord("D")));
1311 ok(! Devel::PPPort::test_isIDFIRST(ord("1")));
1312
1313 ok(  Devel::PPPort::test_isIDFIRST_A(ord("_")));
1314 ok(! Devel::PPPort::test_isIDFIRST_A(0xFC));
1315
1316 ok(  Devel::PPPort::test_isIDCONT(ord("e")));
1317 ok(! Devel::PPPort::test_isIDCONT(ord("@")));
1318
1319 ok(  Devel::PPPort::test_isIDCONT_A(ord("2")));
1320 ok(! Devel::PPPort::test_isIDCONT_A(0xDC));
1321
1322 ok(  Devel::PPPort::test_isSPACE(ord(" ")));
1323 ok(! Devel::PPPort::test_isSPACE(ord("_")));
1324
1325 ok(  Devel::PPPort::test_isSPACE_A(ord("\cK")));
1326 ok(! Devel::PPPort::test_isSPACE_A(ord("F")));
1327
1328 # This stresses the edge for ASCII machines, but happens to work on EBCDIC as
1329 # well
1330 ok(  Devel::PPPort::test_isASCII(0x7F));
1331 ok(! Devel::PPPort::test_isASCII(0x80));
1332
1333 ok(  Devel::PPPort::test_isASCII_A(ord("9")));
1334
1335 # B6 is the PARAGRAPH SIGN in ASCII and EBCDIC
1336 ok(! Devel::PPPort::test_isASCII_A(0xB6));
1337
1338 ok(  Devel::PPPort::test_isCNTRL(ord("\e")));
1339 ok(! Devel::PPPort::test_isCNTRL(ord(" ")));
1340
1341 ok(  Devel::PPPort::test_isCNTRL_A(ord("\a")));
1342 ok(! Devel::PPPort::test_isCNTRL_A(0xB6));
1343
1344 ok(  Devel::PPPort::test_isPRINT(ord(" ")));
1345 ok(! Devel::PPPort::test_isPRINT(ord("\n")));
1346
1347 ok(  Devel::PPPort::test_isPRINT_A(ord("G")));
1348 ok(! Devel::PPPort::test_isPRINT_A(0xB6));
1349
1350 ok(  Devel::PPPort::test_isGRAPH(ord("h")));
1351 ok(! Devel::PPPort::test_isGRAPH(ord(" ")));
1352
1353 ok(  Devel::PPPort::test_isGRAPH_A(ord("i")));
1354 ok(! Devel::PPPort::test_isGRAPH_A(0xB6));
1355
1356 ok(  Devel::PPPort::test_isPUNCT(ord("#")));
1357 ok(! Devel::PPPort::test_isPUNCT(ord(" ")));
1358
1359 ok(  Devel::PPPort::test_isPUNCT_A(ord("*")));
1360 ok(! Devel::PPPort::test_isPUNCT_A(0xB6));
1361
1362 ok(  Devel::PPPort::test_isXDIGIT(ord("A")));
1363 ok(! Devel::PPPort::test_isXDIGIT(ord("_")));
1364
1365 ok(  Devel::PPPort::test_isXDIGIT_A(ord("9")));
1366 ok(! Devel::PPPort::test_isXDIGIT_A(0xDC));
1367
1368 ok(  Devel::PPPort::test_isPSXSPC(ord(" ")));
1369 ok(! Devel::PPPort::test_isPSXSPC(ord("k")));
1370
1371 ok(  Devel::PPPort::test_isPSXSPC_A(ord("\cK")));
1372 ok(! Devel::PPPort::test_isPSXSPC_A(0xFC));
1373
1374 ok(&Devel::PPPort::av_top_index([1,2,3]), 2);
1375 ok(&Devel::PPPort::av_tindex([1,2,3,4]), 3);