1 #if 0
2 <<'SKIP';
3 #endif
4 /*
5 ----------------------------------------------------------------------
6
7 ./ppport.h -- Perl/Pollution/Portability Version 3.35
8
9 Automatically created by Devel::PPPort running under perl 5.024001.
10
11 Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz.
12
13 Version 2.x, Copyright (C) 2001, Paul Marquess.
14
15 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
16
17 This program is free software; you can redistribute it and/or
18 modify it under the same terms as Perl itself.
19
20 ----------------------------------------------------------------------
21
22 SKIP
23 if (@ARGV && $ARGV[0] eq '--unstrip') {
24 eval { require Devel::PPPort };
25 $@ and die "Cannot require Devel::PPPort, please install.\n";
26 if (eval $Devel::PPPort::VERSION < 3.35) {
27 die "./ppport.h was originally generated with Devel::PPPort 3.35.\n"
28 . "Your Devel::PPPort is only version $Devel::PPPort::VERSION.\n"
29 . "Please install a newer version, or --unstrip will not work.\n";
30 }
31 Devel::PPPort::WriteFile($0);
32 exit 0;
33 }
34 print <<END;
35
36 Sorry, but this is a stripped version of $0.
37
38 To be able to use its original script and doc functionality,
39 please try to regenerate this file using:
40
41 $^X $0 --unstrip
42
43 END
44 __DATA__*/
45 #ifndef _P_P_PORTABILITY_H_
46 #define _P_P_PORTABILITY_H_
47 #ifndef DPPP_NAMESPACE
48 #define DPPP_NAMESPACE DPPP_
49 #endif
50 #define DPPP_CAT2(x,y) CAT2(x,y)
51 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
52 #ifndef PERL_REVISION
53 #if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
54 #define PERL_PATCHLEVEL_H_IMPLICIT
55 #include <patchlevel.h>
56 #endif
57 #if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
58 #include <could_not_find_Perl_patchlevel.h>
59 #endif
60 #ifndef PERL_REVISION
61 #define PERL_REVISION (5)
62 #define PERL_VERSION PATCHLEVEL
63 #define PERL_SUBVERSION SUBVERSION
64 #endif
65 #endif
66 #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
67 #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION))
68 #if PERL_REVISION != 5
69 #error ./ppport.h only works with Perl version 5
70 #endif
71 #ifndef dTHR
72 #define dTHR dNOOP
73 #endif
74 #ifndef dTHX
75 #define dTHX dNOOP
76 #endif
77 #ifndef dTHXa
78 #define dTHXa(x) dNOOP
79 #endif
80 #ifndef pTHX
81 #define pTHX void
82 #endif
83 #ifndef pTHX_
84 #define pTHX_
85 #endif
86 #ifndef aTHX
87 #define aTHX
88 #endif
89 #ifndef aTHX_
90 #define aTHX_
91 #endif
92 #if (PERL_BCDVERSION < 0x5006000)
93 #ifdef USE_THREADS
94 #define aTHXR thr
95 #define aTHXR_ thr,
96 #else
97 #define aTHXR
98 #define aTHXR_
99 #endif
100 #define dTHXR dTHR
101 #else
102 #define aTHXR aTHX
103 #define aTHXR_ aTHX_
104 #define dTHXR dTHX
105 #endif
106 #ifndef dTHXoa
107 #define dTHXoa(x) dTHXa(x)
108 #endif
109 #ifdef I_LIMITS
110 #include <limits.h>
111 #endif
112 #ifndef PERL_UCHAR_MIN
113 #define PERL_UCHAR_MIN ((unsigned char)0)
114 #endif
115 #ifndef PERL_UCHAR_MAX
116 #ifdef UCHAR_MAX
117 #define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
118 #else
119 #ifdef MAXUCHAR
120 #define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
121 #else
122 #define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
123 #endif
124 #endif
125 #endif
126 #ifndef PERL_USHORT_MIN
127 #define PERL_USHORT_MIN ((unsigned short)0)
128 #endif
129 #ifndef PERL_USHORT_MAX
130 #ifdef USHORT_MAX
131 #define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
132 #else
133 #ifdef MAXUSHORT
134 #define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
135 #else
136 #ifdef USHRT_MAX
137 #define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
138 #else
139 #define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
140 #endif
141 #endif
142 #endif
143 #endif
144 #ifndef PERL_SHORT_MAX
145 #ifdef SHORT_MAX
146 #define PERL_SHORT_MAX ((short)SHORT_MAX)
147 #else
148 #ifdef MAXSHORT
149 #define PERL_SHORT_MAX ((short)MAXSHORT)
150 #else
151 #ifdef SHRT_MAX
152 #define PERL_SHORT_MAX ((short)SHRT_MAX)
153 #else
154 #define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
155 #endif
156 #endif
157 #endif
158 #endif
159 #ifndef PERL_SHORT_MIN
160 #ifdef SHORT_MIN
161 #define PERL_SHORT_MIN ((short)SHORT_MIN)
162 #else
163 #ifdef MINSHORT
164 #define PERL_SHORT_MIN ((short)MINSHORT)
165 #else
166 #ifdef SHRT_MIN
167 #define PERL_SHORT_MIN ((short)SHRT_MIN)
168 #else
169 #define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
170 #endif
171 #endif
172 #endif
173 #endif
174 #ifndef PERL_UINT_MAX
175 #ifdef UINT_MAX
176 #define PERL_UINT_MAX ((unsigned int)UINT_MAX)
177 #else
178 #ifdef MAXUINT
179 #define PERL_UINT_MAX ((unsigned int)MAXUINT)
180 #else
181 #define PERL_UINT_MAX (~(unsigned int)0)
182 #endif
183 #endif
184 #endif
185 #ifndef PERL_UINT_MIN
186 #define PERL_UINT_MIN ((unsigned int)0)
187 #endif
188 #ifndef PERL_INT_MAX
189 #ifdef INT_MAX
190 #define PERL_INT_MAX ((int)INT_MAX)
191 #else
192 #ifdef MAXINT
193 #define PERL_INT_MAX ((int)MAXINT)
194 #else
195 #define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
196 #endif
197 #endif
198 #endif
199 #ifndef PERL_INT_MIN
200 #ifdef INT_MIN
201 #define PERL_INT_MIN ((int)INT_MIN)
202 #else
203 #ifdef MININT
204 #define PERL_INT_MIN ((int)MININT)
205 #else
206 #define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
207 #endif
208 #endif
209 #endif
210 #ifndef PERL_ULONG_MAX
211 #ifdef ULONG_MAX
212 #define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
213 #else
214 #ifdef MAXULONG
215 #define PERL_ULONG_MAX ((unsigned long)MAXULONG)
216 #else
217 #define PERL_ULONG_MAX (~(unsigned long)0)
218 #endif
219 #endif
220 #endif
221 #ifndef PERL_ULONG_MIN
222 #define PERL_ULONG_MIN ((unsigned long)0L)
223 #endif
224 #ifndef PERL_LONG_MAX
225 #ifdef LONG_MAX
226 #define PERL_LONG_MAX ((long)LONG_MAX)
227 #else
228 #ifdef MAXLONG
229 #define PERL_LONG_MAX ((long)MAXLONG)
230 #else
231 #define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
232 #endif
233 #endif
234 #endif
235 #ifndef PERL_LONG_MIN
236 #ifdef LONG_MIN
237 #define PERL_LONG_MIN ((long)LONG_MIN)
238 #else
239 #ifdef MINLONG
240 #define PERL_LONG_MIN ((long)MINLONG)
241 #else
242 #define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
243 #endif
244 #endif
245 #endif
246 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
247 #ifndef PERL_UQUAD_MAX
248 #ifdef ULONGLONG_MAX
249 #define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
250 #else
251 #ifdef MAXULONGLONG
252 #define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
253 #else
254 #define PERL_UQUAD_MAX (~(unsigned long long)0)
255 #endif
256 #endif
257 #endif
258 #ifndef PERL_UQUAD_MIN
259 #define PERL_UQUAD_MIN ((unsigned long long)0L)
260 #endif
261 #ifndef PERL_QUAD_MAX
262 #ifdef LONGLONG_MAX
263 #define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
264 #else
265 #ifdef MAXLONGLONG
266 #define PERL_QUAD_MAX ((long long)MAXLONGLONG)
267 #else
268 #define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
269 #endif
270 #endif
271 #endif
272 #ifndef PERL_QUAD_MIN
273 #ifdef LONGLONG_MIN
274 #define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
275 #else
276 #ifdef MINLONGLONG
277 #define PERL_QUAD_MIN ((long long)MINLONGLONG)
278 #else
279 #define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
280 #endif
281 #endif
282 #endif
283 #endif
284 #ifdef HAS_QUAD
285 #ifdef cray
286 #ifndef IVTYPE
287 #define IVTYPE int
288 #endif
289 #ifndef IV_MIN
290 #define IV_MIN PERL_INT_MIN
291 #endif
292 #ifndef IV_MAX
293 #define IV_MAX PERL_INT_MAX
294 #endif
295 #ifndef UV_MIN
296 #define UV_MIN PERL_UINT_MIN
297 #endif
298 #ifndef UV_MAX
299 #define UV_MAX PERL_UINT_MAX
300 #endif
301 #ifdef INTSIZE
302 #ifndef IVSIZE
303 #define IVSIZE INTSIZE
304 #endif
305 #endif
306 #else
307 #if defined(convex) || defined(uts)
308 #ifndef IVTYPE
309 #define IVTYPE long long
310 #endif
311 #ifndef IV_MIN
312 #define IV_MIN PERL_QUAD_MIN
313 #endif
314 #ifndef IV_MAX
315 #define IV_MAX PERL_QUAD_MAX
316 #endif
317 #ifndef UV_MIN
318 #define UV_MIN PERL_UQUAD_MIN
319 #endif
320 #ifndef UV_MAX
321 #define UV_MAX PERL_UQUAD_MAX
322 #endif
323 #ifdef LONGLONGSIZE
324 #ifndef IVSIZE
325 #define IVSIZE LONGLONGSIZE
326 #endif
327 #endif
328 #else
329 #ifndef IVTYPE
330 #define IVTYPE long
331 #endif
332 #ifndef IV_MIN
333 #define IV_MIN PERL_LONG_MIN
334 #endif
335 #ifndef IV_MAX
336 #define IV_MAX PERL_LONG_MAX
337 #endif
338 #ifndef UV_MIN
339 #define UV_MIN PERL_ULONG_MIN
340 #endif
341 #ifndef UV_MAX
342 #define UV_MAX PERL_ULONG_MAX
343 #endif
344 #ifdef LONGSIZE
345 #ifndef IVSIZE
346 #define IVSIZE LONGSIZE
347 #endif
348 #endif
349 #endif
350 #endif
351 #ifndef IVSIZE
352 #define IVSIZE 8
353 #endif
354 #ifndef LONGSIZE
355 #define LONGSIZE 8
356 #endif
357 #ifndef PERL_QUAD_MIN
358 #define PERL_QUAD_MIN IV_MIN
359 #endif
360 #ifndef PERL_QUAD_MAX
361 #define PERL_QUAD_MAX IV_MAX
362 #endif
363 #ifndef PERL_UQUAD_MIN
364 #define PERL_UQUAD_MIN UV_MIN
365 #endif
366 #ifndef PERL_UQUAD_MAX
367 #define PERL_UQUAD_MAX UV_MAX
368 #endif
369 #else
370 #ifndef IVTYPE
371 #define IVTYPE long
372 #endif
373 #ifndef LONGSIZE
374 #define LONGSIZE 4
375 #endif
376 #ifndef IV_MIN
377 #define IV_MIN PERL_LONG_MIN
378 #endif
379 #ifndef IV_MAX
380 #define IV_MAX PERL_LONG_MAX
381 #endif
382 #ifndef UV_MIN
383 #define UV_MIN PERL_ULONG_MIN
384 #endif
385 #ifndef UV_MAX
386 #define UV_MAX PERL_ULONG_MAX
387 #endif
388 #endif
389 #ifndef IVSIZE
390 #ifdef LONGSIZE
391 #define IVSIZE LONGSIZE
392 #else
393 #define IVSIZE 4
394 #endif
395 #endif
396 #ifndef UVTYPE
397 #define UVTYPE unsigned IVTYPE
398 #endif
399 #ifndef UVSIZE
400 #define UVSIZE IVSIZE
401 #endif
402 #ifndef sv_setuv
403 #define sv_setuv(sv, uv) \
404 STMT_START { \
405 UV TeMpUv = uv; \
406 if (TeMpUv <= IV_MAX) \
407 sv_setiv(sv, TeMpUv); \
408 else \
409 sv_setnv(sv, (double)TeMpUv); \
410 } STMT_END
411 #endif
412 #ifndef newSVuv
413 #define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
414 #endif
415 #ifndef sv_2uv
416 #define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
417 #endif
418 #ifndef SvUVX
419 #define SvUVX(sv) ((UV)SvIVX(sv))
420 #endif
421 #ifndef SvUVXx
422 #define SvUVXx(sv) SvUVX(sv)
423 #endif
424 #ifndef SvUV
425 #define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
426 #endif
427 #ifndef SvUVx
428 #define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
429 #endif
430 #ifndef sv_uv
431 #define sv_uv(sv) SvUVx(sv)
432 #endif
433 #if !defined(SvUOK) && defined(SvIOK_UV)
434 #define SvUOK(sv) SvIOK_UV(sv)
435 #endif
436 #ifndef XST_mUV
437 #define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
438 #endif
439 #ifndef XSRETURN_UV
440 #define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
441 #endif
442 #ifndef PUSHu
443 #define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
444 #endif
445 #ifndef XPUSHu
446 #define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
447 #endif
448 #ifdef HAS_MEMCMP
449 #ifndef memNE
450 #define memNE(s1,s2,l) (memcmp(s1,s2,l))
451 #endif
452 #ifndef memEQ
453 #define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
454 #endif
455 #else
456 #ifndef memNE
457 #define memNE(s1,s2,l) (bcmp(s1,s2,l))
458 #endif
459 #ifndef memEQ
460 #define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
461 #endif
462 #endif
463 #ifndef memEQs
464 #define memEQs(s1, l, s2) \
465 (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
466 #endif
467 #ifndef memNEs
468 #define memNEs(s1, l, s2) !memEQs(s1, l, s2)
469 #endif
470 #ifndef MoveD
471 #define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
472 #endif
473 #ifndef CopyD
474 #define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
475 #endif
476 #ifdef HAS_MEMSET
477 #ifndef ZeroD
478 #define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
479 #endif
480 #else
481 #ifndef ZeroD
482 #define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
483 #endif
484 #endif
485 #ifndef PoisonWith
486 #define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
487 #endif
488 #ifndef PoisonNew
489 #define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
490 #endif
491 #ifndef PoisonFree
492 #define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
493 #endif
494 #ifndef Poison
495 #define Poison(d,n,t) PoisonFree(d,n,t)
496 #endif
497 #ifndef Newx
498 #define Newx(v,n,t) New(0,v,n,t)
499 #endif
500 #ifndef Newxc
501 #define Newxc(v,n,t,c) Newc(0,v,n,t,c)
502 #endif
503 #ifndef Newxz
504 #define Newxz(v,n,t) Newz(0,v,n,t)
505 #endif
506 #ifndef PERL_MAGIC_qr
507 #define PERL_MAGIC_qr 'r'
508 #endif
509 #ifndef cBOOL
510 #define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
511 #endif
512 #ifndef OpHAS_SIBLING
513 #define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
514 #endif
515 #ifndef OpSIBLING
516 #define OpSIBLING(o) (0 + (o)->op_sibling)
517 #endif
518 #ifndef OpMORESIB_set
519 #define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
520 #endif
521 #ifndef OpLASTSIB_set
522 #define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
523 #endif
524 #ifndef OpMAYBESIB_set
525 #define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
526 #endif
527 #ifndef SvRX
528 #if defined(NEED_SvRX)
529 static void * DPPP_(my_SvRX)(pTHX_ SV *rv);
530 static
531 #else
532 extern void * DPPP_(my_SvRX)(pTHX_ SV *rv);
533 #endif
534 #ifdef SvRX
535 #undef SvRX
536 #endif
537 #define SvRX(a) DPPP_(my_SvRX)(aTHX_ a)
538 #if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL)
539 void *
DPPP_(my_SvRX)540 DPPP_(my_SvRX)(pTHX_ SV *rv)
541 {
542 if (SvROK(rv)) {
543 SV *sv = SvRV(rv);
544 if (SvMAGICAL(sv)) {
545 MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
546 if (mg && mg->mg_obj) {
547 return mg->mg_obj;
548 }
549 }
550 }
551 return 0;
552 }
553 #endif
554 #endif
555 #ifndef SvRXOK
556 #define SvRXOK(sv) (!!SvRX(sv))
557 #endif
558 #ifndef PERL_UNUSED_DECL
559 #ifdef HASATTRIBUTE
560 #if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
561 #define PERL_UNUSED_DECL
562 #else
563 #define PERL_UNUSED_DECL __attribute__((unused))
564 #endif
565 #else
566 #define PERL_UNUSED_DECL
567 #endif
568 #endif
569 #ifndef PERL_UNUSED_ARG
570 #if defined(lint) && defined(S_SPLINT_S)
571 #include <note.h>
572 #define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
573 #else
574 #define PERL_UNUSED_ARG(x) ((void)x)
575 #endif
576 #endif
577 #ifndef PERL_UNUSED_VAR
578 #define PERL_UNUSED_VAR(x) ((void)x)
579 #endif
580 #ifndef PERL_UNUSED_CONTEXT
581 #ifdef USE_ITHREADS
582 #define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
583 #else
584 #define PERL_UNUSED_CONTEXT
585 #endif
586 #endif
587 #ifndef PERL_UNUSED_RESULT
588 #if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
589 #define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
590 #else
591 #define PERL_UNUSED_RESULT(v) ((void)(v))
592 #endif
593 #endif
594 #ifndef NOOP
595 #define NOOP (void)0
596 #endif
597 #ifndef dNOOP
598 #define dNOOP extern int Perl___notused PERL_UNUSED_DECL
599 #endif
600 #ifndef NVTYPE
601 #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
602 #define NVTYPE long double
603 #else
604 #define NVTYPE double
605 #endif
606 typedef NVTYPE NV;
607 #endif
608 #ifndef INT2PTR
609 #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
610 #define PTRV UV
611 #define INT2PTR(any,d) (any)(d)
612 #else
613 #if PTRSIZE == LONGSIZE
614 #define PTRV unsigned long
615 #else
616 #define PTRV unsigned
617 #endif
618 #define INT2PTR(any,d) (any)(PTRV)(d)
619 #endif
620 #endif
621 #ifndef PTR2ul
622 #if PTRSIZE == LONGSIZE
623 #define PTR2ul(p) (unsigned long)(p)
624 #else
625 #define PTR2ul(p) INT2PTR(unsigned long,p)
626 #endif
627 #endif
628 #ifndef PTR2nat
629 #define PTR2nat(p) (PTRV)(p)
630 #endif
631 #ifndef NUM2PTR
632 #define NUM2PTR(any,d) (any)PTR2nat(d)
633 #endif
634 #ifndef PTR2IV
635 #define PTR2IV(p) INT2PTR(IV,p)
636 #endif
637 #ifndef PTR2UV
638 #define PTR2UV(p) INT2PTR(UV,p)
639 #endif
640 #ifndef PTR2NV
641 #define PTR2NV(p) NUM2PTR(NV,p)
642 #endif
643 #undef START_EXTERN_C
644 #undef END_EXTERN_C
645 #undef EXTERN_C
646 #ifdef __cplusplus
647 #define START_EXTERN_C extern "C" {
648 #define END_EXTERN_C }
649 #define EXTERN_C extern "C"
650 #else
651 #define START_EXTERN_C
652 #define END_EXTERN_C
653 #define EXTERN_C extern
654 #endif
655 #if defined(PERL_GCC_PEDANTIC)
656 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
657 #define PERL_GCC_BRACE_GROUPS_FORBIDDEN
658 #endif
659 #endif
660 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
661 #ifndef PERL_USE_GCC_BRACE_GROUPS
662 #define PERL_USE_GCC_BRACE_GROUPS
663 #endif
664 #endif
665 #undef STMT_START
666 #undef STMT_END
667 #ifdef PERL_USE_GCC_BRACE_GROUPS
668 #define STMT_START (void)(
669 #define STMT_END )
670 #else
671 #if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
672 #define STMT_START if (1)
673 #define STMT_END else (void)0
674 #else
675 #define STMT_START do
676 #define STMT_END while (0)
677 #endif
678 #endif
679 #ifndef boolSV
680 #define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
681 #endif
682 #ifndef DEFSV
683 #define DEFSV GvSV(PL_defgv)
684 #endif
685 #ifndef SAVE_DEFSV
686 #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
687 #endif
688 #ifndef DEFSV_set
689 #define DEFSV_set(sv) (DEFSV = (sv))
690 #endif
691 #ifndef AvFILLp
692 #define AvFILLp AvFILL
693 #endif
694 #ifndef ERRSV
695 #define ERRSV get_sv("@",FALSE)
696 #endif
697 #ifndef gv_stashpvn
698 #define gv_stashpvn(str,len,create) gv_stashpv(str,create)
699 #endif
700 #ifndef get_cv
701 #define get_cv perl_get_cv
702 #endif
703 #ifndef get_sv
704 #define get_sv perl_get_sv
705 #endif
706 #ifndef get_av
707 #define get_av perl_get_av
708 #endif
709 #ifndef get_hv
710 #define get_hv perl_get_hv
711 #endif
712 #ifndef dUNDERBAR
713 #define dUNDERBAR dNOOP
714 #endif
715 #ifndef UNDERBAR
716 #define UNDERBAR DEFSV
717 #endif
718 #ifndef dAX
719 #define dAX I32 ax = MARK - PL_stack_base + 1
720 #endif
721 #ifndef dITEMS
722 #define dITEMS I32 items = SP - MARK
723 #endif
724 #ifndef dXSTARG
725 #define dXSTARG SV * targ = sv_newmortal()
726 #endif
727 #ifndef dAXMARK
728 #define dAXMARK I32 ax = POPMARK; \
729 register SV ** const mark = PL_stack_base + ax++
730 #endif
731 #ifndef XSprePUSH
732 #define XSprePUSH (sp = PL_stack_base + ax - 1)
733 #endif
734 #if (PERL_BCDVERSION < 0x5005000)
735 #undef XSRETURN
736 #define XSRETURN(off) \
737 STMT_START { \
738 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
739 return; \
740 } STMT_END
741 #endif
742 #ifndef XSPROTO
743 #define XSPROTO(name) void name(pTHX_ CV* cv)
744 #endif
745 #ifndef SVfARG
746 #define SVfARG(p) ((void*)(p))
747 #endif
748 #ifndef PERL_ABS
749 #define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
750 #endif
751 #ifndef dVAR
752 #define dVAR dNOOP
753 #endif
754 #ifndef SVf
755 #define SVf "_"
756 #endif
757 #ifndef UTF8_MAXBYTES
758 #define UTF8_MAXBYTES UTF8_MAXLEN
759 #endif
760 #ifndef CPERLscope
761 #define CPERLscope(x) x
762 #endif
763 #ifndef PERL_HASH
764 #define PERL_HASH(hash,str,len) \
765 STMT_START { \
766 const char *s_PeRlHaSh = str; \
767 I32 i_PeRlHaSh = len; \
768 U32 hash_PeRlHaSh = 0; \
769 while (i_PeRlHaSh--) \
770 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
771 (hash) = hash_PeRlHaSh; \
772 } STMT_END
773 #endif
774 #ifndef PERLIO_FUNCS_DECL
775 #ifdef PERLIO_FUNCS_CONST
776 #define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
777 #define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
778 #else
779 #define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
780 #define PERLIO_FUNCS_CAST(funcs) (funcs)
781 #endif
782 #endif
783 #if (PERL_BCDVERSION < 0x5009003)
784 #ifdef ARGSproto
785 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
786 #else
787 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
788 #endif
789 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
790 #endif
791 #ifndef isPSXSPC
792 #define isPSXSPC(c) (isSPACE(c) || (c) == '\v')
793 #endif
794 #ifndef isBLANK
795 #define isBLANK(c) ((c) == ' ' || (c) == '\t')
796 #endif
797 #ifdef EBCDIC
798 #ifndef isALNUMC
799 #define isALNUMC(c) isalnum(c)
800 #endif
801 #ifndef isASCII
802 #define isASCII(c) isascii(c)
803 #endif
804 #ifndef isCNTRL
805 #define isCNTRL(c) iscntrl(c)
806 #endif
807 #ifndef isGRAPH
808 #define isGRAPH(c) isgraph(c)
809 #endif
810 #ifndef isPRINT
811 #define isPRINT(c) isprint(c)
812 #endif
813 #ifndef isPUNCT
814 #define isPUNCT(c) ispunct(c)
815 #endif
816 #ifndef isXDIGIT
817 #define isXDIGIT(c) isxdigit(c)
818 #endif
819 #else
820 #if (PERL_BCDVERSION < 0x5010000)
821 #undef isPRINT
822 #endif
823 #ifdef HAS_QUAD
824 #ifdef U64TYPE
825 #define WIDEST_UTYPE U64TYPE
826 #else
827 #define WIDEST_UTYPE Quad_t
828 #endif
829 #else
830 #define WIDEST_UTYPE U32
831 #endif
832 #ifndef isALNUMC
833 #define isALNUMC(c) (isALPHA(c) || isDIGIT(c))
834 #endif
835 #ifndef isASCII
836 #define isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
837 #endif
838 #ifndef isCNTRL
839 #define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
840 #endif
841 #ifndef isGRAPH
842 #define isGRAPH(c) (isALNUM(c) || isPUNCT(c))
843 #endif
844 #ifndef isPRINT
845 #define isPRINT(c) (((c) >= 32 && (c) < 127))
846 #endif
847 #ifndef isPUNCT
848 #define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
849 #endif
850 #ifndef isXDIGIT
851 #define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
852 #endif
853 #endif
854 #if (PERL_BCDVERSION >= 0x5008000)
855 #ifndef HeUTF8
856 #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
857 SvUTF8(HeKEY_sv(he)) : \
858 (U32)HeKUTF8(he))
859 #endif
860 #endif
861 #ifndef C_ARRAY_LENGTH
862 #define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
863 #endif
864 #ifndef C_ARRAY_END
865 #define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
866 #endif
867 #ifndef PERL_SIGNALS_UNSAFE_FLAG
868 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001
869 #if (PERL_BCDVERSION < 0x5008000)
870 #define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG
871 #else
872 #define D_PPP_PERL_SIGNALS_INIT 0
873 #endif
874 #if defined(NEED_PL_signals)
875 static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
876 #elif defined(NEED_PL_signals_GLOBAL)
877 U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
878 #else
879 extern U32 DPPP_(my_PL_signals);
880 #endif
881 #define PL_signals DPPP_(my_PL_signals)
882 #endif
883 #if (PERL_BCDVERSION <= 0x5005005)
884 #define PL_ppaddr ppaddr
885 #define PL_no_modify no_modify
886 #endif
887 #if (PERL_BCDVERSION <= 0x5004005)
888 #define PL_DBsignal DBsignal
889 #define PL_DBsingle DBsingle
890 #define PL_DBsub DBsub
891 #define PL_DBtrace DBtrace
892 #define PL_Sv Sv
893 #define PL_bufend bufend
894 #define PL_bufptr bufptr
895 #define PL_compiling compiling
896 #define PL_copline copline
897 #define PL_curcop curcop
898 #define PL_curstash curstash
899 #define PL_debstash debstash
900 #define PL_defgv defgv
901 #define PL_diehook diehook
902 #define PL_dirty dirty
903 #define PL_dowarn dowarn
904 #define PL_errgv errgv
905 #define PL_error_count error_count
906 #define PL_expect expect
907 #define PL_hexdigit hexdigit
908 #define PL_hints hints
909 #define PL_in_my in_my
910 #define PL_laststatval laststatval
911 #define PL_lex_state lex_state
912 #define PL_lex_stuff lex_stuff
913 #define PL_linestr linestr
914 #define PL_na na
915 #define PL_perl_destruct_level perl_destruct_level
916 #define PL_perldb perldb
917 #define PL_rsfp_filters rsfp_filters
918 #define PL_rsfp rsfp
919 #define PL_stack_base stack_base
920 #define PL_stack_sp stack_sp
921 #define PL_statcache statcache
922 #define PL_stdingv stdingv
923 #define PL_sv_arenaroot sv_arenaroot
924 #define PL_sv_no sv_no
925 #define PL_sv_undef sv_undef
926 #define PL_sv_yes sv_yes
927 #define PL_tainted tainted
928 #define PL_tainting tainting
929 #define PL_tokenbuf tokenbuf
930 #endif
931 #if (PERL_BCDVERSION >= 0x5009005)
932 #ifdef DPPP_PL_parser_NO_DUMMY
933 #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
934 (croak("panic: PL_parser == NULL in %s:%d", \
935 __FILE__, __LINE__), (yy_parser *) NULL))->var)
936 #else
937 #ifdef DPPP_PL_parser_NO_DUMMY_WARNING
938 #define D_PPP_parser_dummy_warning(var)
939 #else
940 #define D_PPP_parser_dummy_warning(var) \
941 warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
942 #endif
943 #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
944 (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
945 #if defined(NEED_PL_parser)
946 static yy_parser DPPP_(dummy_PL_parser);
947 #elif defined(NEED_PL_parser_GLOBAL)
948 yy_parser DPPP_(dummy_PL_parser);
949 #else
950 extern yy_parser DPPP_(dummy_PL_parser);
951 #endif
952 #endif
953 #define PL_expect D_PPP_my_PL_parser_var(expect)
954 #define PL_copline D_PPP_my_PL_parser_var(copline)
955 #define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
956 #define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
957 #define PL_linestr D_PPP_my_PL_parser_var(linestr)
958 #define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
959 #define PL_bufend D_PPP_my_PL_parser_var(bufend)
960 #define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
961 #define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
962 #define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
963 #define PL_in_my D_PPP_my_PL_parser_var(in_my)
964 #define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
965 #define PL_error_count D_PPP_my_PL_parser_var(error_count)
966 #else
967 #define PL_parser ((void *) 1)
968 #endif
969 #ifndef mPUSHs
970 #define mPUSHs(s) PUSHs(sv_2mortal(s))
971 #endif
972 #ifndef PUSHmortal
973 #define PUSHmortal PUSHs(sv_newmortal())
974 #endif
975 #ifndef mPUSHp
976 #define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l))
977 #endif
978 #ifndef mPUSHn
979 #define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n))
980 #endif
981 #ifndef mPUSHi
982 #define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i))
983 #endif
984 #ifndef mPUSHu
985 #define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u))
986 #endif
987 #ifndef mXPUSHs
988 #define mXPUSHs(s) XPUSHs(sv_2mortal(s))
989 #endif
990 #ifndef XPUSHmortal
991 #define XPUSHmortal XPUSHs(sv_newmortal())
992 #endif
993 #ifndef mXPUSHp
994 #define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END
995 #endif
996 #ifndef mXPUSHn
997 #define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END
998 #endif
999 #ifndef mXPUSHi
1000 #define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END
1001 #endif
1002 #ifndef mXPUSHu
1003 #define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END
1004 #endif
1005 #ifndef call_sv
1006 #define call_sv perl_call_sv
1007 #endif
1008 #ifndef call_pv
1009 #define call_pv perl_call_pv
1010 #endif
1011 #ifndef call_argv
1012 #define call_argv perl_call_argv
1013 #endif
1014 #ifndef call_method
1015 #define call_method perl_call_method
1016 #endif
1017 #ifndef eval_sv
1018 #define eval_sv perl_eval_sv
1019 #endif
1020 #ifndef PERL_LOADMOD_DENY
1021 #define PERL_LOADMOD_DENY 0x1
1022 #endif
1023 #ifndef PERL_LOADMOD_NOIMPORT
1024 #define PERL_LOADMOD_NOIMPORT 0x2
1025 #endif
1026 #ifndef PERL_LOADMOD_IMPORT_OPS
1027 #define PERL_LOADMOD_IMPORT_OPS 0x4
1028 #endif
1029 #ifndef G_METHOD
1030 #define G_METHOD 64
1031 #ifdef call_sv
1032 #undef call_sv
1033 #endif
1034 #if (PERL_BCDVERSION < 0x5006000)
1035 #define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
1036 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
1037 #else
1038 #define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
1039 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
1040 #endif
1041 #endif
1042 #ifndef eval_pv
1043 #if defined(NEED_eval_pv)
1044 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
1045 static
1046 #else
1047 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
1048 #endif
1049 #ifdef eval_pv
1050 #undef eval_pv
1051 #endif
1052 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
1053 #define Perl_eval_pv DPPP_(my_eval_pv)
1054 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
1055 SV*
DPPP_(my_eval_pv)1056 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
1057 {
1058 dSP;
1059 SV* sv = newSVpv(p, 0);
1060 PUSHMARK(sp);
1061 eval_sv(sv, G_SCALAR);
1062 SvREFCNT_dec(sv);
1063 SPAGAIN;
1064 sv = POPs;
1065 PUTBACK;
1066 if (croak_on_error && SvTRUE(GvSV(errgv)))
1067 croak(SvPVx(GvSV(errgv), na));
1068 return sv;
1069 }
1070 #endif
1071 #endif
1072 #ifndef vload_module
1073 #if defined(NEED_vload_module)
1074 static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args);
1075 static
1076 #else
1077 extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args);
1078 #endif
1079 #ifdef vload_module
1080 #undef vload_module
1081 #endif
1082 #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d)
1083 #define Perl_vload_module DPPP_(my_vload_module)
1084 #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
1085 void
DPPP_(my_vload_module)1086 DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args)
1087 {
1088 dTHR;
1089 dVAR;
1090 OP *veop, *imop;
1091 OP * const modname = newSVOP(OP_CONST, 0, name);
1092 SvREADONLY_off(((SVOP*)modname)->op_sv);
1093 modname->op_private |= OPpCONST_BARE;
1094 if (ver) {
1095 veop = newSVOP(OP_CONST, 0, ver);
1096 }
1097 else
1098 veop = NULL;
1099 if (flags & PERL_LOADMOD_NOIMPORT) {
1100 imop = sawparens(newNULLLIST());
1101 }
1102 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
1103 imop = va_arg(*args, OP*);
1104 }
1105 else {
1106 SV *sv;
1107 imop = NULL;
1108 sv = va_arg(*args, SV*);
1109 while (sv) {
1110 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
1111 sv = va_arg(*args, SV*);
1112 }
1113 }
1114 {
1115 const line_t ocopline = PL_copline;
1116 COP * const ocurcop = PL_curcop;
1117 const int oexpect = PL_expect;
1118 #if (PERL_BCDVERSION >= 0x5004000)
1119 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
1120 veop, modname, imop);
1121 #elif (PERL_BCDVERSION > 0x5003000)
1122 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
1123 veop, modname, imop);
1124 #else
1125 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(),
1126 modname, imop);
1127 #endif
1128 PL_expect = oexpect;
1129 PL_copline = ocopline;
1130 PL_curcop = ocurcop;
1131 }
1132 }
1133 #endif
1134 #endif
1135 #ifndef load_module
1136 #if defined(NEED_load_module)
1137 static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...);
1138 static
1139 #else
1140 extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...);
1141 #endif
1142 #ifdef load_module
1143 #undef load_module
1144 #endif
1145 #define load_module DPPP_(my_load_module)
1146 #define Perl_load_module DPPP_(my_load_module)
1147 #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
1148 void
DPPP_(my_load_module)1149 DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
1150 {
1151 va_list args;
1152 va_start(args, ver);
1153 vload_module(flags, name, ver, &args);
1154 va_end(args);
1155 }
1156 #endif
1157 #endif
1158 #ifndef newRV_inc
1159 #define newRV_inc(sv) newRV(sv)
1160 #endif
1161 #ifndef newRV_noinc
1162 #if defined(NEED_newRV_noinc)
1163 static SV * DPPP_(my_newRV_noinc)(SV *sv);
1164 static
1165 #else
1166 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
1167 #endif
1168 #ifdef newRV_noinc
1169 #undef newRV_noinc
1170 #endif
1171 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
1172 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
1173 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
1174 SV *
DPPP_(my_newRV_noinc)1175 DPPP_(my_newRV_noinc)(SV *sv)
1176 {
1177 SV *rv = (SV *)newRV(sv);
1178 SvREFCNT_dec(sv);
1179 return rv;
1180 }
1181 #endif
1182 #endif
1183 #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
1184 #if defined(NEED_newCONSTSUB)
1185 static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
1186 static
1187 #else
1188 extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv);
1189 #endif
1190 #ifdef newCONSTSUB
1191 #undef newCONSTSUB
1192 #endif
1193 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
1194 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
1195 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
1196 #define D_PPP_PL_copline PL_copline
1197 void
DPPP_(my_newCONSTSUB)1198 DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv)
1199 {
1200 U32 oldhints = PL_hints;
1201 HV *old_cop_stash = PL_curcop->cop_stash;
1202 HV *old_curstash = PL_curstash;
1203 line_t oldline = PL_curcop->cop_line;
1204 PL_curcop->cop_line = D_PPP_PL_copline;
1205 PL_hints &= ~HINT_BLOCK_SCOPE;
1206 if (stash)
1207 PL_curstash = PL_curcop->cop_stash = stash;
1208 newSUB(
1209 #if (PERL_BCDVERSION < 0x5003022)
1210 start_subparse(),
1211 #elif (PERL_BCDVERSION == 0x5003022)
1212 start_subparse(0),
1213 #else
1214 start_subparse(FALSE, 0),
1215 #endif
1216 newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
1217 newSVOP(OP_CONST, 0, &PL_sv_no),
1218 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
1219 );
1220 PL_hints = oldhints;
1221 PL_curcop->cop_stash = old_cop_stash;
1222 PL_curstash = old_curstash;
1223 PL_curcop->cop_line = oldline;
1224 }
1225 #endif
1226 #endif
1227 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
1228 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
1229 #ifndef START_MY_CXT
1230 #define START_MY_CXT
1231 #if (PERL_BCDVERSION < 0x5004068)
1232 #define dMY_CXT_SV \
1233 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
1234 #else
1235 #define dMY_CXT_SV \
1236 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
1237 sizeof(MY_CXT_KEY)-1, TRUE)
1238 #endif
1239 #define dMY_CXT \
1240 dMY_CXT_SV; \
1241 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
1242 #define MY_CXT_INIT \
1243 dMY_CXT_SV; \
1244 \
1245 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
1246 Zero(my_cxtp, 1, my_cxt_t); \
1247 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
1248 #define MY_CXT (*my_cxtp)
1249 #define pMY_CXT my_cxt_t *my_cxtp
1250 #define pMY_CXT_ pMY_CXT,
1251 #define _pMY_CXT ,pMY_CXT
1252 #define aMY_CXT my_cxtp
1253 #define aMY_CXT_ aMY_CXT,
1254 #define _aMY_CXT ,aMY_CXT
1255 #endif
1256 #ifndef MY_CXT_CLONE
1257 #define MY_CXT_CLONE \
1258 dMY_CXT_SV; \
1259 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
1260 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
1261 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
1262 #endif
1263 #else
1264 #ifndef START_MY_CXT
1265 #define START_MY_CXT static my_cxt_t my_cxt;
1266 #define dMY_CXT_SV dNOOP
1267 #define dMY_CXT dNOOP
1268 #define MY_CXT_INIT NOOP
1269 #define MY_CXT my_cxt
1270 #define pMY_CXT void
1271 #define pMY_CXT_
1272 #define _pMY_CXT
1273 #define aMY_CXT
1274 #define aMY_CXT_
1275 #define _aMY_CXT
1276 #endif
1277 #ifndef MY_CXT_CLONE
1278 #define MY_CXT_CLONE NOOP
1279 #endif
1280 #endif
1281 #ifndef IVdf
1282 #if IVSIZE == LONGSIZE
1283 #define IVdf "ld"
1284 #define UVuf "lu"
1285 #define UVof "lo"
1286 #define UVxf "lx"
1287 #define UVXf "lX"
1288 #elif IVSIZE == INTSIZE
1289 #define IVdf "d"
1290 #define UVuf "u"
1291 #define UVof "o"
1292 #define UVxf "x"
1293 #define UVXf "X"
1294 #else
1295 #error "cannot define IV/UV formats"
1296 #endif
1297 #endif
1298 #ifndef NVef
1299 #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
1300 defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
1301 #define NVef PERL_PRIeldbl
1302 #define NVff PERL_PRIfldbl
1303 #define NVgf PERL_PRIgldbl
1304 #else
1305 #define NVef "e"
1306 #define NVff "f"
1307 #define NVgf "g"
1308 #endif
1309 #endif
1310 #ifndef SvREFCNT_inc
1311 #ifdef PERL_USE_GCC_BRACE_GROUPS
1312 #define SvREFCNT_inc(sv) \
1313 ({ \
1314 SV * const _sv = (SV*)(sv); \
1315 if (_sv) \
1316 (SvREFCNT(_sv))++; \
1317 _sv; \
1318 })
1319 #else
1320 #define SvREFCNT_inc(sv) \
1321 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
1322 #endif
1323 #endif
1324 #ifndef SvREFCNT_inc_simple
1325 #ifdef PERL_USE_GCC_BRACE_GROUPS
1326 #define SvREFCNT_inc_simple(sv) \
1327 ({ \
1328 if (sv) \
1329 (SvREFCNT(sv))++; \
1330 (SV *)(sv); \
1331 })
1332 #else
1333 #define SvREFCNT_inc_simple(sv) \
1334 ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL)
1335 #endif
1336 #endif
1337 #ifndef SvREFCNT_inc_NN
1338 #ifdef PERL_USE_GCC_BRACE_GROUPS
1339 #define SvREFCNT_inc_NN(sv) \
1340 ({ \
1341 SV * const _sv = (SV*)(sv); \
1342 SvREFCNT(_sv)++; \
1343 _sv; \
1344 })
1345 #else
1346 #define SvREFCNT_inc_NN(sv) \
1347 (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
1348 #endif
1349 #endif
1350 #ifndef SvREFCNT_inc_void
1351 #ifdef PERL_USE_GCC_BRACE_GROUPS
1352 #define SvREFCNT_inc_void(sv) \
1353 ({ \
1354 SV * const _sv = (SV*)(sv); \
1355 if (_sv) \
1356 (void)(SvREFCNT(_sv)++); \
1357 })
1358 #else
1359 #define SvREFCNT_inc_void(sv) \
1360 (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
1361 #endif
1362 #endif
1363 #ifndef SvREFCNT_inc_simple_void
1364 #define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
1365 #endif
1366 #ifndef SvREFCNT_inc_simple_NN
1367 #define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
1368 #endif
1369 #ifndef SvREFCNT_inc_void_NN
1370 #define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
1371 #endif
1372 #ifndef SvREFCNT_inc_simple_void_NN
1373 #define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
1374 #endif
1375 #ifndef newSV_type
1376 #if defined(NEED_newSV_type)
1377 static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
1378 static
1379 #else
1380 extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t);
1381 #endif
1382 #ifdef newSV_type
1383 #undef newSV_type
1384 #endif
1385 #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a)
1386 #define Perl_newSV_type DPPP_(my_newSV_type)
1387 #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL)
1388 SV*
DPPP_(my_newSV_type)1389 DPPP_(my_newSV_type)(pTHX_ svtype const t)
1390 {
1391 SV* const sv = newSV(0);
1392 sv_upgrade(sv, t);
1393 return sv;
1394 }
1395 #endif
1396 #endif
1397 #if (PERL_BCDVERSION < 0x5006000)
1398 #define D_PPP_CONSTPV_ARG(x) ((char *) (x))
1399 #else
1400 #define D_PPP_CONSTPV_ARG(x) (x)
1401 #endif
1402 #ifndef newSVpvn
1403 #define newSVpvn(data,len) ((data) \
1404 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
1405 : newSV(0))
1406 #endif
1407 #ifndef newSVpvn_utf8
1408 #define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
1409 #endif
1410 #ifndef SVf_UTF8
1411 #define SVf_UTF8 0
1412 #endif
1413 #ifndef newSVpvn_flags
1414 #if defined(NEED_newSVpvn_flags)
1415 static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags);
1416 static
1417 #else
1418 extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags);
1419 #endif
1420 #ifdef newSVpvn_flags
1421 #undef newSVpvn_flags
1422 #endif
1423 #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c)
1424 #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags)
1425 #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL)
1426 SV *
DPPP_(my_newSVpvn_flags)1427 DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags)
1428 {
1429 SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len);
1430 SvFLAGS(sv) |= (flags & SVf_UTF8);
1431 return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv;
1432 }
1433 #endif
1434 #endif
1435 #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen)
1436 #define NEED_sv_2pv_flags
1437 #endif
1438 #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL)
1439 #define NEED_sv_2pv_flags_GLOBAL
1440 #endif
1441 #ifndef sv_2pv_nolen
1442 #define sv_2pv_nolen(sv) SvPV_nolen(sv)
1443 #endif
1444 #ifdef SvPVbyte
1445 #if (PERL_BCDVERSION < 0x5007000)
1446 #if defined(NEED_sv_2pvbyte)
1447 static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
1448 static
1449 #else
1450 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp);
1451 #endif
1452 #ifdef sv_2pvbyte
1453 #undef sv_2pvbyte
1454 #endif
1455 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
1456 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
1457 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
1458 char *
DPPP_(my_sv_2pvbyte)1459 DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp)
1460 {
1461 sv_utf8_downgrade(sv,0);
1462 return SvPV(sv,*lp);
1463 }
1464 #endif
1465 #undef SvPVbyte
1466 #define SvPVbyte(sv, lp) \
1467 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
1468 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
1469 #endif
1470 #else
1471 #define SvPVbyte SvPV
1472 #define sv_2pvbyte sv_2pv
1473 #endif
1474 #ifndef sv_2pvbyte_nolen
1475 #define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv)
1476 #endif
1477 #ifndef SV_IMMEDIATE_UNREF
1478 #define SV_IMMEDIATE_UNREF 0
1479 #endif
1480 #ifndef SV_GMAGIC
1481 #define SV_GMAGIC 0
1482 #endif
1483 #ifndef SV_COW_DROP_PV
1484 #define SV_COW_DROP_PV 0
1485 #endif
1486 #ifndef SV_UTF8_NO_ENCODING
1487 #define SV_UTF8_NO_ENCODING 0
1488 #endif
1489 #ifndef SV_NOSTEAL
1490 #define SV_NOSTEAL 0
1491 #endif
1492 #ifndef SV_CONST_RETURN
1493 #define SV_CONST_RETURN 0
1494 #endif
1495 #ifndef SV_MUTABLE_RETURN
1496 #define SV_MUTABLE_RETURN 0
1497 #endif
1498 #ifndef SV_SMAGIC
1499 #define SV_SMAGIC 0
1500 #endif
1501 #ifndef SV_HAS_TRAILING_NUL
1502 #define SV_HAS_TRAILING_NUL 0
1503 #endif
1504 #ifndef SV_COW_SHARED_HASH_KEYS
1505 #define SV_COW_SHARED_HASH_KEYS 0
1506 #endif
1507 #if (PERL_BCDVERSION < 0x5007002)
1508 #if defined(NEED_sv_2pv_flags)
1509 static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
1510 static
1511 #else
1512 extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
1513 #endif
1514 #ifdef sv_2pv_flags
1515 #undef sv_2pv_flags
1516 #endif
1517 #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c)
1518 #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags)
1519 #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL)
1520 char *
DPPP_(my_sv_2pv_flags)1521 DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
1522 {
1523 STRLEN n_a = (STRLEN) flags;
1524 return sv_2pv(sv, lp ? lp : &n_a);
1525 }
1526 #endif
1527 #if defined(NEED_sv_pvn_force_flags)
1528 static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
1529 static
1530 #else
1531 extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags);
1532 #endif
1533 #ifdef sv_pvn_force_flags
1534 #undef sv_pvn_force_flags
1535 #endif
1536 #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c)
1537 #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags)
1538 #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL)
1539 char *
DPPP_(my_sv_pvn_force_flags)1540 DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags)
1541 {
1542 STRLEN n_a = (STRLEN) flags;
1543 return sv_pvn_force(sv, lp ? lp : &n_a);
1544 }
1545 #endif
1546 #endif
1547 #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) )
1548 #define DPPP_SVPV_NOLEN_LP_ARG &PL_na
1549 #else
1550 #define DPPP_SVPV_NOLEN_LP_ARG 0
1551 #endif
1552 #ifndef SvPV_const
1553 #define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
1554 #endif
1555 #ifndef SvPV_mutable
1556 #define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
1557 #endif
1558 #ifndef SvPV_flags
1559 #define SvPV_flags(sv, lp, flags) \
1560 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1561 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
1562 #endif
1563 #ifndef SvPV_flags_const
1564 #define SvPV_flags_const(sv, lp, flags) \
1565 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1566 ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
1567 (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
1568 #endif
1569 #ifndef SvPV_flags_const_nolen
1570 #define SvPV_flags_const_nolen(sv, flags) \
1571 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1572 ? SvPVX_const(sv) : \
1573 (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN))
1574 #endif
1575 #ifndef SvPV_flags_mutable
1576 #define SvPV_flags_mutable(sv, lp, flags) \
1577 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1578 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
1579 sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
1580 #endif
1581 #ifndef SvPV_force
1582 #define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
1583 #endif
1584 #ifndef SvPV_force_nolen
1585 #define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
1586 #endif
1587 #ifndef SvPV_force_mutable
1588 #define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC)
1589 #endif
1590 #ifndef SvPV_force_nomg
1591 #define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
1592 #endif
1593 #ifndef SvPV_force_nomg_nolen
1594 #define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
1595 #endif
1596 #ifndef SvPV_force_flags
1597 #define SvPV_force_flags(sv, lp, flags) \
1598 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
1599 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
1600 #endif
1601 #ifndef SvPV_force_flags_nolen
1602 #define SvPV_force_flags_nolen(sv, flags) \
1603 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
1604 ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags))
1605 #endif
1606 #ifndef SvPV_force_flags_mutable
1607 #define SvPV_force_flags_mutable(sv, lp, flags) \
1608 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
1609 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
1610 : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
1611 #endif
1612 #ifndef SvPV_nolen
1613 #define SvPV_nolen(sv) \
1614 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1615 ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC))
1616 #endif
1617 #ifndef SvPV_nolen_const
1618 #define SvPV_nolen_const(sv) \
1619 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1620 ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN))
1621 #endif
1622 #ifndef SvPV_nomg
1623 #define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
1624 #endif
1625 #ifndef SvPV_nomg_const
1626 #define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
1627 #endif
1628 #ifndef SvPV_nomg_const_nolen
1629 #define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
1630 #endif
1631 #ifndef SvPV_nomg_nolen
1632 #define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
1633 ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0))
1634 #endif
1635 #ifndef SvPV_renew
1636 #define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \
1637 SvPV_set((sv), (char *) saferealloc( \
1638 (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \
1639 } STMT_END
1640 #endif
1641 #ifndef SvMAGIC_set
1642 #define SvMAGIC_set(sv, val) \
1643 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
1644 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
1645 #endif
1646 #if (PERL_BCDVERSION < 0x5009003)
1647 #ifndef SvPVX_const
1648 #define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
1649 #endif
1650 #ifndef SvPVX_mutable
1651 #define SvPVX_mutable(sv) (0 + SvPVX(sv))
1652 #endif
1653 #ifndef SvRV_set
1654 #define SvRV_set(sv, val) \
1655 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
1656 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
1657 #endif
1658 #else
1659 #ifndef SvPVX_const
1660 #define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
1661 #endif
1662 #ifndef SvPVX_mutable
1663 #define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
1664 #endif
1665 #ifndef SvRV_set
1666 #define SvRV_set(sv, val) \
1667 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
1668 ((sv)->sv_u.svu_rv = (val)); } STMT_END
1669 #endif
1670 #endif
1671 #ifndef SvSTASH_set
1672 #define SvSTASH_set(sv, val) \
1673 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
1674 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
1675 #endif
1676 #if (PERL_BCDVERSION < 0x5004000)
1677 #ifndef SvUV_set
1678 #define SvUV_set(sv, val) \
1679 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
1680 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
1681 #endif
1682 #else
1683 #ifndef SvUV_set
1684 #define SvUV_set(sv, val) \
1685 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
1686 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
1687 #endif
1688 #endif
1689 #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf)
1690 #if defined(NEED_vnewSVpvf)
1691 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
1692 static
1693 #else
1694 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args);
1695 #endif
1696 #ifdef vnewSVpvf
1697 #undef vnewSVpvf
1698 #endif
1699 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
1700 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
1701 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
1702 SV *
DPPP_(my_vnewSVpvf)1703 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
1704 {
1705 register SV *sv = newSV(0);
1706 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
1707 return sv;
1708 }
1709 #endif
1710 #endif
1711 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf)
1712 #define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
1713 #endif
1714 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf)
1715 #define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
1716 #endif
1717 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg)
1718 #if defined(NEED_sv_catpvf_mg)
1719 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
1720 static
1721 #else
1722 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
1723 #endif
1724 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
1725 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
1726 void
DPPP_(my_sv_catpvf_mg)1727 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
1728 {
1729 va_list args;
1730 va_start(args, pat);
1731 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1732 SvSETMAGIC(sv);
1733 va_end(args);
1734 }
1735 #endif
1736 #endif
1737 #ifdef PERL_IMPLICIT_CONTEXT
1738 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
1739 #if defined(NEED_sv_catpvf_mg_nocontext)
1740 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...);
1741 static
1742 #else
1743 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...);
1744 #endif
1745 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
1746 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
1747 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
1748 void
DPPP_(my_sv_catpvf_mg_nocontext)1749 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
1750 {
1751 dTHX;
1752 va_list args;
1753 va_start(args, pat);
1754 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1755 SvSETMAGIC(sv);
1756 va_end(args);
1757 }
1758 #endif
1759 #endif
1760 #endif
1761 #ifndef sv_catpvf_mg
1762 #ifdef PERL_IMPLICIT_CONTEXT
1763 #define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
1764 #else
1765 #define sv_catpvf_mg Perl_sv_catpvf_mg
1766 #endif
1767 #endif
1768 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg)
1769 #define sv_vcatpvf_mg(sv, pat, args) \
1770 STMT_START { \
1771 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
1772 SvSETMAGIC(sv); \
1773 } STMT_END
1774 #endif
1775 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg)
1776 #if defined(NEED_sv_setpvf_mg)
1777 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
1778 static
1779 #else
1780 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...);
1781 #endif
1782 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
1783 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
1784 void
DPPP_(my_sv_setpvf_mg)1785 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
1786 {
1787 va_list args;
1788 va_start(args, pat);
1789 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1790 SvSETMAGIC(sv);
1791 va_end(args);
1792 }
1793 #endif
1794 #endif
1795 #ifdef PERL_IMPLICIT_CONTEXT
1796 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
1797 #if defined(NEED_sv_setpvf_mg_nocontext)
1798 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...);
1799 static
1800 #else
1801 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...);
1802 #endif
1803 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
1804 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
1805 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
1806 void
DPPP_(my_sv_setpvf_mg_nocontext)1807 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
1808 {
1809 dTHX;
1810 va_list args;
1811 va_start(args, pat);
1812 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
1813 SvSETMAGIC(sv);
1814 va_end(args);
1815 }
1816 #endif
1817 #endif
1818 #endif
1819 #ifndef sv_setpvf_mg
1820 #ifdef PERL_IMPLICIT_CONTEXT
1821 #define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
1822 #else
1823 #define sv_setpvf_mg Perl_sv_setpvf_mg
1824 #endif
1825 #endif
1826 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg)
1827 #define sv_vsetpvf_mg(sv, pat, args) \
1828 STMT_START { \
1829 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
1830 SvSETMAGIC(sv); \
1831 } STMT_END
1832 #endif
1833 #ifndef newSVpvn_share
1834 #if defined(NEED_newSVpvn_share)
1835 static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
1836 static
1837 #else
1838 extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash);
1839 #endif
1840 #ifdef newSVpvn_share
1841 #undef newSVpvn_share
1842 #endif
1843 #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
1844 #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
1845 #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
1846 SV *
DPPP_(my_newSVpvn_share)1847 DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash)
1848 {
1849 SV *sv;
1850 if (len < 0)
1851 len = -len;
1852 if (!hash)
1853 PERL_HASH(hash, (char*) src, len);
1854 sv = newSVpvn((char *) src, len);
1855 sv_upgrade(sv, SVt_PVIV);
1856 SvIVX(sv) = hash;
1857 SvREADONLY_on(sv);
1858 SvPOK_on(sv);
1859 return sv;
1860 }
1861 #endif
1862 #endif
1863 #ifndef SvSHARED_HASH
1864 #define SvSHARED_HASH(sv) (0 + SvUVX(sv))
1865 #endif
1866 #ifndef HvNAME_get
1867 #define HvNAME_get(hv) HvNAME(hv)
1868 #endif
1869 #ifndef HvNAMELEN_get
1870 #define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
1871 #endif
1872 #ifndef gv_fetchpvn_flags
1873 #if defined(NEED_gv_fetchpvn_flags)
1874 static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types);
1875 static
1876 #else
1877 extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types);
1878 #endif
1879 #ifdef gv_fetchpvn_flags
1880 #undef gv_fetchpvn_flags
1881 #endif
1882 #define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d)
1883 #define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags)
1884 #if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL)
1885 GV*
DPPP_(my_gv_fetchpvn_flags)1886 DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) {
1887 char *namepv = savepvn(name, len);
1888 GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV);
1889 Safefree(namepv);
1890 return stash;
1891 }
1892 #endif
1893 #endif
1894 #ifndef GvSVn
1895 #define GvSVn(gv) GvSV(gv)
1896 #endif
1897 #ifndef isGV_with_GP
1898 #define isGV_with_GP(gv) isGV(gv)
1899 #endif
1900 #ifndef gv_fetchsv
1901 #define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt)
1902 #endif
1903 #ifndef get_cvn_flags
1904 #define get_cvn_flags(name, namelen, flags) get_cv(name, flags)
1905 #endif
1906 #ifndef gv_init_pvn
1907 #define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE)
1908 #endif
1909 #ifndef WARN_ALL
1910 #define WARN_ALL 0
1911 #endif
1912 #ifndef WARN_CLOSURE
1913 #define WARN_CLOSURE 1
1914 #endif
1915 #ifndef WARN_DEPRECATED
1916 #define WARN_DEPRECATED 2
1917 #endif
1918 #ifndef WARN_EXITING
1919 #define WARN_EXITING 3
1920 #endif
1921 #ifndef WARN_GLOB
1922 #define WARN_GLOB 4
1923 #endif
1924 #ifndef WARN_IO
1925 #define WARN_IO 5
1926 #endif
1927 #ifndef WARN_CLOSED
1928 #define WARN_CLOSED 6
1929 #endif
1930 #ifndef WARN_EXEC
1931 #define WARN_EXEC 7
1932 #endif
1933 #ifndef WARN_LAYER
1934 #define WARN_LAYER 8
1935 #endif
1936 #ifndef WARN_NEWLINE
1937 #define WARN_NEWLINE 9
1938 #endif
1939 #ifndef WARN_PIPE
1940 #define WARN_PIPE 10
1941 #endif
1942 #ifndef WARN_UNOPENED
1943 #define WARN_UNOPENED 11
1944 #endif
1945 #ifndef WARN_MISC
1946 #define WARN_MISC 12
1947 #endif
1948 #ifndef WARN_NUMERIC
1949 #define WARN_NUMERIC 13
1950 #endif
1951 #ifndef WARN_ONCE
1952 #define WARN_ONCE 14
1953 #endif
1954 #ifndef WARN_OVERFLOW
1955 #define WARN_OVERFLOW 15
1956 #endif
1957 #ifndef WARN_PACK
1958 #define WARN_PACK 16
1959 #endif
1960 #ifndef WARN_PORTABLE
1961 #define WARN_PORTABLE 17
1962 #endif
1963 #ifndef WARN_RECURSION
1964 #define WARN_RECURSION 18
1965 #endif
1966 #ifndef WARN_REDEFINE
1967 #define WARN_REDEFINE 19
1968 #endif
1969 #ifndef WARN_REGEXP
1970 #define WARN_REGEXP 20
1971 #endif
1972 #ifndef WARN_SEVERE
1973 #define WARN_SEVERE 21
1974 #endif
1975 #ifndef WARN_DEBUGGING
1976 #define WARN_DEBUGGING 22
1977 #endif
1978 #ifndef WARN_INPLACE
1979 #define WARN_INPLACE 23
1980 #endif
1981 #ifndef WARN_INTERNAL
1982 #define WARN_INTERNAL 24
1983 #endif
1984 #ifndef WARN_MALLOC
1985 #define WARN_MALLOC 25
1986 #endif
1987 #ifndef WARN_SIGNAL
1988 #define WARN_SIGNAL 26
1989 #endif
1990 #ifndef WARN_SUBSTR
1991 #define WARN_SUBSTR 27
1992 #endif
1993 #ifndef WARN_SYNTAX
1994 #define WARN_SYNTAX 28
1995 #endif
1996 #ifndef WARN_AMBIGUOUS
1997 #define WARN_AMBIGUOUS 29
1998 #endif
1999 #ifndef WARN_BAREWORD
2000 #define WARN_BAREWORD 30
2001 #endif
2002 #ifndef WARN_DIGIT
2003 #define WARN_DIGIT 31
2004 #endif
2005 #ifndef WARN_PARENTHESIS
2006 #define WARN_PARENTHESIS 32
2007 #endif
2008 #ifndef WARN_PRECEDENCE
2009 #define WARN_PRECEDENCE 33
2010 #endif
2011 #ifndef WARN_PRINTF
2012 #define WARN_PRINTF 34
2013 #endif
2014 #ifndef WARN_PROTOTYPE
2015 #define WARN_PROTOTYPE 35
2016 #endif
2017 #ifndef WARN_QW
2018 #define WARN_QW 36
2019 #endif
2020 #ifndef WARN_RESERVED
2021 #define WARN_RESERVED 37
2022 #endif
2023 #ifndef WARN_SEMICOLON
2024 #define WARN_SEMICOLON 38
2025 #endif
2026 #ifndef WARN_TAINT
2027 #define WARN_TAINT 39
2028 #endif
2029 #ifndef WARN_THREADS
2030 #define WARN_THREADS 40
2031 #endif
2032 #ifndef WARN_UNINITIALIZED
2033 #define WARN_UNINITIALIZED 41
2034 #endif
2035 #ifndef WARN_UNPACK
2036 #define WARN_UNPACK 42
2037 #endif
2038 #ifndef WARN_UNTIE
2039 #define WARN_UNTIE 43
2040 #endif
2041 #ifndef WARN_UTF8
2042 #define WARN_UTF8 44
2043 #endif
2044 #ifndef WARN_VOID
2045 #define WARN_VOID 45
2046 #endif
2047 #ifndef WARN_ASSERTIONS
2048 #define WARN_ASSERTIONS 46
2049 #endif
2050 #ifndef packWARN
2051 #define packWARN(a) (a)
2052 #endif
2053 #ifndef ckWARN
2054 #ifdef G_WARN_ON
2055 #define ckWARN(a) (PL_dowarn & G_WARN_ON)
2056 #else
2057 #define ckWARN(a) PL_dowarn
2058 #endif
2059 #endif
2060 #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner)
2061 #if defined(NEED_warner)
2062 static void DPPP_(my_warner)(U32 err, const char *pat, ...);
2063 static
2064 #else
2065 extern void DPPP_(my_warner)(U32 err, const char *pat, ...);
2066 #endif
2067 #define Perl_warner DPPP_(my_warner)
2068 #if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
2069 void
DPPP_(my_warner)2070 DPPP_(my_warner)(U32 err, const char *pat, ...)
2071 {
2072 SV *sv;
2073 va_list args;
2074 PERL_UNUSED_ARG(err);
2075 va_start(args, pat);
2076 sv = vnewSVpvf(pat, &args);
2077 va_end(args);
2078 sv_2mortal(sv);
2079 warn("%s", SvPV_nolen(sv));
2080 }
2081 #define warner Perl_warner
2082 #define Perl_warner_nocontext Perl_warner
2083 #endif
2084 #endif
2085 #ifndef STR_WITH_LEN
2086 #define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
2087 #endif
2088 #ifndef newSVpvs
2089 #define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
2090 #endif
2091 #ifndef newSVpvs_flags
2092 #define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
2093 #endif
2094 #ifndef newSVpvs_share
2095 #define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0)
2096 #endif
2097 #ifndef sv_catpvs
2098 #define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
2099 #endif
2100 #ifndef sv_setpvs
2101 #define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
2102 #endif
2103 #ifndef hv_fetchs
2104 #define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval)
2105 #endif
2106 #ifndef hv_stores
2107 #define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
2108 #endif
2109 #ifndef gv_fetchpvs
2110 #define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
2111 #endif
2112 #ifndef gv_stashpvs
2113 #define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
2114 #endif
2115 #ifndef get_cvs
2116 #define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags)
2117 #endif
2118 #ifndef SvGETMAGIC
2119 #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
2120 #endif
2121 #ifndef HEf_SVKEY
2122 #define HEf_SVKEY -2
2123 #endif
2124 #ifndef MUTABLE_PTR
2125 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
2126 #define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
2127 #else
2128 #define MUTABLE_PTR(p) ((void *) (p))
2129 #endif
2130 #endif
2131 #ifndef MUTABLE_SV
2132 #define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
2133 #endif
2134 #ifndef PERL_MAGIC_sv
2135 #define PERL_MAGIC_sv '\0'
2136 #endif
2137 #ifndef PERL_MAGIC_overload
2138 #define PERL_MAGIC_overload 'A'
2139 #endif
2140 #ifndef PERL_MAGIC_overload_elem
2141 #define PERL_MAGIC_overload_elem 'a'
2142 #endif
2143 #ifndef PERL_MAGIC_overload_table
2144 #define PERL_MAGIC_overload_table 'c'
2145 #endif
2146 #ifndef PERL_MAGIC_bm
2147 #define PERL_MAGIC_bm 'B'
2148 #endif
2149 #ifndef PERL_MAGIC_regdata
2150 #define PERL_MAGIC_regdata 'D'
2151 #endif
2152 #ifndef PERL_MAGIC_regdatum
2153 #define PERL_MAGIC_regdatum 'd'
2154 #endif
2155 #ifndef PERL_MAGIC_env
2156 #define PERL_MAGIC_env 'E'
2157 #endif
2158 #ifndef PERL_MAGIC_envelem
2159 #define PERL_MAGIC_envelem 'e'
2160 #endif
2161 #ifndef PERL_MAGIC_fm
2162 #define PERL_MAGIC_fm 'f'
2163 #endif
2164 #ifndef PERL_MAGIC_regex_global
2165 #define PERL_MAGIC_regex_global 'g'
2166 #endif
2167 #ifndef PERL_MAGIC_isa
2168 #define PERL_MAGIC_isa 'I'
2169 #endif
2170 #ifndef PERL_MAGIC_isaelem
2171 #define PERL_MAGIC_isaelem 'i'
2172 #endif
2173 #ifndef PERL_MAGIC_nkeys
2174 #define PERL_MAGIC_nkeys 'k'
2175 #endif
2176 #ifndef PERL_MAGIC_dbfile
2177 #define PERL_MAGIC_dbfile 'L'
2178 #endif
2179 #ifndef PERL_MAGIC_dbline
2180 #define PERL_MAGIC_dbline 'l'
2181 #endif
2182 #ifndef PERL_MAGIC_mutex
2183 #define PERL_MAGIC_mutex 'm'
2184 #endif
2185 #ifndef PERL_MAGIC_shared
2186 #define PERL_MAGIC_shared 'N'
2187 #endif
2188 #ifndef PERL_MAGIC_shared_scalar
2189 #define PERL_MAGIC_shared_scalar 'n'
2190 #endif
2191 #ifndef PERL_MAGIC_collxfrm
2192 #define PERL_MAGIC_collxfrm 'o'
2193 #endif
2194 #ifndef PERL_MAGIC_tied
2195 #define PERL_MAGIC_tied 'P'
2196 #endif
2197 #ifndef PERL_MAGIC_tiedelem
2198 #define PERL_MAGIC_tiedelem 'p'
2199 #endif
2200 #ifndef PERL_MAGIC_tiedscalar
2201 #define PERL_MAGIC_tiedscalar 'q'
2202 #endif
2203 #ifndef PERL_MAGIC_qr
2204 #define PERL_MAGIC_qr 'r'
2205 #endif
2206 #ifndef PERL_MAGIC_sig
2207 #define PERL_MAGIC_sig 'S'
2208 #endif
2209 #ifndef PERL_MAGIC_sigelem
2210 #define PERL_MAGIC_sigelem 's'
2211 #endif
2212 #ifndef PERL_MAGIC_taint
2213 #define PERL_MAGIC_taint 't'
2214 #endif
2215 #ifndef PERL_MAGIC_uvar
2216 #define PERL_MAGIC_uvar 'U'
2217 #endif
2218 #ifndef PERL_MAGIC_uvar_elem
2219 #define PERL_MAGIC_uvar_elem 'u'
2220 #endif
2221 #ifndef PERL_MAGIC_vstring
2222 #define PERL_MAGIC_vstring 'V'
2223 #endif
2224 #ifndef PERL_MAGIC_vec
2225 #define PERL_MAGIC_vec 'v'
2226 #endif
2227 #ifndef PERL_MAGIC_utf8
2228 #define PERL_MAGIC_utf8 'w'
2229 #endif
2230 #ifndef PERL_MAGIC_substr
2231 #define PERL_MAGIC_substr 'x'
2232 #endif
2233 #ifndef PERL_MAGIC_defelem
2234 #define PERL_MAGIC_defelem 'y'
2235 #endif
2236 #ifndef PERL_MAGIC_glob
2237 #define PERL_MAGIC_glob '*'
2238 #endif
2239 #ifndef PERL_MAGIC_arylen
2240 #define PERL_MAGIC_arylen '#'
2241 #endif
2242 #ifndef PERL_MAGIC_pos
2243 #define PERL_MAGIC_pos '.'
2244 #endif
2245 #ifndef PERL_MAGIC_backref
2246 #define PERL_MAGIC_backref '<'
2247 #endif
2248 #ifndef PERL_MAGIC_ext
2249 #define PERL_MAGIC_ext '~'
2250 #endif
2251 #ifndef sv_catpvn_nomg
2252 #define sv_catpvn_nomg sv_catpvn
2253 #endif
2254 #ifndef sv_catsv_nomg
2255 #define sv_catsv_nomg sv_catsv
2256 #endif
2257 #ifndef sv_setsv_nomg
2258 #define sv_setsv_nomg sv_setsv
2259 #endif
2260 #ifndef sv_pvn_nomg
2261 #define sv_pvn_nomg sv_pvn
2262 #endif
2263 #ifndef SvIV_nomg
2264 #define SvIV_nomg SvIV
2265 #endif
2266 #ifndef SvUV_nomg
2267 #define SvUV_nomg SvUV
2268 #endif
2269 #ifndef sv_catpv_mg
2270 #define sv_catpv_mg(sv, ptr) \
2271 STMT_START { \
2272 SV *TeMpSv = sv; \
2273 sv_catpv(TeMpSv,ptr); \
2274 SvSETMAGIC(TeMpSv); \
2275 } STMT_END
2276 #endif
2277 #ifndef sv_catpvn_mg
2278 #define sv_catpvn_mg(sv, ptr, len) \
2279 STMT_START { \
2280 SV *TeMpSv = sv; \
2281 sv_catpvn(TeMpSv,ptr,len); \
2282 SvSETMAGIC(TeMpSv); \
2283 } STMT_END
2284 #endif
2285 #ifndef sv_catsv_mg
2286 #define sv_catsv_mg(dsv, ssv) \
2287 STMT_START { \
2288 SV *TeMpSv = dsv; \
2289 sv_catsv(TeMpSv,ssv); \
2290 SvSETMAGIC(TeMpSv); \
2291 } STMT_END
2292 #endif
2293 #ifndef sv_setiv_mg
2294 #define sv_setiv_mg(sv, i) \
2295 STMT_START { \
2296 SV *TeMpSv = sv; \
2297 sv_setiv(TeMpSv,i); \
2298 SvSETMAGIC(TeMpSv); \
2299 } STMT_END
2300 #endif
2301 #ifndef sv_setnv_mg
2302 #define sv_setnv_mg(sv, num) \
2303 STMT_START { \
2304 SV *TeMpSv = sv; \
2305 sv_setnv(TeMpSv,num); \
2306 SvSETMAGIC(TeMpSv); \
2307 } STMT_END
2308 #endif
2309 #ifndef sv_setpv_mg
2310 #define sv_setpv_mg(sv, ptr) \
2311 STMT_START { \
2312 SV *TeMpSv = sv; \
2313 sv_setpv(TeMpSv,ptr); \
2314 SvSETMAGIC(TeMpSv); \
2315 } STMT_END
2316 #endif
2317 #ifndef sv_setpvn_mg
2318 #define sv_setpvn_mg(sv, ptr, len) \
2319 STMT_START { \
2320 SV *TeMpSv = sv; \
2321 sv_setpvn(TeMpSv,ptr,len); \
2322 SvSETMAGIC(TeMpSv); \
2323 } STMT_END
2324 #endif
2325 #ifndef sv_setsv_mg
2326 #define sv_setsv_mg(dsv, ssv) \
2327 STMT_START { \
2328 SV *TeMpSv = dsv; \
2329 sv_setsv(TeMpSv,ssv); \
2330 SvSETMAGIC(TeMpSv); \
2331 } STMT_END
2332 #endif
2333 #ifndef sv_setuv_mg
2334 #define sv_setuv_mg(sv, i) \
2335 STMT_START { \
2336 SV *TeMpSv = sv; \
2337 sv_setuv(TeMpSv,i); \
2338 SvSETMAGIC(TeMpSv); \
2339 } STMT_END
2340 #endif
2341 #ifndef sv_usepvn_mg
2342 #define sv_usepvn_mg(sv, ptr, len) \
2343 STMT_START { \
2344 SV *TeMpSv = sv; \
2345 sv_usepvn(TeMpSv,ptr,len); \
2346 SvSETMAGIC(TeMpSv); \
2347 } STMT_END
2348 #endif
2349 #ifndef SvVSTRING_mg
2350 #define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
2351 #endif
2352 #if (PERL_BCDVERSION < 0x5004000)
2353 #elif (PERL_BCDVERSION < 0x5008000)
2354 #define sv_magic_portable(sv, obj, how, name, namlen) \
2355 STMT_START { \
2356 SV *SvMp_sv = (sv); \
2357 char *SvMp_name = (char *) (name); \
2358 I32 SvMp_namlen = (namlen); \
2359 if (SvMp_name && SvMp_namlen == 0) \
2360 { \
2361 MAGIC *mg; \
2362 sv_magic(SvMp_sv, obj, how, 0, 0); \
2363 mg = SvMAGIC(SvMp_sv); \
2364 mg->mg_len = -42; \
2365 mg->mg_ptr = SvMp_name; \
2366 } \
2367 else \
2368 { \
2369 sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
2370 } \
2371 } STMT_END
2372 #else
2373 #define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
2374 #endif
2375 #if !defined(mg_findext)
2376 #if defined(NEED_mg_findext)
2377 static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl);
2378 static
2379 #else
2380 extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl);
2381 #endif
2382 #define mg_findext DPPP_(my_mg_findext)
2383 #define Perl_mg_findext DPPP_(my_mg_findext)
2384 #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL)
2385 MAGIC *
DPPP_(my_mg_findext)2386 DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) {
2387 if (sv) {
2388 MAGIC *mg;
2389 #ifdef AvPAD_NAMELIST
2390 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
2391 #endif
2392 for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
2393 if (mg->mg_type == type && mg->mg_virtual == vtbl)
2394 return mg;
2395 }
2396 }
2397 return NULL;
2398 }
2399 #endif
2400 #endif
2401 #if !defined(sv_unmagicext)
2402 #if defined(NEED_sv_unmagicext)
2403 static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
2404 static
2405 #else
2406 extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
2407 #endif
2408 #ifdef sv_unmagicext
2409 #undef sv_unmagicext
2410 #endif
2411 #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c)
2412 #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext)
2413 #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL)
2414 int
DPPP_(my_sv_unmagicext)2415 DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
2416 {
2417 MAGIC* mg;
2418 MAGIC** mgp;
2419 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2420 return 0;
2421 mgp = &(SvMAGIC(sv));
2422 for (mg = *mgp; mg; mg = *mgp) {
2423 const MGVTBL* const virt = mg->mg_virtual;
2424 if (mg->mg_type == type && virt == vtbl) {
2425 *mgp = mg->mg_moremagic;
2426 if (virt && virt->svt_free)
2427 virt->svt_free(aTHX_ sv, mg);
2428 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
2429 if (mg->mg_len > 0)
2430 Safefree(mg->mg_ptr);
2431 else if (mg->mg_len == HEf_SVKEY)
2432 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
2433 else if (mg->mg_type == PERL_MAGIC_utf8)
2434 Safefree(mg->mg_ptr);
2435 }
2436 if (mg->mg_flags & MGf_REFCOUNTED)
2437 SvREFCNT_dec(mg->mg_obj);
2438 Safefree(mg);
2439 }
2440 else
2441 mgp = &mg->mg_moremagic;
2442 }
2443 if (SvMAGIC(sv)) {
2444 if (SvMAGICAL(sv))
2445 mg_magical(sv);
2446 }
2447 else {
2448 SvMAGICAL_off(sv);
2449 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2450 }
2451 return 0;
2452 }
2453 #endif
2454 #endif
2455 #ifdef USE_ITHREADS
2456 #ifndef CopFILE
2457 #define CopFILE(c) ((c)->cop_file)
2458 #endif
2459 #ifndef CopFILEGV
2460 #define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
2461 #endif
2462 #ifndef CopFILE_set
2463 #define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
2464 #endif
2465 #ifndef CopFILESV
2466 #define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
2467 #endif
2468 #ifndef CopFILEAV
2469 #define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
2470 #endif
2471 #ifndef CopSTASHPV
2472 #define CopSTASHPV(c) ((c)->cop_stashpv)
2473 #endif
2474 #ifndef CopSTASHPV_set
2475 #define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
2476 #endif
2477 #ifndef CopSTASH
2478 #define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
2479 #endif
2480 #ifndef CopSTASH_set
2481 #define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
2482 #endif
2483 #ifndef CopSTASH_eq
2484 #define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
2485 || (CopSTASHPV(c) && HvNAME(hv) \
2486 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
2487 #endif
2488 #else
2489 #ifndef CopFILEGV
2490 #define CopFILEGV(c) ((c)->cop_filegv)
2491 #endif
2492 #ifndef CopFILEGV_set
2493 #define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
2494 #endif
2495 #ifndef CopFILE_set
2496 #define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
2497 #endif
2498 #ifndef CopFILESV
2499 #define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
2500 #endif
2501 #ifndef CopFILEAV
2502 #define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
2503 #endif
2504 #ifndef CopFILE
2505 #define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
2506 #endif
2507 #ifndef CopSTASH
2508 #define CopSTASH(c) ((c)->cop_stash)
2509 #endif
2510 #ifndef CopSTASH_set
2511 #define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
2512 #endif
2513 #ifndef CopSTASHPV
2514 #define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
2515 #endif
2516 #ifndef CopSTASHPV_set
2517 #define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
2518 #endif
2519 #ifndef CopSTASH_eq
2520 #define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
2521 #endif
2522 #endif
2523 #if (PERL_BCDVERSION >= 0x5006000)
2524 #ifndef caller_cx
2525 #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
2526 static I32
DPPP_dopoptosub_at(const PERL_CONTEXT * cxstk,I32 startingblock)2527 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
2528 {
2529 I32 i;
2530 for (i = startingblock; i >= 0; i--) {
2531 register const PERL_CONTEXT * const cx = &cxstk[i];
2532 switch (CxTYPE(cx)) {
2533 default:
2534 continue;
2535 case CXt_EVAL:
2536 case CXt_SUB:
2537 case CXt_FORMAT:
2538 return i;
2539 }
2540 }
2541 return i;
2542 }
2543 #endif
2544 #if defined(NEED_caller_cx)
2545 static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp);
2546 static
2547 #else
2548 extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp);
2549 #endif
2550 #ifdef caller_cx
2551 #undef caller_cx
2552 #endif
2553 #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b)
2554 #define Perl_caller_cx DPPP_(my_caller_cx)
2555 #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
2556 const PERL_CONTEXT *
DPPP_(my_caller_cx)2557 DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
2558 {
2559 register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
2560 register const PERL_CONTEXT *cx;
2561 register const PERL_CONTEXT *ccstack = cxstack;
2562 const PERL_SI *top_si = PL_curstackinfo;
2563 for (;;) {
2564 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
2565 top_si = top_si->si_prev;
2566 ccstack = top_si->si_cxstack;
2567 cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
2568 }
2569 if (cxix < 0)
2570 return NULL;
2571 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
2572 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
2573 count++;
2574 if (!count--)
2575 break;
2576 cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
2577 }
2578 cx = &ccstack[cxix];
2579 if (dbcxp) *dbcxp = cx;
2580 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2581 const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
2582 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
2583 cx = &ccstack[dbcxix];
2584 }
2585 return cx;
2586 }
2587 #endif
2588 #endif
2589 #endif
2590 #ifndef IN_PERL_COMPILETIME
2591 #define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
2592 #endif
2593 #ifndef IN_LOCALE_RUNTIME
2594 #define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
2595 #endif
2596 #ifndef IN_LOCALE_COMPILETIME
2597 #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
2598 #endif
2599 #ifndef IN_LOCALE
2600 #define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
2601 #endif
2602 #ifndef IS_NUMBER_IN_UV
2603 #define IS_NUMBER_IN_UV 0x01
2604 #endif
2605 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
2606 #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
2607 #endif
2608 #ifndef IS_NUMBER_NOT_INT
2609 #define IS_NUMBER_NOT_INT 0x04
2610 #endif
2611 #ifndef IS_NUMBER_NEG
2612 #define IS_NUMBER_NEG 0x08
2613 #endif
2614 #ifndef IS_NUMBER_INFINITY
2615 #define IS_NUMBER_INFINITY 0x10
2616 #endif
2617 #ifndef IS_NUMBER_NAN
2618 #define IS_NUMBER_NAN 0x20
2619 #endif
2620 #ifndef GROK_NUMERIC_RADIX
2621 #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
2622 #endif
2623 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
2624 #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
2625 #endif
2626 #ifndef PERL_SCAN_SILENT_ILLDIGIT
2627 #define PERL_SCAN_SILENT_ILLDIGIT 0x04
2628 #endif
2629 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
2630 #define PERL_SCAN_ALLOW_UNDERSCORES 0x01
2631 #endif
2632 #ifndef PERL_SCAN_DISALLOW_PREFIX
2633 #define PERL_SCAN_DISALLOW_PREFIX 0x02
2634 #endif
2635 #ifndef grok_numeric_radix
2636 #if defined(NEED_grok_numeric_radix)
2637 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
2638 static
2639 #else
2640 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
2641 #endif
2642 #ifdef grok_numeric_radix
2643 #undef grok_numeric_radix
2644 #endif
2645 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
2646 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
2647 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
2648 bool
DPPP_(my_grok_numeric_radix)2649 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
2650 {
2651 #ifdef USE_LOCALE_NUMERIC
2652 #ifdef PL_numeric_radix_sv
2653 if (PL_numeric_radix_sv && IN_LOCALE) {
2654 STRLEN len;
2655 char* radix = SvPV(PL_numeric_radix_sv, len);
2656 if (*sp + len <= send && memEQ(*sp, radix, len)) {
2657 *sp += len;
2658 return TRUE;
2659 }
2660 }
2661 #else
2662 #include <locale.h>
2663 dTHR;
2664 struct lconv *lc = localeconv();
2665 char *radix = lc->decimal_point;
2666 if (radix && IN_LOCALE) {
2667 STRLEN len = strlen(radix);
2668 if (*sp + len <= send && memEQ(*sp, radix, len)) {
2669 *sp += len;
2670 return TRUE;
2671 }
2672 }
2673 #endif
2674 #endif
2675 if (*sp < send && **sp == '.') {
2676 ++*sp;
2677 return TRUE;
2678 }
2679 return FALSE;
2680 }
2681 #endif
2682 #endif
2683 #ifndef grok_number
2684 #if defined(NEED_grok_number)
2685 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
2686 static
2687 #else
2688 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
2689 #endif
2690 #ifdef grok_number
2691 #undef grok_number
2692 #endif
2693 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
2694 #define Perl_grok_number DPPP_(my_grok_number)
2695 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
2696 int
DPPP_(my_grok_number)2697 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
2698 {
2699 const char *s = pv;
2700 const char *send = pv + len;
2701 const UV max_div_10 = UV_MAX / 10;
2702 const char max_mod_10 = UV_MAX % 10;
2703 int numtype = 0;
2704 int sawinf = 0;
2705 int sawnan = 0;
2706 while (s < send && isSPACE(*s))
2707 s++;
2708 if (s == send) {
2709 return 0;
2710 } else if (*s == '-') {
2711 s++;
2712 numtype = IS_NUMBER_NEG;
2713 }
2714 else if (*s == '+')
2715 s++;
2716 if (s == send)
2717 return 0;
2718 if (isDIGIT(*s)) {
2719 UV value = *s - '0';
2720 if (++s < send) {
2721 int digit = *s - '0';
2722 if (digit >= 0 && digit <= 9) {
2723 value = value * 10 + digit;
2724 if (++s < send) {
2725 digit = *s - '0';
2726 if (digit >= 0 && digit <= 9) {
2727 value = value * 10 + digit;
2728 if (++s < send) {
2729 digit = *s - '0';
2730 if (digit >= 0 && digit <= 9) {
2731 value = value * 10 + digit;
2732 if (++s < send) {
2733 digit = *s - '0';
2734 if (digit >= 0 && digit <= 9) {
2735 value = value * 10 + digit;
2736 if (++s < send) {
2737 digit = *s - '0';
2738 if (digit >= 0 && digit <= 9) {
2739 value = value * 10 + digit;
2740 if (++s < send) {
2741 digit = *s - '0';
2742 if (digit >= 0 && digit <= 9) {
2743 value = value * 10 + digit;
2744 if (++s < send) {
2745 digit = *s - '0';
2746 if (digit >= 0 && digit <= 9) {
2747 value = value * 10 + digit;
2748 if (++s < send) {
2749 digit = *s - '0';
2750 if (digit >= 0 && digit <= 9) {
2751 value = value * 10 + digit;
2752 if (++s < send) {
2753 digit = *s - '0';
2754 while (digit >= 0 && digit <= 9
2755 && (value < max_div_10
2756 || (value == max_div_10
2757 && digit <= max_mod_10))) {
2758 value = value * 10 + digit;
2759 if (++s < send)
2760 digit = *s - '0';
2761 else
2762 break;
2763 }
2764 if (digit >= 0 && digit <= 9
2765 && (s < send)) {
2766 do {
2767 s++;
2768 } while (s < send && isDIGIT(*s));
2769 numtype |=
2770 IS_NUMBER_GREATER_THAN_UV_MAX;
2771 goto skip_value;
2772 }
2773 }
2774 }
2775 }
2776 }
2777 }
2778 }
2779 }
2780 }
2781 }
2782 }
2783 }
2784 }
2785 }
2786 }
2787 }
2788 }
2789 }
2790 numtype |= IS_NUMBER_IN_UV;
2791 if (valuep)
2792 *valuep = value;
2793 skip_value:
2794 if (GROK_NUMERIC_RADIX(&s, send)) {
2795 numtype |= IS_NUMBER_NOT_INT;
2796 while (s < send && isDIGIT(*s))
2797 s++;
2798 }
2799 }
2800 else if (GROK_NUMERIC_RADIX(&s, send)) {
2801 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV;
2802 if (s < send && isDIGIT(*s)) {
2803 do {
2804 s++;
2805 } while (s < send && isDIGIT(*s));
2806 if (valuep) {
2807 *valuep = 0;
2808 }
2809 }
2810 else
2811 return 0;
2812 } else if (*s == 'I' || *s == 'i') {
2813 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
2814 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
2815 s++; if (s < send && (*s == 'I' || *s == 'i')) {
2816 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
2817 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
2818 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
2819 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
2820 s++;
2821 }
2822 sawinf = 1;
2823 } else if (*s == 'N' || *s == 'n') {
2824 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
2825 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
2826 s++;
2827 sawnan = 1;
2828 } else
2829 return 0;
2830 if (sawinf) {
2831 numtype &= IS_NUMBER_NEG;
2832 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2833 } else if (sawnan) {
2834 numtype &= IS_NUMBER_NEG;
2835 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
2836 } else if (s < send) {
2837 if (*s == 'e' || *s == 'E') {
2838 numtype &= IS_NUMBER_NEG;
2839 numtype |= IS_NUMBER_NOT_INT;
2840 s++;
2841 if (s < send && (*s == '-' || *s == '+'))
2842 s++;
2843 if (s < send && isDIGIT(*s)) {
2844 do {
2845 s++;
2846 } while (s < send && isDIGIT(*s));
2847 }
2848 else
2849 return 0;
2850 }
2851 }
2852 while (s < send && isSPACE(*s))
2853 s++;
2854 if (s >= send)
2855 return numtype;
2856 if (len == 10 && memEQ(pv, "0 but true", 10)) {
2857 if (valuep)
2858 *valuep = 0;
2859 return IS_NUMBER_IN_UV;
2860 }
2861 return 0;
2862 }
2863 #endif
2864 #endif
2865 #ifndef grok_bin
2866 #if defined(NEED_grok_bin)
2867 static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
2868 static
2869 #else
2870 extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
2871 #endif
2872 #ifdef grok_bin
2873 #undef grok_bin
2874 #endif
2875 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
2876 #define Perl_grok_bin DPPP_(my_grok_bin)
2877 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
2878 UV
DPPP_(my_grok_bin)2879 DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
2880 {
2881 const char *s = start;
2882 STRLEN len = *len_p;
2883 UV value = 0;
2884 NV value_nv = 0;
2885 const UV max_div_2 = UV_MAX / 2;
2886 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
2887 bool overflowed = FALSE;
2888 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
2889 if (len >= 1) {
2890 if (s[0] == 'b') {
2891 s++;
2892 len--;
2893 }
2894 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
2895 s+=2;
2896 len-=2;
2897 }
2898 }
2899 }
2900 for (; len-- && *s; s++) {
2901 char bit = *s;
2902 if (bit == '0' || bit == '1') {
2903 redo:
2904 if (!overflowed) {
2905 if (value <= max_div_2) {
2906 value = (value << 1) | (bit - '0');
2907 continue;
2908 }
2909 warn("Integer overflow in binary number");
2910 overflowed = TRUE;
2911 value_nv = (NV) value;
2912 }
2913 value_nv *= 2.0;
2914 value_nv += (NV)(bit - '0');
2915 continue;
2916 }
2917 if (bit == '_' && len && allow_underscores && (bit = s[1])
2918 && (bit == '0' || bit == '1'))
2919 {
2920 --len;
2921 ++s;
2922 goto redo;
2923 }
2924 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
2925 warn("Illegal binary digit '%c' ignored", *s);
2926 break;
2927 }
2928 if ( ( overflowed && value_nv > 4294967295.0)
2929 #if UVSIZE > 4
2930 || (!overflowed && value > 0xffffffff )
2931 #endif
2932 ) {
2933 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
2934 }
2935 *len_p = s - start;
2936 if (!overflowed) {
2937 *flags = 0;
2938 return value;
2939 }
2940 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
2941 if (result)
2942 *result = value_nv;
2943 return UV_MAX;
2944 }
2945 #endif
2946 #endif
2947 #ifndef grok_hex
2948 #if defined(NEED_grok_hex)
2949 static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
2950 static
2951 #else
2952 extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
2953 #endif
2954 #ifdef grok_hex
2955 #undef grok_hex
2956 #endif
2957 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
2958 #define Perl_grok_hex DPPP_(my_grok_hex)
2959 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
2960 UV
DPPP_(my_grok_hex)2961 DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
2962 {
2963 const char *s = start;
2964 STRLEN len = *len_p;
2965 UV value = 0;
2966 NV value_nv = 0;
2967 const UV max_div_16 = UV_MAX / 16;
2968 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
2969 bool overflowed = FALSE;
2970 const char *xdigit;
2971 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
2972 if (len >= 1) {
2973 if (s[0] == 'x') {
2974 s++;
2975 len--;
2976 }
2977 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
2978 s+=2;
2979 len-=2;
2980 }
2981 }
2982 }
2983 for (; len-- && *s; s++) {
2984 xdigit = strchr((char *) PL_hexdigit, *s);
2985 if (xdigit) {
2986 redo:
2987 if (!overflowed) {
2988 if (value <= max_div_16) {
2989 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
2990 continue;
2991 }
2992 warn("Integer overflow in hexadecimal number");
2993 overflowed = TRUE;
2994 value_nv = (NV) value;
2995 }
2996 value_nv *= 16.0;
2997 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
2998 continue;
2999 }
3000 if (*s == '_' && len && allow_underscores && s[1]
3001 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
3002 {
3003 --len;
3004 ++s;
3005 goto redo;
3006 }
3007 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
3008 warn("Illegal hexadecimal digit '%c' ignored", *s);
3009 break;
3010 }
3011 if ( ( overflowed && value_nv > 4294967295.0)
3012 #if UVSIZE > 4
3013 || (!overflowed && value > 0xffffffff )
3014 #endif
3015 ) {
3016 warn("Hexadecimal number > 0xffffffff non-portable");
3017 }
3018 *len_p = s - start;
3019 if (!overflowed) {
3020 *flags = 0;
3021 return value;
3022 }
3023 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
3024 if (result)
3025 *result = value_nv;
3026 return UV_MAX;
3027 }
3028 #endif
3029 #endif
3030 #ifndef grok_oct
3031 #if defined(NEED_grok_oct)
3032 static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
3033 static
3034 #else
3035 extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
3036 #endif
3037 #ifdef grok_oct
3038 #undef grok_oct
3039 #endif
3040 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
3041 #define Perl_grok_oct DPPP_(my_grok_oct)
3042 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
3043 UV
DPPP_(my_grok_oct)3044 DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
3045 {
3046 const char *s = start;
3047 STRLEN len = *len_p;
3048 UV value = 0;
3049 NV value_nv = 0;
3050 const UV max_div_8 = UV_MAX / 8;
3051 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
3052 bool overflowed = FALSE;
3053 for (; len-- && *s; s++) {
3054 int digit = *s - '0';
3055 if (digit >= 0 && digit <= 7) {
3056 redo:
3057 if (!overflowed) {
3058 if (value <= max_div_8) {
3059 value = (value << 3) | digit;
3060 continue;
3061 }
3062 warn("Integer overflow in octal number");
3063 overflowed = TRUE;
3064 value_nv = (NV) value;
3065 }
3066 value_nv *= 8.0;
3067 value_nv += (NV)digit;
3068 continue;
3069 }
3070 if (digit == ('_' - '0') && len && allow_underscores
3071 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
3072 {
3073 --len;
3074 ++s;
3075 goto redo;
3076 }
3077 if (digit == 8 || digit == 9) {
3078 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
3079 warn("Illegal octal digit '%c' ignored", *s);
3080 }
3081 break;
3082 }
3083 if ( ( overflowed && value_nv > 4294967295.0)
3084 #if UVSIZE > 4
3085 || (!overflowed && value > 0xffffffff )
3086 #endif
3087 ) {
3088 warn("Octal number > 037777777777 non-portable");
3089 }
3090 *len_p = s - start;
3091 if (!overflowed) {
3092 *flags = 0;
3093 return value;
3094 }
3095 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
3096 if (result)
3097 *result = value_nv;
3098 return UV_MAX;
3099 }
3100 #endif
3101 #endif
3102 #if !defined(my_snprintf)
3103 #if defined(NEED_my_snprintf)
3104 static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
3105 static
3106 #else
3107 extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
3108 #endif
3109 #define my_snprintf DPPP_(my_my_snprintf)
3110 #define Perl_my_snprintf DPPP_(my_my_snprintf)
3111 #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
3112 int
DPPP_(my_my_snprintf)3113 DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
3114 {
3115 dTHX;
3116 int retval;
3117 va_list ap;
3118 va_start(ap, format);
3119 #ifdef HAS_VSNPRINTF
3120 retval = vsnprintf(buffer, len, format, ap);
3121 #else
3122 retval = vsprintf(buffer, format, ap);
3123 #endif
3124 va_end(ap);
3125 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
3126 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
3127 return retval;
3128 }
3129 #endif
3130 #endif
3131 #if !defined(my_sprintf)
3132 #if defined(NEED_my_sprintf)
3133 static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
3134 static
3135 #else
3136 extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
3137 #endif
3138 #define my_sprintf DPPP_(my_my_sprintf)
3139 #define Perl_my_sprintf DPPP_(my_my_sprintf)
3140 #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
3141 int
DPPP_(my_my_sprintf)3142 DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
3143 {
3144 va_list args;
3145 va_start(args, pat);
3146 vsprintf(buffer, pat, args);
3147 va_end(args);
3148 return strlen(buffer);
3149 }
3150 #endif
3151 #endif
3152 #ifdef NO_XSLOCKS
3153 #ifdef dJMPENV
3154 #define dXCPT dJMPENV; int rEtV = 0
3155 #define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
3156 #define XCPT_TRY_END JMPENV_POP;
3157 #define XCPT_CATCH if (rEtV != 0)
3158 #define XCPT_RETHROW JMPENV_JUMP(rEtV)
3159 #else
3160 #define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
3161 #define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
3162 #define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
3163 #define XCPT_CATCH if (rEtV != 0)
3164 #define XCPT_RETHROW Siglongjmp(top_env, rEtV)
3165 #endif
3166 #endif
3167 #if !defined(my_strlcat)
3168 #if defined(NEED_my_strlcat)
3169 static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
3170 static
3171 #else
3172 extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
3173 #endif
3174 #define my_strlcat DPPP_(my_my_strlcat)
3175 #define Perl_my_strlcat DPPP_(my_my_strlcat)
3176 #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
3177 Size_t
DPPP_(my_my_strlcat)3178 DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
3179 {
3180 Size_t used, length, copy;
3181 used = strlen(dst);
3182 length = strlen(src);
3183 if (size > 0 && used < size - 1) {
3184 copy = (length >= size - used) ? size - used - 1 : length;
3185 memcpy(dst + used, src, copy);
3186 dst[used + copy] = '\0';
3187 }
3188 return used + length;
3189 }
3190 #endif
3191 #endif
3192 #if !defined(my_strlcpy)
3193 #if defined(NEED_my_strlcpy)
3194 static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
3195 static
3196 #else
3197 extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
3198 #endif
3199 #define my_strlcpy DPPP_(my_my_strlcpy)
3200 #define Perl_my_strlcpy DPPP_(my_my_strlcpy)
3201 #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
3202 Size_t
DPPP_(my_my_strlcpy)3203 DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
3204 {
3205 Size_t length, copy;
3206 length = strlen(src);
3207 if (size > 0) {
3208 copy = (length >= size) ? size - 1 : length;
3209 memcpy(dst, src, copy);
3210 dst[copy] = '\0';
3211 }
3212 return length;
3213 }
3214 #endif
3215 #endif
3216 #ifndef PERL_PV_ESCAPE_QUOTE
3217 #define PERL_PV_ESCAPE_QUOTE 0x0001
3218 #endif
3219 #ifndef PERL_PV_PRETTY_QUOTE
3220 #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
3221 #endif
3222 #ifndef PERL_PV_PRETTY_ELLIPSES
3223 #define PERL_PV_PRETTY_ELLIPSES 0x0002
3224 #endif
3225 #ifndef PERL_PV_PRETTY_LTGT
3226 #define PERL_PV_PRETTY_LTGT 0x0004
3227 #endif
3228 #ifndef PERL_PV_ESCAPE_FIRSTCHAR
3229 #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008
3230 #endif
3231 #ifndef PERL_PV_ESCAPE_UNI
3232 #define PERL_PV_ESCAPE_UNI 0x0100
3233 #endif
3234 #ifndef PERL_PV_ESCAPE_UNI_DETECT
3235 #define PERL_PV_ESCAPE_UNI_DETECT 0x0200
3236 #endif
3237 #ifndef PERL_PV_ESCAPE_ALL
3238 #define PERL_PV_ESCAPE_ALL 0x1000
3239 #endif
3240 #ifndef PERL_PV_ESCAPE_NOBACKSLASH
3241 #define PERL_PV_ESCAPE_NOBACKSLASH 0x2000
3242 #endif
3243 #ifndef PERL_PV_ESCAPE_NOCLEAR
3244 #define PERL_PV_ESCAPE_NOCLEAR 0x4000
3245 #endif
3246 #ifndef PERL_PV_ESCAPE_RE
3247 #define PERL_PV_ESCAPE_RE 0x8000
3248 #endif
3249 #ifndef PERL_PV_PRETTY_NOCLEAR
3250 #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
3251 #endif
3252 #ifndef PERL_PV_PRETTY_DUMP
3253 #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
3254 #endif
3255 #ifndef PERL_PV_PRETTY_REGPROP
3256 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
3257 #endif
3258 #ifndef pv_escape
3259 #if defined(NEED_pv_escape)
3260 static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
3261 static
3262 #else
3263 extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
3264 #endif
3265 #ifdef pv_escape
3266 #undef pv_escape
3267 #endif
3268 #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f)
3269 #define Perl_pv_escape DPPP_(my_pv_escape)
3270 #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL)
3271 char *
DPPP_(my_pv_escape)3272 DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str,
3273 const STRLEN count, const STRLEN max,
3274 STRLEN * const escaped, const U32 flags)
3275 {
3276 const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
3277 const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
3278 char octbuf[32] = "%123456789ABCDF";
3279 STRLEN wrote = 0;
3280 STRLEN chsize = 0;
3281 STRLEN readsize = 1;
3282 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
3283 bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
3284 #endif
3285 const char *pv = str;
3286 const char * const end = pv + count;
3287 octbuf[0] = esc;
3288 if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
3289 sv_setpvs(dsv, "");
3290 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
3291 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
3292 isuni = 1;
3293 #endif
3294 for (; pv < end && (!max || wrote < max) ; pv += readsize) {
3295 const UV u =
3296 #if defined(is_utf8_string) && defined(utf8_to_uvchr)
3297 isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
3298 #endif
3299 (U8)*pv;
3300 const U8 c = (U8)u & 0xFF;
3301 if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
3302 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
3303 chsize = my_snprintf(octbuf, sizeof octbuf,
3304 "%" UVxf, u);
3305 else
3306 chsize = my_snprintf(octbuf, sizeof octbuf,
3307 "%cx{%" UVxf "}", esc, u);
3308 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
3309 chsize = 1;
3310 } else {
3311 if (c == dq || c == esc || !isPRINT(c)) {
3312 chsize = 2;
3313 switch (c) {
3314 case '\\' :
3315 case '%' : if (c == esc)
3316 octbuf[1] = esc;
3317 else
3318 chsize = 1;
3319 break;
3320 case '\v' : octbuf[1] = 'v'; break;
3321 case '\t' : octbuf[1] = 't'; break;
3322 case '\r' : octbuf[1] = 'r'; break;
3323 case '\n' : octbuf[1] = 'n'; break;
3324 case '\f' : octbuf[1] = 'f'; break;
3325 case '"' : if (dq == '"')
3326 octbuf[1] = '"';
3327 else
3328 chsize = 1;
3329 break;
3330 default: chsize = my_snprintf(octbuf, sizeof octbuf,
3331 pv < end && isDIGIT((U8)*(pv+readsize))
3332 ? "%c%03o" : "%c%o", esc, c);
3333 }
3334 } else {
3335 chsize = 1;
3336 }
3337 }
3338 if (max && wrote + chsize > max) {
3339 break;
3340 } else if (chsize > 1) {
3341 sv_catpvn(dsv, octbuf, chsize);
3342 wrote += chsize;
3343 } else {
3344 char tmp[2];
3345 my_snprintf(tmp, sizeof tmp, "%c", c);
3346 sv_catpvn(dsv, tmp, 1);
3347 wrote++;
3348 }
3349 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
3350 break;
3351 }
3352 if (escaped != NULL)
3353 *escaped= pv - str;
3354 return SvPVX(dsv);
3355 }
3356 #endif
3357 #endif
3358 #ifndef pv_pretty
3359 #if defined(NEED_pv_pretty)
3360 static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
3361 static
3362 #else
3363 extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags);
3364 #endif
3365 #ifdef pv_pretty
3366 #undef pv_pretty
3367 #endif
3368 #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
3369 #define Perl_pv_pretty DPPP_(my_pv_pretty)
3370 #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
3371 char *
DPPP_(my_pv_pretty)3372 DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count,
3373 const STRLEN max, char const * const start_color, char const * const end_color,
3374 const U32 flags)
3375 {
3376 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
3377 STRLEN escaped;
3378 if (!(flags & PERL_PV_PRETTY_NOCLEAR))
3379 sv_setpvs(dsv, "");
3380 if (dq == '"')
3381 sv_catpvs(dsv, "\"");
3382 else if (flags & PERL_PV_PRETTY_LTGT)
3383 sv_catpvs(dsv, "<");
3384 if (start_color != NULL)
3385 sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
3386 pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
3387 if (end_color != NULL)
3388 sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
3389 if (dq == '"')
3390 sv_catpvs(dsv, "\"");
3391 else if (flags & PERL_PV_PRETTY_LTGT)
3392 sv_catpvs(dsv, ">");
3393 if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
3394 sv_catpvs(dsv, "...");
3395 return SvPVX(dsv);
3396 }
3397 #endif
3398 #endif
3399 #ifndef pv_display
3400 #if defined(NEED_pv_display)
3401 static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
3402 static
3403 #else
3404 extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
3405 #endif
3406 #ifdef pv_display
3407 #undef pv_display
3408 #endif
3409 #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e)
3410 #define Perl_pv_display DPPP_(my_pv_display)
3411 #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL)
3412 char *
DPPP_(my_pv_display)3413 DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
3414 {
3415 pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
3416 if (len > cur && pv[cur] == '\0')
3417 sv_catpvs(dsv, "\\0");
3418 return SvPVX(dsv);
3419 }
3420 #endif
3421 #endif
3422 #endif
3423