1 #if 0
2 my $void = <<'SKIP';
3 #endif
4 /*
5 ----------------------------------------------------------------------
6
7 ppport.h -- Perl/Pollution/Portability Version 3.62
8
9 Automatically created by Devel::PPPort running under perl 5.032001.
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.62) {
27 die "ppport.h was originally generated with Devel::PPPort 3.62.\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 #define D_PPP_RELEASE_DATE 1602806400
53 #if ! defined(PERL_REVISION) && ! defined(PERL_VERSION_MAJOR)
54 #if ! defined(__PATCHLEVEL_H_INCLUDED__) \
55 && ! ( defined(PATCHLEVEL) && defined(SUBVERSION))
56 #define PERL_PATCHLEVEL_H_IMPLICIT
57 #include <patchlevel.h>
58 #endif
59 #if ! defined(PERL_VERSION) \
60 && ! defined(PERL_VERSION_MAJOR) \
61 && ( ! defined(SUBVERSION) || ! defined(PATCHLEVEL) )
62 #include <could_not_find_Perl_patchlevel.h>
63 #endif
64 #endif
65 #ifdef PERL_VERSION_MAJOR
66 #define D_PPP_MAJOR PERL_VERSION_MAJOR
67 #elif defined(PERL_REVISION)
68 #define D_PPP_MAJOR PERL_REVISION
69 #else
70 #define D_PPP_MAJOR 5
71 #endif
72 #ifdef PERL_VERSION_MINOR
73 #define D_PPP_MINOR PERL_VERSION_MINOR
74 #elif defined(PERL_VERSION)
75 #define D_PPP_MINOR PERL_VERSION
76 #elif defined(PATCHLEVEL)
77 #define D_PPP_MINOR PATCHLEVEL
78 #define PERL_VERSION PATCHLEVEL
79 #else
80 #error Could not find a source for PERL_VERSION_MINOR
81 #endif
82 #ifdef PERL_VERSION_PATCH
83 #define D_PPP_PATCH PERL_VERSION_PATCH
84 #elif defined(PERL_SUBVERSION)
85 #define D_PPP_PATCH PERL_SUBVERSION
86 #elif defined(SUBVERSION)
87 #define D_PPP_PATCH SUBVERSION
88 #define PERL_SUBVERSION SUBVERSION
89 #else
90 #error Could not find a source for PERL_VERSION_PATCH
91 #endif
92 #if D_PPP_MAJOR < 5 || D_PPP_MAJOR == 6
93 #error Devel::PPPort works only on Perl 5, Perl 7, ...
94 #elif D_PPP_MAJOR != 5
95 #undef PERL_REVISION
96 #undef PERL_VERSION
97 #undef PERL_SUBVERSION
98 #define D_PPP_REVISION 5
99 #define D_PPP_VERSION 201
100 #define D_PPP_SUBVERSION 201
101 #if (defined(__clang__) \
102 && ( (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) \
103 || defined(_STDC_C99) \
104 || defined(__c99)))
105 #define D_PPP_STRINGIFY(x) #x
106 #define D_PPP_deprecate(xyz) _Pragma(D_PPP_STRINGIFY(GCC warning(D_PPP_STRINGIFY(xyz) " is deprecated")))
107 #define PERL_REVISION (D_PPP_REVISION D_PPP_deprecate(PERL_REVISION))
108 #define PERL_VERSION (D_PPP_REVISION D_PPP_deprecate(PERL_VERSION))
109 #define PERL_SUBVERSION (D_PPP_SUBVERSION D_PPP_deprecate(PERL_SUBVERSION))
110 #else
111 #define PERL_REVISION D_PPP_REVISION
112 #define PERL_VERSION D_PPP_REVISION
113 #define PERL_SUBVERSION D_PPP_SUBVERSION
114 #endif
115 #endif
116 #define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
117 #define D_PPP_JNP_TO_BCD(j,n,p) ((D_PPP_DEC2BCD(j)<<24)|(D_PPP_DEC2BCD(n)<<12)|D_PPP_DEC2BCD(p))
118 #define PERL_BCDVERSION D_PPP_JNP_TO_BCD(D_PPP_MAJOR, \
119 D_PPP_MINOR, \
120 D_PPP_PATCH)
121 #undef PERL_VERSION_EQ
122 #undef PERL_VERSION_NE
123 #undef PERL_VERSION_LT
124 #undef PERL_VERSION_GE
125 #undef PERL_VERSION_LE
126 #undef PERL_VERSION_GT
127 #ifndef PERL_VERSION_EQ
128 #define PERL_VERSION_EQ(j,n,p) \
129 (((p) == '*') ? ( (j) == D_PPP_VERSION_MAJOR \
130 && (n) == D_PPP_VERSION_MINOR) \
131 : (PERL_BCDVERSION == D_PPP_JNP_TO_BCD(j,n,p)))
132 #endif
133 #ifndef PERL_VERSION_NE
134 #define PERL_VERSION_NE(j,n,p) (! PERL_VERSION_EQ(j,n,p))
135 #endif
136 #ifndef PERL_VERSION_LT
137 #define PERL_VERSION_LT(j,n,p) \
138 (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \
139 (n), \
140 (((p) == '*') ? 0 : (p))))
141 #endif
142 #ifndef PERL_VERSION_GE
143 #define PERL_VERSION_GE(j,n,p) (! PERL_VERSION_LT(j,n,p))
144 #endif
145 #ifndef PERL_VERSION_LE
146 #define PERL_VERSION_LE(j,n,p) \
147 (PERL_BCDVERSION < D_PPP_JNP_TO_BCD( (j), \
148 (((p) == '*') ? ((n)+1) : (n)), \
149 (((p) == '*') ? 0 : (p))))
150 #endif
151 #ifndef PERL_VERSION_GT
152 #define PERL_VERSION_GT(j,n,p) (! PERL_VERSION_LE(j,n,p))
153 #endif
154 #ifndef dTHR
155 #define dTHR dNOOP
156 #endif
157 #ifndef dTHX
158 #define dTHX dNOOP
159 #endif
160 #ifndef dTHXa
161 #define dTHXa(x) dNOOP
162 #endif
163 #ifndef pTHX
164 #define pTHX void
165 #endif
166 #ifndef pTHX_
167 #define pTHX_
168 #endif
169 #ifndef aTHX
170 #define aTHX
171 #endif
172 #ifndef aTHX_
173 #define aTHX_
174 #endif
175 #if (PERL_BCDVERSION < 0x5006000)
176 #ifdef USE_THREADS
177 #define aTHXR thr
178 #define aTHXR_ thr,
179 #else
180 #define aTHXR
181 #define aTHXR_
182 #endif
183 #define dTHXR dTHR
184 #else
185 #define aTHXR aTHX
186 #define aTHXR_ aTHX_
187 #define dTHXR dTHX
188 #endif
189 #ifndef dTHXoa
190 #define dTHXoa(x) dTHXa(x)
191 #endif
192 #ifdef I_LIMITS
193 #include <limits.h>
194 #endif
195 #ifndef PERL_UCHAR_MIN
196 #define PERL_UCHAR_MIN ((unsigned char)0)
197 #endif
198 #ifndef PERL_UCHAR_MAX
199 #ifdef UCHAR_MAX
200 #define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
201 #else
202 #ifdef MAXUCHAR
203 #define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
204 #else
205 #define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
206 #endif
207 #endif
208 #endif
209 #ifndef PERL_USHORT_MIN
210 #define PERL_USHORT_MIN ((unsigned short)0)
211 #endif
212 #ifndef PERL_USHORT_MAX
213 #ifdef USHORT_MAX
214 #define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
215 #else
216 #ifdef MAXUSHORT
217 #define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
218 #else
219 #ifdef USHRT_MAX
220 #define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
221 #else
222 #define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
223 #endif
224 #endif
225 #endif
226 #endif
227 #ifndef PERL_SHORT_MAX
228 #ifdef SHORT_MAX
229 #define PERL_SHORT_MAX ((short)SHORT_MAX)
230 #else
231 #ifdef MAXSHORT
232 #define PERL_SHORT_MAX ((short)MAXSHORT)
233 #else
234 #ifdef SHRT_MAX
235 #define PERL_SHORT_MAX ((short)SHRT_MAX)
236 #else
237 #define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
238 #endif
239 #endif
240 #endif
241 #endif
242 #ifndef PERL_SHORT_MIN
243 #ifdef SHORT_MIN
244 #define PERL_SHORT_MIN ((short)SHORT_MIN)
245 #else
246 #ifdef MINSHORT
247 #define PERL_SHORT_MIN ((short)MINSHORT)
248 #else
249 #ifdef SHRT_MIN
250 #define PERL_SHORT_MIN ((short)SHRT_MIN)
251 #else
252 #define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
253 #endif
254 #endif
255 #endif
256 #endif
257 #ifndef PERL_UINT_MAX
258 #ifdef UINT_MAX
259 #define PERL_UINT_MAX ((unsigned int)UINT_MAX)
260 #else
261 #ifdef MAXUINT
262 #define PERL_UINT_MAX ((unsigned int)MAXUINT)
263 #else
264 #define PERL_UINT_MAX (~(unsigned int)0)
265 #endif
266 #endif
267 #endif
268 #ifndef PERL_UINT_MIN
269 #define PERL_UINT_MIN ((unsigned int)0)
270 #endif
271 #ifndef PERL_INT_MAX
272 #ifdef INT_MAX
273 #define PERL_INT_MAX ((int)INT_MAX)
274 #else
275 #ifdef MAXINT
276 #define PERL_INT_MAX ((int)MAXINT)
277 #else
278 #define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
279 #endif
280 #endif
281 #endif
282 #ifndef PERL_INT_MIN
283 #ifdef INT_MIN
284 #define PERL_INT_MIN ((int)INT_MIN)
285 #else
286 #ifdef MININT
287 #define PERL_INT_MIN ((int)MININT)
288 #else
289 #define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
290 #endif
291 #endif
292 #endif
293 #ifndef PERL_ULONG_MAX
294 #ifdef ULONG_MAX
295 #define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
296 #else
297 #ifdef MAXULONG
298 #define PERL_ULONG_MAX ((unsigned long)MAXULONG)
299 #else
300 #define PERL_ULONG_MAX (~(unsigned long)0)
301 #endif
302 #endif
303 #endif
304 #ifndef PERL_ULONG_MIN
305 #define PERL_ULONG_MIN ((unsigned long)0L)
306 #endif
307 #ifndef PERL_LONG_MAX
308 #ifdef LONG_MAX
309 #define PERL_LONG_MAX ((long)LONG_MAX)
310 #else
311 #ifdef MAXLONG
312 #define PERL_LONG_MAX ((long)MAXLONG)
313 #else
314 #define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
315 #endif
316 #endif
317 #endif
318 #ifndef PERL_LONG_MIN
319 #ifdef LONG_MIN
320 #define PERL_LONG_MIN ((long)LONG_MIN)
321 #else
322 #ifdef MINLONG
323 #define PERL_LONG_MIN ((long)MINLONG)
324 #else
325 #define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
326 #endif
327 #endif
328 #endif
329 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
330 #ifndef PERL_UQUAD_MAX
331 #ifdef ULONGLONG_MAX
332 #define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
333 #else
334 #ifdef MAXULONGLONG
335 #define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
336 #else
337 #define PERL_UQUAD_MAX (~(unsigned long long)0)
338 #endif
339 #endif
340 #endif
341 #ifndef PERL_UQUAD_MIN
342 #define PERL_UQUAD_MIN ((unsigned long long)0L)
343 #endif
344 #ifndef PERL_QUAD_MAX
345 #ifdef LONGLONG_MAX
346 #define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
347 #else
348 #ifdef MAXLONGLONG
349 #define PERL_QUAD_MAX ((long long)MAXLONGLONG)
350 #else
351 #define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
352 #endif
353 #endif
354 #endif
355 #ifndef PERL_QUAD_MIN
356 #ifdef LONGLONG_MIN
357 #define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
358 #else
359 #ifdef MINLONGLONG
360 #define PERL_QUAD_MIN ((long long)MINLONGLONG)
361 #else
362 #define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
363 #endif
364 #endif
365 #endif
366 #endif
367 #ifdef HAS_QUAD
368 #ifdef cray
369 #ifndef IVTYPE
370 #define IVTYPE int
371 #endif
372 #ifndef IV_MIN
373 #define IV_MIN PERL_INT_MIN
374 #endif
375 #ifndef IV_MAX
376 #define IV_MAX PERL_INT_MAX
377 #endif
378 #ifndef UV_MIN
379 #define UV_MIN PERL_UINT_MIN
380 #endif
381 #ifndef UV_MAX
382 #define UV_MAX PERL_UINT_MAX
383 #endif
384 #ifdef INTSIZE
385 #ifndef IVSIZE
386 #define IVSIZE INTSIZE
387 #endif
388 #endif
389 #else
390 #if defined(convex) || defined(uts)
391 #ifndef IVTYPE
392 #define IVTYPE long long
393 #endif
394 #ifndef IV_MIN
395 #define IV_MIN PERL_QUAD_MIN
396 #endif
397 #ifndef IV_MAX
398 #define IV_MAX PERL_QUAD_MAX
399 #endif
400 #ifndef UV_MIN
401 #define UV_MIN PERL_UQUAD_MIN
402 #endif
403 #ifndef UV_MAX
404 #define UV_MAX PERL_UQUAD_MAX
405 #endif
406 #ifdef LONGLONGSIZE
407 #ifndef IVSIZE
408 #define IVSIZE LONGLONGSIZE
409 #endif
410 #endif
411 #else
412 #ifndef IVTYPE
413 #define IVTYPE long
414 #endif
415 #ifndef IV_MIN
416 #define IV_MIN PERL_LONG_MIN
417 #endif
418 #ifndef IV_MAX
419 #define IV_MAX PERL_LONG_MAX
420 #endif
421 #ifndef UV_MIN
422 #define UV_MIN PERL_ULONG_MIN
423 #endif
424 #ifndef UV_MAX
425 #define UV_MAX PERL_ULONG_MAX
426 #endif
427 #ifdef LONGSIZE
428 #ifndef IVSIZE
429 #define IVSIZE LONGSIZE
430 #endif
431 #endif
432 #endif
433 #endif
434 #ifndef IVSIZE
435 #define IVSIZE 8
436 #endif
437 #ifndef LONGSIZE
438 #define LONGSIZE 8
439 #endif
440 #ifndef PERL_QUAD_MIN
441 #define PERL_QUAD_MIN IV_MIN
442 #endif
443 #ifndef PERL_QUAD_MAX
444 #define PERL_QUAD_MAX IV_MAX
445 #endif
446 #ifndef PERL_UQUAD_MIN
447 #define PERL_UQUAD_MIN UV_MIN
448 #endif
449 #ifndef PERL_UQUAD_MAX
450 #define PERL_UQUAD_MAX UV_MAX
451 #endif
452 #else
453 #ifndef IVTYPE
454 #define IVTYPE long
455 #endif
456 #ifndef LONGSIZE
457 #define LONGSIZE 4
458 #endif
459 #ifndef IV_MIN
460 #define IV_MIN PERL_LONG_MIN
461 #endif
462 #ifndef IV_MAX
463 #define IV_MAX PERL_LONG_MAX
464 #endif
465 #ifndef UV_MIN
466 #define UV_MIN PERL_ULONG_MIN
467 #endif
468 #ifndef UV_MAX
469 #define UV_MAX PERL_ULONG_MAX
470 #endif
471 #endif
472 #ifndef IVSIZE
473 #ifdef LONGSIZE
474 #define IVSIZE LONGSIZE
475 #else
476 #define IVSIZE 4
477 #endif
478 #endif
479 #ifndef UVTYPE
480 #define UVTYPE unsigned IVTYPE
481 #endif
482 #ifndef UVSIZE
483 #define UVSIZE IVSIZE
484 #endif
485 #ifndef PERL_SIGNALS_UNSAFE_FLAG
486 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001
487 #if (PERL_BCDVERSION < 0x5008000)
488 #define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG
489 #else
490 #define D_PPP_PERL_SIGNALS_INIT 0
491 #endif
492 #if defined(NEED_PL_signals)
493 static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
494 #elif defined(NEED_PL_signals_GLOBAL)
495 U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT;
496 #else
497 extern U32 DPPP_(my_PL_signals);
498 #endif
499 #define PL_signals DPPP_(my_PL_signals)
500 #endif
501 #if (PERL_BCDVERSION <= 0x5005005)
502 #define PL_ppaddr ppaddr
503 #define PL_no_modify no_modify
504 #endif
505 #if (PERL_BCDVERSION <= 0x5004005)
506 #define PL_DBsignal DBsignal
507 #define PL_DBsingle DBsingle
508 #define PL_DBsub DBsub
509 #define PL_DBtrace DBtrace
510 #define PL_Sv Sv
511 #define PL_Xpv Xpv
512 #define PL_bufend bufend
513 #define PL_bufptr bufptr
514 #define PL_compiling compiling
515 #define PL_copline copline
516 #define PL_curcop curcop
517 #define PL_curstash curstash
518 #define PL_debstash debstash
519 #define PL_defgv defgv
520 #define PL_diehook diehook
521 #define PL_dirty dirty
522 #define PL_dowarn dowarn
523 #define PL_errgv errgv
524 #define PL_error_count error_count
525 #define PL_expect expect
526 #define PL_hexdigit hexdigit
527 #define PL_hints hints
528 #define PL_in_my in_my
529 #define PL_laststatval laststatval
530 #define PL_lex_state lex_state
531 #define PL_lex_stuff lex_stuff
532 #define PL_linestr linestr
533 #define PL_na na
534 #define PL_perl_destruct_level perl_destruct_level
535 #define PL_perldb perldb
536 #define PL_rsfp_filters rsfp_filters
537 #define PL_rsfp rsfp
538 #define PL_stack_base stack_base
539 #define PL_stack_sp stack_sp
540 #define PL_statcache statcache
541 #define PL_stdingv stdingv
542 #define PL_sv_arenaroot sv_arenaroot
543 #define PL_sv_no sv_no
544 #define PL_sv_undef sv_undef
545 #define PL_sv_yes sv_yes
546 #define PL_tainted tainted
547 #define PL_tainting tainting
548 #define PL_tokenbuf tokenbuf
549 #define PL_mess_sv mess_sv
550 #endif
551 #if (PERL_BCDVERSION >= 0x5009005)
552 #ifdef DPPP_PL_parser_NO_DUMMY
553 #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
554 (croak("panic: PL_parser == NULL in %s:%d", \
555 __FILE__, __LINE__), (yy_parser *) NULL))->var)
556 #else
557 #ifdef DPPP_PL_parser_NO_DUMMY_WARNING
558 #define D_PPP_parser_dummy_warning(var)
559 #else
560 #define D_PPP_parser_dummy_warning(var) \
561 warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__),
562 #endif
563 #define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \
564 (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var)
565 #if defined(NEED_PL_parser)
566 static yy_parser DPPP_(dummy_PL_parser);
567 #elif defined(NEED_PL_parser_GLOBAL)
568 yy_parser DPPP_(dummy_PL_parser);
569 #else
570 extern yy_parser DPPP_(dummy_PL_parser);
571 #endif
572 #endif
573 #define PL_expect D_PPP_my_PL_parser_var(expect)
574 #define PL_copline D_PPP_my_PL_parser_var(copline)
575 #define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
576 #define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
577 #define PL_linestr D_PPP_my_PL_parser_var(linestr)
578 #define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
579 #define PL_bufend D_PPP_my_PL_parser_var(bufend)
580 #define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
581 #define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
582 #define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
583 #define PL_in_my D_PPP_my_PL_parser_var(in_my)
584 #define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
585 #define PL_error_count D_PPP_my_PL_parser_var(error_count)
586 #else
587 #define PL_parser ((void *) 1)
588 #endif
589 #if (PERL_BCDVERSION <= 0x5003022)
590 #undef start_subparse
591 #if (PERL_BCDVERSION < 0x5003022)
592 #ifndef start_subparse
593 #define start_subparse(a, b) Perl_start_subparse()
594 #endif
595 #else
596 #ifndef start_subparse
597 #define start_subparse(a, b) Perl_start_subparse(b)
598 #endif
599 #endif
600 #if (PERL_BCDVERSION < 0x5003007)
601 foo
602 #endif
603 #endif
604 #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005)
605 #define NEED_newCONSTSUB
606 #if defined(NEED_newCONSTSUB)
607 static CV * DPPP_(my_newCONSTSUB)(HV * stash, const char * name, SV * sv);
608 static
609 #else
610 extern CV * DPPP_(my_newCONSTSUB)(HV * stash, const char * name, SV * sv);
611 #endif
612 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
613 #ifdef newCONSTSUB
614 #undef newCONSTSUB
615 #endif
616 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
617 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
618 #define D_PPP_PL_copline PL_copline
619 CV *
DPPP_(my_newCONSTSUB)620 DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv)
621 {
622 CV *cv;
623 U32 oldhints = PL_hints;
624 HV *old_cop_stash = PL_curcop->cop_stash;
625 HV *old_curstash = PL_curstash;
626 line_t oldline = PL_curcop->cop_line;
627 PL_curcop->cop_line = D_PPP_PL_copline;
628 PL_hints &= ~HINT_BLOCK_SCOPE;
629 if (stash)
630 PL_curstash = PL_curcop->cop_stash = stash;
631 cv = newSUB(
632 start_subparse(FALSE, 0),
633 newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)),
634 newSVOP(OP_CONST, 0, &PL_sv_no),
635 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
636 );
637 PL_hints = oldhints;
638 PL_curcop->cop_stash = old_cop_stash;
639 PL_curstash = old_curstash;
640 PL_curcop->cop_line = oldline;
641 return cv;
642 }
643 #endif
644 #endif
645 #ifndef PERL_MAGIC_sv
646 #define PERL_MAGIC_sv '\0'
647 #endif
648 #ifndef PERL_MAGIC_overload
649 #define PERL_MAGIC_overload 'A'
650 #endif
651 #ifndef PERL_MAGIC_overload_elem
652 #define PERL_MAGIC_overload_elem 'a'
653 #endif
654 #ifndef PERL_MAGIC_overload_table
655 #define PERL_MAGIC_overload_table 'c'
656 #endif
657 #ifndef PERL_MAGIC_bm
658 #define PERL_MAGIC_bm 'B'
659 #endif
660 #ifndef PERL_MAGIC_regdata
661 #define PERL_MAGIC_regdata 'D'
662 #endif
663 #ifndef PERL_MAGIC_regdatum
664 #define PERL_MAGIC_regdatum 'd'
665 #endif
666 #ifndef PERL_MAGIC_env
667 #define PERL_MAGIC_env 'E'
668 #endif
669 #ifndef PERL_MAGIC_envelem
670 #define PERL_MAGIC_envelem 'e'
671 #endif
672 #ifndef PERL_MAGIC_fm
673 #define PERL_MAGIC_fm 'f'
674 #endif
675 #ifndef PERL_MAGIC_regex_global
676 #define PERL_MAGIC_regex_global 'g'
677 #endif
678 #ifndef PERL_MAGIC_isa
679 #define PERL_MAGIC_isa 'I'
680 #endif
681 #ifndef PERL_MAGIC_isaelem
682 #define PERL_MAGIC_isaelem 'i'
683 #endif
684 #ifndef PERL_MAGIC_nkeys
685 #define PERL_MAGIC_nkeys 'k'
686 #endif
687 #ifndef PERL_MAGIC_dbfile
688 #define PERL_MAGIC_dbfile 'L'
689 #endif
690 #ifndef PERL_MAGIC_dbline
691 #define PERL_MAGIC_dbline 'l'
692 #endif
693 #ifndef PERL_MAGIC_mutex
694 #define PERL_MAGIC_mutex 'm'
695 #endif
696 #ifndef PERL_MAGIC_shared
697 #define PERL_MAGIC_shared 'N'
698 #endif
699 #ifndef PERL_MAGIC_shared_scalar
700 #define PERL_MAGIC_shared_scalar 'n'
701 #endif
702 #ifndef PERL_MAGIC_collxfrm
703 #define PERL_MAGIC_collxfrm 'o'
704 #endif
705 #ifndef PERL_MAGIC_tied
706 #define PERL_MAGIC_tied 'P'
707 #endif
708 #ifndef PERL_MAGIC_tiedelem
709 #define PERL_MAGIC_tiedelem 'p'
710 #endif
711 #ifndef PERL_MAGIC_tiedscalar
712 #define PERL_MAGIC_tiedscalar 'q'
713 #endif
714 #ifndef PERL_MAGIC_qr
715 #define PERL_MAGIC_qr 'r'
716 #endif
717 #ifndef PERL_MAGIC_sig
718 #define PERL_MAGIC_sig 'S'
719 #endif
720 #ifndef PERL_MAGIC_sigelem
721 #define PERL_MAGIC_sigelem 's'
722 #endif
723 #ifndef PERL_MAGIC_taint
724 #define PERL_MAGIC_taint 't'
725 #endif
726 #ifndef PERL_MAGIC_uvar
727 #define PERL_MAGIC_uvar 'U'
728 #endif
729 #ifndef PERL_MAGIC_uvar_elem
730 #define PERL_MAGIC_uvar_elem 'u'
731 #endif
732 #ifndef PERL_MAGIC_vstring
733 #define PERL_MAGIC_vstring 'V'
734 #endif
735 #ifndef PERL_MAGIC_vec
736 #define PERL_MAGIC_vec 'v'
737 #endif
738 #ifndef PERL_MAGIC_utf8
739 #define PERL_MAGIC_utf8 'w'
740 #endif
741 #ifndef PERL_MAGIC_substr
742 #define PERL_MAGIC_substr 'x'
743 #endif
744 #ifndef PERL_MAGIC_defelem
745 #define PERL_MAGIC_defelem 'y'
746 #endif
747 #ifndef PERL_MAGIC_glob
748 #define PERL_MAGIC_glob '*'
749 #endif
750 #ifndef PERL_MAGIC_arylen
751 #define PERL_MAGIC_arylen '#'
752 #endif
753 #ifndef PERL_MAGIC_pos
754 #define PERL_MAGIC_pos '.'
755 #endif
756 #ifndef PERL_MAGIC_backref
757 #define PERL_MAGIC_backref '<'
758 #endif
759 #ifndef PERL_MAGIC_ext
760 #define PERL_MAGIC_ext '~'
761 #endif
762 #ifndef cBOOL
763 #define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0)
764 #endif
765 #ifndef OpHAS_SIBLING
766 #define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
767 #endif
768 #ifndef OpSIBLING
769 #define OpSIBLING(o) (0 + (o)->op_sibling)
770 #endif
771 #ifndef OpMORESIB_set
772 #define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
773 #endif
774 #ifndef OpLASTSIB_set
775 #define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
776 #endif
777 #ifndef OpMAYBESIB_set
778 #define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
779 #endif
780 #ifndef HEf_SVKEY
781 #define HEf_SVKEY -2
782 #endif
783 #if defined(DEBUGGING) && !defined(__COVERITY__)
784 #ifndef __ASSERT_
785 #define __ASSERT_(statement) assert(statement),
786 #endif
787 #else
788 #ifndef __ASSERT_
789 #define __ASSERT_(statement)
790 #endif
791 #endif
792 #ifndef WIDEST_UTYPE
793 #ifdef QUADKIND
794 #ifdef U64TYPE
795 #define WIDEST_UTYPE U64TYPE
796 #else
797 #define WIDEST_UTYPE unsigned Quad_t
798 #endif
799 #else
800 #define WIDEST_UTYPE U32
801 #endif
802 #endif
803 #ifndef withinCOUNT
804 #define withinCOUNT(c, l, n) \
805 (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0))))
806 #endif
807 #ifndef inRANGE
808 #define inRANGE(c, l, u) \
809 ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \
810 : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \
811 : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l)))))
812 #endif
813 #undef FITS_IN_8_BITS
814 #ifndef FITS_IN_8_BITS
815 #define FITS_IN_8_BITS(c) ( (sizeof(c) == 1) \
816 || !(((WIDEST_UTYPE)((c) | 0)) & ~0xFF))
817 #endif
818 #define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \
819 (((e) - (s)) <= 0 \
820 ? 0 \
821 : UTF8_IS_INVARIANT((s)[0]) \
822 ? is ## macro ## _L1((s)[0]) \
823 : (((e) - (s)) < UTF8SKIP(s)) \
824 ? 0 \
825 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
826 \
827 ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
828 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
829 & UTF_START_MASK(2), \
830 (s)[1]))) \
831 : is ## macro ## _utf8(s))
832 #define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \
833 (((e) - (s)) <= 0 \
834 ? 0 \
835 : UTF8_IS_INVARIANT((s)[0]) \
836 ? is ## macro ## _LC((s)[0]) \
837 : (((e) - (s)) < UTF8SKIP(s)) \
838 ? 0 \
839 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
840 \
841 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
842 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
843 & UTF_START_MASK(2), \
844 (s)[1]))) \
845 : is ## macro ## _utf8(s))
846 #define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \
847 (((e) - (s)) <= 0 \
848 ? 0 \
849 : UTF8_IS_INVARIANT((s)[0]) \
850 ? is ## macro ## _LC((s)[0]) \
851 : (((e) - (s)) < UTF8SKIP(s)) \
852 ? 0 \
853 : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \
854 \
855 ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \
856 UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \
857 & UTF_START_MASK(2), \
858 (s)[1]))) \
859 : is ## macro ## _utf8_safe(s, e))
860 #ifndef SvRX
861 #define SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL)
862 #endif
863 #ifndef SvRXOK
864 #define SvRXOK(sv) (!!SvRX(sv))
865 #endif
866 #ifndef PERL_UNUSED_DECL
867 #ifdef HASATTRIBUTE
868 #if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
869 #define PERL_UNUSED_DECL
870 #else
871 #define PERL_UNUSED_DECL __attribute__((unused))
872 #endif
873 #else
874 #define PERL_UNUSED_DECL
875 #endif
876 #endif
877 #ifndef PERL_UNUSED_ARG
878 #if defined(lint) && defined(S_SPLINT_S)
879 #include <note.h>
880 #define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
881 #else
882 #define PERL_UNUSED_ARG(x) ((void)x)
883 #endif
884 #endif
885 #ifndef PERL_UNUSED_VAR
886 #define PERL_UNUSED_VAR(x) ((void)x)
887 #endif
888 #ifndef PERL_UNUSED_CONTEXT
889 #ifdef USE_ITHREADS
890 #define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
891 #else
892 #define PERL_UNUSED_CONTEXT
893 #endif
894 #endif
895 #ifndef PERL_UNUSED_RESULT
896 #if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT)
897 #define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END
898 #else
899 #define PERL_UNUSED_RESULT(v) ((void)(v))
900 #endif
901 #endif
902 #ifndef NOOP
903 #define NOOP (void)0
904 #endif
905 #ifndef dNOOP
906 #define dNOOP extern int Perl___notused PERL_UNUSED_DECL
907 #endif
908 #ifndef NVTYPE
909 #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
910 #define NVTYPE long double
911 #else
912 #define NVTYPE double
913 #endif
914 typedef NVTYPE NV;
915 #endif
916 #ifndef INT2PTR
917 #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
918 #define PTRV UV
919 #define INT2PTR(any,d) (any)(d)
920 #else
921 #if PTRSIZE == LONGSIZE
922 #define PTRV unsigned long
923 #else
924 #define PTRV unsigned
925 #endif
926 #define INT2PTR(any,d) (any)(PTRV)(d)
927 #endif
928 #endif
929 #ifndef PTR2ul
930 #if PTRSIZE == LONGSIZE
931 #define PTR2ul(p) (unsigned long)(p)
932 #else
933 #define PTR2ul(p) INT2PTR(unsigned long,p)
934 #endif
935 #endif
936 #ifndef PTR2nat
937 #define PTR2nat(p) (PTRV)(p)
938 #endif
939 #ifndef NUM2PTR
940 #define NUM2PTR(any,d) (any)PTR2nat(d)
941 #endif
942 #ifndef PTR2IV
943 #define PTR2IV(p) INT2PTR(IV,p)
944 #endif
945 #ifndef PTR2UV
946 #define PTR2UV(p) INT2PTR(UV,p)
947 #endif
948 #ifndef PTR2NV
949 #define PTR2NV(p) NUM2PTR(NV,p)
950 #endif
951 #undef START_EXTERN_C
952 #undef END_EXTERN_C
953 #undef EXTERN_C
954 #ifdef __cplusplus
955 #define START_EXTERN_C extern "C" {
956 #define END_EXTERN_C }
957 #define EXTERN_C extern "C"
958 #else
959 #define START_EXTERN_C
960 #define END_EXTERN_C
961 #define EXTERN_C extern
962 #endif
963 #if (PERL_BCDVERSION < 0x5004000) || defined(PERL_GCC_PEDANTIC)
964 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
965 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
966 #define PERL_GCC_BRACE_GROUPS_FORBIDDEN
967 #endif
968 #endif
969 #endif
970 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
971 #ifndef PERL_USE_GCC_BRACE_GROUPS
972 #define PERL_USE_GCC_BRACE_GROUPS
973 #endif
974 #endif
975 #undef STMT_START
976 #undef STMT_END
977 #ifdef PERL_USE_GCC_BRACE_GROUPS
978 #define STMT_START (void)(
979 #define STMT_END )
980 #else
981 #if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
982 #define STMT_START if (1)
983 #define STMT_END else (void)0
984 #else
985 #define STMT_START do
986 #define STMT_END while (0)
987 #endif
988 #endif
989 #ifndef boolSV
990 #define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
991 #endif
992 #ifndef DEFSV
993 #define DEFSV GvSV(PL_defgv)
994 #endif
995 #ifndef SAVE_DEFSV
996 #define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
997 #endif
998 #ifndef DEFSV_set
999 #define DEFSV_set(sv) (DEFSV = (sv))
1000 #endif
1001 #ifndef AvFILLp
1002 #define AvFILLp AvFILL
1003 #endif
1004 #ifndef av_tindex
1005 #define av_tindex AvFILL
1006 #endif
1007 #ifndef av_top_index
1008 #define av_top_index AvFILL
1009 #endif
1010 #ifndef av_count
1011 #define av_count(av) (AvFILL(av)+1)
1012 #endif
1013 #ifndef ERRSV
1014 #define ERRSV get_sv("@",FALSE)
1015 #endif
1016 #ifndef gv_stashpvn
1017 #define gv_stashpvn(str,len,create) gv_stashpv(str,create)
1018 #endif
1019 #ifndef get_cv
1020 #define get_cv perl_get_cv
1021 #endif
1022 #ifndef get_sv
1023 #define get_sv perl_get_sv
1024 #endif
1025 #ifndef get_av
1026 #define get_av perl_get_av
1027 #endif
1028 #ifndef get_hv
1029 #define get_hv perl_get_hv
1030 #endif
1031 #ifndef dUNDERBAR
1032 #define dUNDERBAR dNOOP
1033 #endif
1034 #ifndef UNDERBAR
1035 #define UNDERBAR DEFSV
1036 #endif
1037 #ifndef dAX
1038 #define dAX I32 ax = MARK - PL_stack_base + 1
1039 #endif
1040 #ifndef dITEMS
1041 #define dITEMS I32 items = SP - MARK
1042 #endif
1043 #ifndef dXSTARG
1044 #define dXSTARG SV * targ = sv_newmortal()
1045 #endif
1046 #ifndef dAXMARK
1047 #define dAXMARK I32 ax = POPMARK; \
1048 SV ** const mark = PL_stack_base + ax++
1049 #endif
1050 #ifndef XSprePUSH
1051 #define XSprePUSH (sp = PL_stack_base + ax - 1)
1052 #endif
1053 #if (PERL_BCDVERSION < 0x5005000)
1054 #undef XSRETURN
1055 #define XSRETURN(off) \
1056 STMT_START { \
1057 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
1058 return; \
1059 } STMT_END
1060 #endif
1061 #ifndef XSPROTO
1062 #define XSPROTO(name) void name(pTHX_ CV* cv)
1063 #endif
1064 #ifndef SVfARG
1065 #define SVfARG(p) ((void*)(p))
1066 #endif
1067 #ifndef PERL_ABS
1068 #define PERL_ABS(x) ((x) < 0 ? -(x) : (x))
1069 #endif
1070 #ifndef dVAR
1071 #define dVAR dNOOP
1072 #endif
1073 #ifndef SVf
1074 #define SVf "_"
1075 #endif
1076 #ifndef CPERLscope
1077 #define CPERLscope(x) x
1078 #endif
1079 #ifndef PERL_HASH
1080 #define PERL_HASH(hash,str,len) \
1081 STMT_START { \
1082 const char *s_PeRlHaSh = str; \
1083 I32 i_PeRlHaSh = len; \
1084 U32 hash_PeRlHaSh = 0; \
1085 while (i_PeRlHaSh--) \
1086 hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
1087 (hash) = hash_PeRlHaSh; \
1088 } STMT_END
1089 #endif
1090 #ifndef PERLIO_FUNCS_DECL
1091 #ifdef PERLIO_FUNCS_CONST
1092 #define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
1093 #define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
1094 #else
1095 #define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
1096 #define PERLIO_FUNCS_CAST(funcs) (funcs)
1097 #endif
1098 #endif
1099 #if (PERL_BCDVERSION < 0x5009003)
1100 #ifdef ARGSproto
1101 typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
1102 #else
1103 typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
1104 #endif
1105 typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
1106 #endif
1107 #if defined(EBCDIC) && defined(NATIVE_TO_ASCI)
1108 #ifndef NATIVE_TO_LATIN1
1109 #define NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c)
1110 #endif
1111 #ifndef LATIN1_TO_NATIVE
1112 #define LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c)
1113 #endif
1114 #ifndef NATIVE_TO_UNI
1115 #define NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c))
1116 #endif
1117 #ifndef UNI_TO_NATIVE
1118 #define UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c))
1119 #endif
1120 #else
1121 #ifndef NATIVE_TO_LATIN1
1122 #define NATIVE_TO_LATIN1(c) (c)
1123 #endif
1124 #ifndef LATIN1_TO_NATIVE
1125 #define LATIN1_TO_NATIVE(c) (c)
1126 #endif
1127 #ifndef NATIVE_TO_UNI
1128 #define NATIVE_TO_UNI(c) (c)
1129 #endif
1130 #ifndef UNI_TO_NATIVE
1131 #define UNI_TO_NATIVE(c) (c)
1132 #endif
1133 #endif
1134 #undef isPSXSPC
1135 #undef isPSXSPC_A
1136 #undef isPSXSPC_L1
1137 #ifdef EBCDIC
1138 #if (PERL_BCDVERSION < 0x5022000)
1139 #undef isALNUM
1140 #undef isALNUM_A
1141 #undef isALNUM_L1
1142 #undef isALNUMC
1143 #undef isALNUMC_A
1144 #undef isALNUMC_L1
1145 #undef isALPHA
1146 #undef isALPHA_A
1147 #undef isALPHA_L1
1148 #undef isALPHANUMERIC
1149 #undef isALPHANUMERIC_A
1150 #undef isALPHANUMERIC_L1
1151 #undef isASCII
1152 #undef isASCII_A
1153 #undef isASCII_L1
1154 #undef isBLANK
1155 #undef isBLANK_A
1156 #undef isBLANK_L1
1157 #undef isCNTRL
1158 #undef isCNTRL_A
1159 #undef isCNTRL_L1
1160 #undef isDIGIT
1161 #undef isDIGIT_A
1162 #undef isDIGIT_L1
1163 #undef isGRAPH
1164 #undef isGRAPH_A
1165 #undef isGRAPH_L1
1166 #undef isIDCONT
1167 #undef isIDCONT_A
1168 #undef isIDCONT_L1
1169 #undef isIDFIRST
1170 #undef isIDFIRST_A
1171 #undef isIDFIRST_L1
1172 #undef isLOWER
1173 #undef isLOWER_A
1174 #undef isLOWER_L1
1175 #undef isOCTAL
1176 #undef isOCTAL_A
1177 #undef isOCTAL_L1
1178 #undef isPRINT
1179 #undef isPRINT_A
1180 #undef isPRINT_L1
1181 #undef isPUNCT
1182 #undef isPUNCT_A
1183 #undef isPUNCT_L1
1184 #undef isSPACE
1185 #undef isSPACE_A
1186 #undef isSPACE_L1
1187 #undef isUPPER
1188 #undef isUPPER_A
1189 #undef isUPPER_L1
1190 #undef isWORDCHAR
1191 #undef isWORDCHAR_A
1192 #undef isWORDCHAR_L1
1193 #undef isXDIGIT
1194 #undef isXDIGIT_A
1195 #undef isXDIGIT_L1
1196 #endif
1197 #ifndef isASCII
1198 #define isASCII(c) (isCNTRL(c) || isPRINT(c))
1199 #endif
1200 #ifndef isCNTRL
1201 #define isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \
1202 || (c) == '\f' || (c) == '\n' || (c) == '\r' \
1203 || (c) == '\t' || (c) == '\v' \
1204 || ((c) <= 3 && (c) >= 1) \
1205 || (c) == 7 \
1206 || ((c) <= 0x13 && (c) >= 0x0E) \
1207 \
1208 || (c) == 0x18 \
1209 || (c) == 0x19 \
1210 || ((c) <= 0x1F && (c) >= 0x1C) \
1211 || (c) == 0x26 \
1212 || (c) == 0x27 \
1213 || (c) == 0x2D \
1214 || (c) == 0x2E \
1215 || (c) == 0x32 \
1216 || (c) == 0x37 \
1217 || (c) == 0x3C \
1218 || (c) == 0x3D \
1219 || (c) == 0x3F \
1220 )
1221 #endif
1222 #if '^' == 106
1223 #define D_PPP_OUTLIER_CONTROL 0x5F
1224 #else
1225 #define D_PPP_OUTLIER_CONTROL 0xFF
1226 #endif
1227 #ifndef isCNTRL_L1
1228 #define isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \
1229 || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL)
1230 #endif
1231 #ifndef isLOWER
1232 #define isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \
1233 && ( (c) <= 'i' \
1234 || ((c) >= 'j' && (c) <= 'r') \
1235 || (c) >= 's'))
1236 #endif
1237 #ifndef isUPPER
1238 #define isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \
1239 && ( (c) <= 'I' \
1240 || ((c) >= 'J' && (c) <= 'R') \
1241 || (c) >= 'S'))
1242 #endif
1243 #else
1244 #if (PERL_BCDVERSION < 0x5004000)
1245 #undef isALNUM
1246 #undef isALNUM_A
1247 #undef isALPHA
1248 #undef isALPHA_A
1249 #undef isDIGIT
1250 #undef isDIGIT_A
1251 #undef isIDFIRST
1252 #undef isIDFIRST_A
1253 #undef isLOWER
1254 #undef isLOWER_A
1255 #undef isUPPER
1256 #undef isUPPER_A
1257 #endif
1258 #if (PERL_BCDVERSION == 0x5007000)
1259 #undef isGRAPH
1260 #endif
1261 #if (PERL_BCDVERSION < 0x5008000)
1262 #undef isCNTRL
1263 #endif
1264 #if (PERL_BCDVERSION < 0x5010000)
1265 #undef isPRINT
1266 #undef isPRINT_A
1267 #endif
1268 #if (PERL_BCDVERSION < 0x5014000)
1269 #undef isASCII
1270 #undef isASCII_A
1271 #endif
1272 #if (PERL_BCDVERSION < 0x5017008)
1273 #undef isPUNCT_L1
1274 #endif
1275 #if (PERL_BCDVERSION < 0x5013007)
1276 #undef isALNUMC_L1
1277 #endif
1278 #if (PERL_BCDVERSION < 0x5020000)
1279 #undef isSPACE
1280 #undef isSPACE_A
1281 #undef isSPACE_L1
1282 #endif
1283 #ifndef isASCII
1284 #define isASCII(c) ((WIDEST_UTYPE) (c) <= 127)
1285 #endif
1286 #ifndef isCNTRL
1287 #define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127)
1288 #endif
1289 #ifndef isCNTRL_L1
1290 #define isCNTRL_L1(c) (isCNTRL(c) || ( (WIDEST_UTYPE) (c) <= 0x9F \
1291 && (WIDEST_UTYPE) (c) >= 0x80))
1292 #endif
1293 #ifndef isLOWER
1294 #define isLOWER(c) ((c) >= 'a' && (c) <= 'z')
1295 #endif
1296 #ifndef isUPPER
1297 #define isUPPER(c) ((c) <= 'Z' && (c) >= 'A')
1298 #endif
1299 #endif
1300 #ifndef isASCII_L1
1301 #define isASCII_L1(c) isASCII(c)
1302 #endif
1303 #ifndef isASCII_LC
1304 #define isASCII_LC(c) isASCII(c)
1305 #endif
1306 #ifndef isALNUM
1307 #define isALNUM(c) isWORDCHAR(c)
1308 #endif
1309 #ifndef isALNUMC
1310 #define isALNUMC(c) isALPHANUMERIC(c)
1311 #endif
1312 #ifndef isALNUMC_L1
1313 #define isALNUMC_L1(c) isALPHANUMERIC_L1(c)
1314 #endif
1315 #ifndef isALPHA
1316 #define isALPHA(c) (isUPPER(c) || isLOWER(c))
1317 #endif
1318 #ifndef isALPHA_L1
1319 #define isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c))
1320 #endif
1321 #ifndef isALPHANUMERIC
1322 #define isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c))
1323 #endif
1324 #ifndef isALPHANUMERIC_L1
1325 #define isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c))
1326 #endif
1327 #ifndef isALPHANUMERIC_LC
1328 #define isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c))
1329 #endif
1330 #ifndef isBLANK
1331 #define isBLANK(c) ((c) == ' ' || (c) == '\t')
1332 #endif
1333 #ifndef isBLANK_L1
1334 #define isBLANK_L1(c) ( isBLANK(c) \
1335 || ( FITS_IN_8_BITS(c) \
1336 && NATIVE_TO_LATIN1((U8) c) == 0xA0))
1337 #endif
1338 #ifndef isBLANK_LC
1339 #define isBLANK_LC(c) isBLANK(c)
1340 #endif
1341 #ifndef isDIGIT
1342 #define isDIGIT(c) inRANGE(c, '0', '9')
1343 #endif
1344 #ifndef isDIGIT_L1
1345 #define isDIGIT_L1(c) isDIGIT(c)
1346 #endif
1347 #ifndef isGRAPH
1348 #define isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c))
1349 #endif
1350 #ifndef isGRAPH_L1
1351 #define isGRAPH_L1(c) ( isPRINT_L1(c) \
1352 && (c) != ' ' \
1353 && NATIVE_TO_LATIN1((U8) c) != 0xA0)
1354 #endif
1355 #ifndef isIDCONT
1356 #define isIDCONT(c) isWORDCHAR(c)
1357 #endif
1358 #ifndef isIDCONT_L1
1359 #define isIDCONT_L1(c) isWORDCHAR_L1(c)
1360 #endif
1361 #ifndef isIDCONT_LC
1362 #define isIDCONT_LC(c) isWORDCHAR_LC(c)
1363 #endif
1364 #ifndef isIDFIRST
1365 #define isIDFIRST(c) (isALPHA(c) || (c) == '_')
1366 #endif
1367 #ifndef isIDFIRST_L1
1368 #define isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_')
1369 #endif
1370 #ifndef isIDFIRST_LC
1371 #define isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_')
1372 #endif
1373 #ifndef isLOWER_L1
1374 #define isLOWER_L1(c) ( isLOWER(c) \
1375 || ( FITS_IN_8_BITS(c) \
1376 && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \
1377 && NATIVE_TO_LATIN1((U8) c) != 0xF7) \
1378 || NATIVE_TO_LATIN1((U8) c) == 0xAA \
1379 || NATIVE_TO_LATIN1((U8) c) == 0xBA \
1380 || NATIVE_TO_LATIN1((U8) c) == 0xB5)))
1381 #endif
1382 #ifndef isOCTAL
1383 #define isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0')
1384 #endif
1385 #ifndef isOCTAL_L1
1386 #define isOCTAL_L1(c) isOCTAL(c)
1387 #endif
1388 #ifndef isPRINT
1389 #define isPRINT(c) (isGRAPH(c) || (c) == ' ')
1390 #endif
1391 #ifndef isPRINT_L1
1392 #define isPRINT_L1(c) (FITS_IN_8_BITS(c) && ! isCNTRL_L1(c))
1393 #endif
1394 #ifndef isPSXSPC
1395 #define isPSXSPC(c) isSPACE(c)
1396 #endif
1397 #ifndef isPSXSPC_L1
1398 #define isPSXSPC_L1(c) isSPACE_L1(c)
1399 #endif
1400 #ifndef isPUNCT
1401 #define isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \
1402 || (c) == '#' || (c) == '$' || (c) == '%' \
1403 || (c) == '&' || (c) == '\'' || (c) == '(' \
1404 || (c) == ')' || (c) == '*' || (c) == '+' \
1405 || (c) == ',' || (c) == '.' || (c) == '/' \
1406 || (c) == ':' || (c) == ';' || (c) == '<' \
1407 || (c) == '=' || (c) == '>' || (c) == '?' \
1408 || (c) == '@' || (c) == '[' || (c) == '\\' \
1409 || (c) == ']' || (c) == '^' || (c) == '_' \
1410 || (c) == '`' || (c) == '{' || (c) == '|' \
1411 || (c) == '}' || (c) == '~')
1412 #endif
1413 #ifndef isPUNCT_L1
1414 #define isPUNCT_L1(c) ( isPUNCT(c) \
1415 || ( FITS_IN_8_BITS(c) \
1416 && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \
1417 || NATIVE_TO_LATIN1((U8) c) == 0xA7 \
1418 || NATIVE_TO_LATIN1((U8) c) == 0xAB \
1419 || NATIVE_TO_LATIN1((U8) c) == 0xB6 \
1420 || NATIVE_TO_LATIN1((U8) c) == 0xB7 \
1421 || NATIVE_TO_LATIN1((U8) c) == 0xBB \
1422 || NATIVE_TO_LATIN1((U8) c) == 0xBF)))
1423 #endif
1424 #ifndef isSPACE
1425 #define isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \
1426 || (c) == '\v' || (c) == '\f')
1427 #endif
1428 #ifndef isSPACE_L1
1429 #define isSPACE_L1(c) ( isSPACE(c) \
1430 || (FITS_IN_8_BITS(c) \
1431 && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \
1432 || NATIVE_TO_LATIN1((U8) c) == 0xA0)))
1433 #endif
1434 #ifndef isUPPER_L1
1435 #define isUPPER_L1(c) ( isUPPER(c) \
1436 || (FITS_IN_8_BITS(c) \
1437 && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \
1438 && NATIVE_TO_LATIN1((U8) c) <= 0xDE \
1439 && NATIVE_TO_LATIN1((U8) c) != 0xD7)))
1440 #endif
1441 #ifndef isWORDCHAR
1442 #define isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_')
1443 #endif
1444 #ifndef isWORDCHAR_L1
1445 #define isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c))
1446 #endif
1447 #ifndef isWORDCHAR_LC
1448 #define isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c))
1449 #endif
1450 #ifndef isXDIGIT
1451 #define isXDIGIT(c) ( isDIGIT(c) \
1452 || ((c) >= 'a' && (c) <= 'f') \
1453 || ((c) >= 'A' && (c) <= 'F'))
1454 #endif
1455 #ifndef isXDIGIT_L1
1456 #define isXDIGIT_L1(c) isXDIGIT(c)
1457 #endif
1458 #ifndef isXDIGIT_LC
1459 #define isXDIGIT_LC(c) isxdigit(c)
1460 #endif
1461 #ifndef isALNUM_A
1462 #define isALNUM_A(c) isALNUM(c)
1463 #endif
1464 #ifndef isALNUMC_A
1465 #define isALNUMC_A(c) isALNUMC(c)
1466 #endif
1467 #ifndef isALPHA_A
1468 #define isALPHA_A(c) isALPHA(c)
1469 #endif
1470 #ifndef isALPHANUMERIC_A
1471 #define isALPHANUMERIC_A(c) isALPHANUMERIC(c)
1472 #endif
1473 #ifndef isASCII_A
1474 #define isASCII_A(c) isASCII(c)
1475 #endif
1476 #ifndef isBLANK_A
1477 #define isBLANK_A(c) isBLANK(c)
1478 #endif
1479 #ifndef isCNTRL_A
1480 #define isCNTRL_A(c) isCNTRL(c)
1481 #endif
1482 #ifndef isDIGIT_A
1483 #define isDIGIT_A(c) isDIGIT(c)
1484 #endif
1485 #ifndef isGRAPH_A
1486 #define isGRAPH_A(c) isGRAPH(c)
1487 #endif
1488 #ifndef isIDCONT_A
1489 #define isIDCONT_A(c) isIDCONT(c)
1490 #endif
1491 #ifndef isIDFIRST_A
1492 #define isIDFIRST_A(c) isIDFIRST(c)
1493 #endif
1494 #ifndef isLOWER_A
1495 #define isLOWER_A(c) isLOWER(c)
1496 #endif
1497 #ifndef isOCTAL_A
1498 #define isOCTAL_A(c) isOCTAL(c)
1499 #endif
1500 #ifndef isPRINT_A
1501 #define isPRINT_A(c) isPRINT(c)
1502 #endif
1503 #ifndef isPSXSPC_A
1504 #define isPSXSPC_A(c) isPSXSPC(c)
1505 #endif
1506 #ifndef isPUNCT_A
1507 #define isPUNCT_A(c) isPUNCT(c)
1508 #endif
1509 #ifndef isSPACE_A
1510 #define isSPACE_A(c) isSPACE(c)
1511 #endif
1512 #ifndef isUPPER_A
1513 #define isUPPER_A(c) isUPPER(c)
1514 #endif
1515 #ifndef isWORDCHAR_A
1516 #define isWORDCHAR_A(c) isWORDCHAR(c)
1517 #endif
1518 #ifndef isXDIGIT_A
1519 #define isXDIGIT_A(c) isXDIGIT(c)
1520 #endif
1521 #ifndef isASCII_utf8_safe
1522 #define isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s)))
1523 #endif
1524 #ifndef isASCII_uvchr
1525 #define isASCII_uvchr(c) (FITS_IN_8_BITS(c) ? isASCII_L1(c) : 0)
1526 #endif
1527 #if (PERL_BCDVERSION >= 0x5006000)
1528 #ifdef isALPHA_uni
1529 #define D_PPP_is_ctype(upper, lower, c) \
1530 (FITS_IN_8_BITS(c) \
1531 ? is ## upper ## _L1(c) \
1532 : is ## upper ## _uni((UV) (c)))
1533 #else
1534 #define D_PPP_is_ctype(upper, lower, c) \
1535 (FITS_IN_8_BITS(c) \
1536 ? is ## upper ## _L1(c) \
1537 : is_uni_ ## lower((UV) (c)))
1538 #endif
1539 #ifndef isALPHA_uvchr
1540 #define isALPHA_uvchr(c) D_PPP_is_ctype(ALPHA, alpha, c)
1541 #endif
1542 #ifndef isALPHANUMERIC_uvchr
1543 #define isALPHANUMERIC_uvchr(c) (isALPHA_uvchr(c) || isDIGIT_uvchr(c))
1544 #endif
1545 #ifdef is_uni_blank
1546 #ifndef isBLANK_uvchr
1547 #define isBLANK_uvchr(c) D_PPP_is_ctype(BLANK, blank, c)
1548 #endif
1549 #else
1550 #ifndef isBLANK_uvchr
1551 #define isBLANK_uvchr(c) (FITS_IN_8_BITS(c) \
1552 ? isBLANK_L1(c) \
1553 : ( (UV) (c) == 0x1680 \
1554 || inRANGE((UV) (c), 0x2000, 0x200A) \
1555 || (UV) (c) == 0x202F \
1556 || (UV) (c) == 0x205F \
1557 || (UV) (c) == 0x3000))
1558 #endif
1559 #endif
1560 #ifndef isCNTRL_uvchr
1561 #define isCNTRL_uvchr(c) D_PPP_is_ctype(CNTRL, cntrl, c)
1562 #endif
1563 #ifndef isDIGIT_uvchr
1564 #define isDIGIT_uvchr(c) D_PPP_is_ctype(DIGIT, digit, c)
1565 #endif
1566 #ifndef isGRAPH_uvchr
1567 #define isGRAPH_uvchr(c) D_PPP_is_ctype(GRAPH, graph, c)
1568 #endif
1569 #ifndef isIDCONT_uvchr
1570 #define isIDCONT_uvchr(c) isWORDCHAR_uvchr(c)
1571 #endif
1572 #ifndef isIDFIRST_uvchr
1573 #define isIDFIRST_uvchr(c) D_PPP_is_ctype(IDFIRST, idfirst, c)
1574 #endif
1575 #ifndef isLOWER_uvchr
1576 #define isLOWER_uvchr(c) D_PPP_is_ctype(LOWER, lower, c)
1577 #endif
1578 #ifndef isPRINT_uvchr
1579 #define isPRINT_uvchr(c) D_PPP_is_ctype(PRINT, print, c)
1580 #endif
1581 #ifndef isPSXSPC_uvchr
1582 #define isPSXSPC_uvchr(c) isSPACE_uvchr(c)
1583 #endif
1584 #ifndef isPUNCT_uvchr
1585 #define isPUNCT_uvchr(c) D_PPP_is_ctype(PUNCT, punct, c)
1586 #endif
1587 #ifndef isSPACE_uvchr
1588 #define isSPACE_uvchr(c) D_PPP_is_ctype(SPACE, space, c)
1589 #endif
1590 #ifndef isUPPER_uvchr
1591 #define isUPPER_uvchr(c) D_PPP_is_ctype(UPPER, upper, c)
1592 #endif
1593 #ifndef isXDIGIT_uvchr
1594 #define isXDIGIT_uvchr(c) D_PPP_is_ctype(XDIGIT, xdigit, c)
1595 #endif
1596 #ifndef isWORDCHAR_uvchr
1597 #define isWORDCHAR_uvchr(c) (FITS_IN_8_BITS(c) \
1598 ? isWORDCHAR_L1(c) : isALPHANUMERIC_uvchr(c))
1599 #endif
1600 #ifndef isALPHA_utf8_safe
1601 #define isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA)
1602 #endif
1603 #ifdef isALPHANUMERIC_utf8
1604 #ifndef isALPHANUMERIC_utf8_safe
1605 #define isALPHANUMERIC_utf8_safe(s,e) \
1606 D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC)
1607 #endif
1608 #else
1609 #ifndef isALPHANUMERIC_utf8_safe
1610 #define isALPHANUMERIC_utf8_safe(s,e) \
1611 (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e))
1612 #endif
1613 #endif
1614 #if 'A' == 65
1615 #ifndef isBLANK_utf8_safe
1616 #define isBLANK_utf8_safe(s,e) \
1617 ( ( LIKELY((e) > (s)) ) ? \
1618 ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \
1619 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
1620 ( ( 0xC2 == ((const U8*)s)[0] ) ? \
1621 ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \
1622 : ( 0xE1 == ((const U8*)s)[0] ) ? \
1623 ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1624 : ( 0xE2 == ((const U8*)s)[0] ) ? \
1625 ( ( 0x80 == ((const U8*)s)[1] ) ? \
1626 ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\
1627 : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1628 : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1629 : 0 ) \
1630 : 0 )
1631 #endif
1632 #elif 'A' == 193 && '^' == 95
1633 #ifndef isBLANK_utf8_safe
1634 #define isBLANK_utf8_safe(s,e) \
1635 ( ( LIKELY((e) > (s)) ) ? \
1636 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
1637 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
1638 ( ( 0x80 == ((const U8*)s)[0] ) ? \
1639 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
1640 : ( 0xBC == ((const U8*)s)[0] ) ? \
1641 ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1642 : ( 0xCA == ((const U8*)s)[0] ) ? \
1643 ( ( 0x41 == ((const U8*)s)[1] ) ? \
1644 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
1645 : ( 0x42 == ((const U8*)s)[1] ) ? \
1646 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
1647 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1648 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1649 : 0 ) \
1650 : 0 )
1651 #endif
1652 #elif 'A' == 193 && '^' == 176
1653 #ifndef isBLANK_utf8_safe
1654 #define isBLANK_utf8_safe(s,e) \
1655 ( ( LIKELY((e) > (s)) ) ? \
1656 ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \
1657 : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \
1658 ( ( 0x78 == ((const U8*)s)[0] ) ? \
1659 ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \
1660 : ( 0xBD == ((const U8*)s)[0] ) ? \
1661 ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1662 : ( 0xCA == ((const U8*)s)[0] ) ? \
1663 ( ( 0x41 == ((const U8*)s)[1] ) ? \
1664 ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\
1665 : ( 0x42 == ((const U8*)s)[1] ) ? \
1666 ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \
1667 : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1668 : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\
1669 : 0 ) \
1670 : 0 )
1671 #endif
1672 #else
1673 #error Unknown character set
1674 #endif
1675 #ifndef isCNTRL_utf8_safe
1676 #define isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL)
1677 #endif
1678 #ifndef isDIGIT_utf8_safe
1679 #define isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT)
1680 #endif
1681 #ifndef isGRAPH_utf8_safe
1682 #define isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH)
1683 #endif
1684 #ifdef isIDCONT_utf8
1685 #ifndef isIDCONT_utf8_safe
1686 #define isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT)
1687 #endif
1688 #else
1689 #ifndef isIDCONT_utf8_safe
1690 #define isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e)
1691 #endif
1692 #endif
1693 #ifndef isIDFIRST_utf8_safe
1694 #define isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST)
1695 #endif
1696 #ifndef isLOWER_utf8_safe
1697 #define isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER)
1698 #endif
1699 #ifndef isPRINT_utf8_safe
1700 #define isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT)
1701 #endif
1702 #undef isPSXSPC_utf8_safe
1703 #ifndef isPSXSPC_utf8_safe
1704 #define isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e)
1705 #endif
1706 #ifndef isPUNCT_utf8_safe
1707 #define isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT)
1708 #endif
1709 #ifndef isSPACE_utf8_safe
1710 #define isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE)
1711 #endif
1712 #ifndef isUPPER_utf8_safe
1713 #define isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER)
1714 #endif
1715 #ifdef isWORDCHAR_utf8
1716 #ifndef isWORDCHAR_utf8_safe
1717 #define isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR)
1718 #endif
1719 #else
1720 #ifndef isWORDCHAR_utf8_safe
1721 #define isWORDCHAR_utf8_safe(s,e) \
1722 (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_')
1723 #endif
1724 #endif
1725 #if 'A' == 65
1726 #ifndef isXDIGIT_utf8_safe
1727 #define isXDIGIT_utf8_safe(s,e) \
1728 ( ( LIKELY((e) > (s)) ) ? \
1729 ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\
1730 : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\
1731 ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\
1732 : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\
1733 : 0 )
1734 #endif
1735 #elif 'A' == 193 && '^' == 95
1736 #ifndef isXDIGIT_utf8_safe
1737 #define isXDIGIT_utf8_safe(s,e) \
1738 ( ( LIKELY((e) > (s)) ) ? \
1739 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
1740 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\
1741 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\
1742 : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
1743 : 0 )
1744 #endif
1745 #elif 'A' == 193 && '^' == 176
1746 #ifndef isXDIGIT_utf8_safe
1747 #define isXDIGIT_utf8_safe(s,e) \
1748 ( ( LIKELY((e) > (s)) ) ? \
1749 ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\
1750 : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\
1751 ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\
1752 : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\
1753 : 0 )
1754 #endif
1755 #else
1756 #error Unknown character set
1757 #endif
1758 #ifndef isALPHA_LC_utf8_safe
1759 #define isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA)
1760 #endif
1761 #ifdef isALPHANUMERIC_utf8
1762 #ifndef isALPHANUMERIC_LC_utf8_safe
1763 #define isALPHANUMERIC_LC_utf8_safe(s,e) \
1764 D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC)
1765 #endif
1766 #else
1767 #ifndef isALPHANUMERIC_LC_utf8_safe
1768 #define isALPHANUMERIC_LC_utf8_safe(s,e) \
1769 (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e))
1770 #endif
1771 #endif
1772 #ifndef isBLANK_LC_utf8_safe
1773 #define isBLANK_LC_utf8_safe(s,e) \
1774 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK)
1775 #endif
1776 #ifndef isCNTRL_LC_utf8_safe
1777 #define isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL)
1778 #endif
1779 #ifndef isDIGIT_LC_utf8_safe
1780 #define isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT)
1781 #endif
1782 #ifndef isGRAPH_LC_utf8_safe
1783 #define isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH)
1784 #endif
1785 #ifdef isIDCONT_utf8
1786 #ifndef isIDCONT_LC_utf8_safe
1787 #define isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT)
1788 #endif
1789 #else
1790 #ifndef isIDCONT_LC_utf8_safe
1791 #define isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e)
1792 #endif
1793 #endif
1794 #ifndef isIDFIRST_LC_utf8_safe
1795 #define isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST)
1796 #endif
1797 #ifndef isLOWER_LC_utf8_safe
1798 #define isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER)
1799 #endif
1800 #ifndef isPRINT_LC_utf8_safe
1801 #define isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT)
1802 #endif
1803 #undef isPSXSPC_LC_utf8_safe
1804 #ifndef isPSXSPC_LC_utf8_safe
1805 #define isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e)
1806 #endif
1807 #ifndef isPUNCT_LC_utf8_safe
1808 #define isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT)
1809 #endif
1810 #ifndef isSPACE_LC_utf8_safe
1811 #define isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE)
1812 #endif
1813 #ifndef isUPPER_LC_utf8_safe
1814 #define isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER)
1815 #endif
1816 #ifdef isWORDCHAR_utf8
1817 #ifndef isWORDCHAR_LC_utf8_safe
1818 #define isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR)
1819 #endif
1820 #else
1821 #ifndef isWORDCHAR_LC_utf8_safe
1822 #define isWORDCHAR_LC_utf8_safe(s,e) \
1823 (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_')
1824 #endif
1825 #endif
1826 #ifndef isXDIGIT_LC_utf8_safe
1827 #define isXDIGIT_LC_utf8_safe(s,e) \
1828 D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT)
1829 #endif
1830 #endif
1831 #define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \
1832 " \\x%02x (too short; %d bytes available, need" \
1833 " %d)\n"
1834 #if (PERL_BCDVERSION >= 0x5007003)
1835 #ifndef toLOWER_uvchr
1836 #define toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l))
1837 #endif
1838 #ifndef toUPPER_uvchr
1839 #define toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l))
1840 #endif
1841 #ifndef toTITLE_uvchr
1842 #define toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l))
1843 #endif
1844 #ifndef toFOLD_uvchr
1845 #define toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l))
1846 #endif
1847 #if (PERL_BCDVERSION != 0x5015006)
1848 #if defined toLOWER_utf8
1849 #define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l)
1850 #else
1851 #define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l)
1852 #endif
1853 #if defined toTITLE_utf8
1854 #define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l)
1855 #else
1856 #define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l)
1857 #endif
1858 #if defined toUPPER_utf8
1859 #define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l)
1860 #else
1861 #define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l)
1862 #endif
1863 #if defined toFOLD_utf8
1864 #define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l)
1865 #else
1866 #define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l)
1867 #endif
1868 #else
1869 #define D_PPP_TO_LOWER_CALLEE(s,r,l) \
1870 Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL)
1871 #define D_PPP_TO_TITLE_CALLEE(s,r,l) \
1872 Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL)
1873 #define D_PPP_TO_UPPER_CALLEE(s,r,l) \
1874 Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL)
1875 #define D_PPP_TO_FOLD_CALLEE(s,r,l) \
1876 Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL)
1877 #endif
1878 #define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \
1879 (((((e) - (s)) <= 0) \
1880 \
1881 ? (croak("Attempting case change on zero length string"), \
1882 0) \
1883 : ((e) - (s)) < UTF8SKIP(s)) \
1884 ? (croak(D_PPP_TOO_SHORT_MSG, \
1885 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
1886 0) \
1887 : D_PPP_TO_ ## name ## _CALLEE(s,r,l))
1888 #ifndef toUPPER_utf8_safe
1889 #define toUPPER_utf8_safe(s,e,r,l) \
1890 D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l)
1891 #endif
1892 #ifndef toLOWER_utf8_safe
1893 #define toLOWER_utf8_safe(s,e,r,l) \
1894 D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l)
1895 #endif
1896 #ifndef toTITLE_utf8_safe
1897 #define toTITLE_utf8_safe(s,e,r,l) \
1898 D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l)
1899 #endif
1900 #ifndef toFOLD_utf8_safe
1901 #define toFOLD_utf8_safe(s,e,r,l) \
1902 D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l)
1903 #endif
1904 #elif (PERL_BCDVERSION >= 0x5006000)
1905 #ifdef uvchr_to_utf8
1906 #define D_PPP_UV_TO_UTF8 uvchr_to_utf8
1907 #else
1908 #define D_PPP_UV_TO_UTF8 uv_to_utf8
1909 #endif
1910 #define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \
1911 (*(l) = (D_PPP_UV_TO_UTF8(s, \
1912 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \
1913 UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c))))
1914 #ifndef toLOWER_uvchr
1915 #define toLOWER_uvchr(c, s, l) \
1916 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l)
1917 #endif
1918 #ifndef toUPPER_uvchr
1919 #define toUPPER_uvchr(c, s, l) \
1920 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l)
1921 #endif
1922 #ifndef toTITLE_uvchr
1923 #define toTITLE_uvchr(c, s, l) \
1924 D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l)
1925 #endif
1926 #ifndef toFOLD_uvchr
1927 #define toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l)
1928 #endif
1929 #define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \
1930 (((((e) - (s)) <= 0) \
1931 ? (croak("Attempting case change on zero length string"), \
1932 0) \
1933 : ((e) - (s)) < UTF8SKIP(s)) \
1934 ? (croak(D_PPP_TOO_SHORT_MSG, \
1935 s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \
1936 0) \
1937 \
1938 : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \
1939 \
1940 *(l) = UTF8SKIP(r), to_utf8_ ## name(r))
1941 #ifndef toUPPER_utf8_safe
1942 #define toUPPER_utf8_safe(s,e,r,l) \
1943 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l)
1944 #endif
1945 #ifndef toLOWER_utf8_safe
1946 #define toLOWER_utf8_safe(s,e,r,l) \
1947 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l)
1948 #endif
1949 #ifndef toTITLE_utf8_safe
1950 #define toTITLE_utf8_safe(s,e,r,l) \
1951 D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l)
1952 #endif
1953 #ifndef toFOLD_utf8_safe
1954 #define toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l)
1955 #endif
1956 #endif
1957 #if (PERL_BCDVERSION >= 0x5008000)
1958 #ifndef HeUTF8
1959 #define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \
1960 SvUTF8(HeKEY_sv(he)) : \
1961 (U32)HeKUTF8(he))
1962 #endif
1963 #endif
1964 #ifndef C_ARRAY_LENGTH
1965 #define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0]))
1966 #endif
1967 #ifndef C_ARRAY_END
1968 #define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))
1969 #endif
1970 #ifndef LIKELY
1971 #define LIKELY(x) (x)
1972 #endif
1973 #ifndef UNLIKELY
1974 #define UNLIKELY(x) (x)
1975 #endif
1976 #ifndef MUTABLE_PTR
1977 #if defined(PERL_USE_GCC_BRACE_GROUPS)
1978 #define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
1979 #else
1980 #define MUTABLE_PTR(p) ((void *) (p))
1981 #endif
1982 #endif
1983 #ifndef MUTABLE_AV
1984 #define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p))
1985 #endif
1986 #ifndef MUTABLE_CV
1987 #define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p))
1988 #endif
1989 #ifndef MUTABLE_GV
1990 #define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p))
1991 #endif
1992 #ifndef MUTABLE_HV
1993 #define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p))
1994 #endif
1995 #ifndef MUTABLE_IO
1996 #define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
1997 #endif
1998 #ifndef MUTABLE_SV
1999 #define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
2000 #endif
2001 #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf)
2002 #if defined(PERL_USE_GCC_BRACE_GROUPS)
2003 #define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; })
2004 #else
2005 #define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_Sv)
2006 #endif
2007 #endif
2008 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf)
2009 #define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
2010 #endif
2011 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf)
2012 #define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
2013 #endif
2014 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg)
2015 #if defined(NEED_sv_catpvf_mg)
2016 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
2017 static
2018 #else
2019 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
2020 #endif
2021 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
2022 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
2023 void
DPPP_(my_sv_catpvf_mg)2024 DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
2025 {
2026 va_list args;
2027 va_start(args, pat);
2028 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
2029 SvSETMAGIC(sv);
2030 va_end(args);
2031 }
2032 #endif
2033 #endif
2034 #ifdef PERL_IMPLICIT_CONTEXT
2035 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext)
2036 #if defined(NEED_sv_catpvf_mg_nocontext)
2037 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
2038 static
2039 #else
2040 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
2041 #endif
2042 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
2043 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
2044 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
2045 void
DPPP_(my_sv_catpvf_mg_nocontext)2046 DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
2047 {
2048 dTHX;
2049 va_list args;
2050 va_start(args, pat);
2051 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
2052 SvSETMAGIC(sv);
2053 va_end(args);
2054 }
2055 #endif
2056 #endif
2057 #endif
2058 #ifndef sv_catpvf_mg
2059 #ifdef PERL_IMPLICIT_CONTEXT
2060 #define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
2061 #else
2062 #define sv_catpvf_mg Perl_sv_catpvf_mg
2063 #endif
2064 #endif
2065 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg)
2066 #define sv_vcatpvf_mg(sv, pat, args) \
2067 STMT_START { \
2068 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
2069 SvSETMAGIC(sv); \
2070 } STMT_END
2071 #endif
2072 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg)
2073 #if defined(NEED_sv_setpvf_mg)
2074 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
2075 static
2076 #else
2077 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...);
2078 #endif
2079 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
2080 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
2081 void
DPPP_(my_sv_setpvf_mg)2082 DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...)
2083 {
2084 va_list args;
2085 va_start(args, pat);
2086 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
2087 SvSETMAGIC(sv);
2088 va_end(args);
2089 }
2090 #endif
2091 #endif
2092 #ifdef PERL_IMPLICIT_CONTEXT
2093 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext)
2094 #if defined(NEED_sv_setpvf_mg_nocontext)
2095 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
2096 static
2097 #else
2098 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...);
2099 #endif
2100 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
2101 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
2102 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
2103 void
DPPP_(my_sv_setpvf_mg_nocontext)2104 DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...)
2105 {
2106 dTHX;
2107 va_list args;
2108 va_start(args, pat);
2109 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
2110 SvSETMAGIC(sv);
2111 va_end(args);
2112 }
2113 #endif
2114 #endif
2115 #endif
2116 #ifndef sv_setpvf_mg
2117 #ifdef PERL_IMPLICIT_CONTEXT
2118 #define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
2119 #else
2120 #define sv_setpvf_mg Perl_sv_setpvf_mg
2121 #endif
2122 #endif
2123 #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg)
2124 #define sv_vsetpvf_mg(sv, pat, args) \
2125 STMT_START { \
2126 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
2127 SvSETMAGIC(sv); \
2128 } STMT_END
2129 #endif
2130 #ifndef sv_2pv_nolen
2131 #define sv_2pv_nolen(sv) SvPV_nolen(sv)
2132 #endif
2133 #ifdef SvPVbyte
2134 #if (PERL_BCDVERSION < 0x5007000)
2135 #ifndef sv_2pvbyte
2136 #define sv_2pvbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), *(lp)))
2137 #endif
2138 #undef SvPVbyte
2139 #define SvPVbyte(sv, lp) \
2140 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
2141 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
2142 #endif
2143 #else
2144 #define SvPVbyte SvPV
2145 #define sv_2pvbyte sv_2pv
2146 #endif
2147 #ifndef sv_2pvbyte_nolen
2148 #define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv)
2149 #endif
2150 #ifndef SV_IMMEDIATE_UNREF
2151 #define SV_IMMEDIATE_UNREF 0
2152 #endif
2153 #ifndef SV_GMAGIC
2154 #define SV_GMAGIC 0
2155 #endif
2156 #ifndef SV_COW_DROP_PV
2157 #define SV_COW_DROP_PV 0
2158 #endif
2159 #ifndef SV_UTF8_NO_ENCODING
2160 #define SV_UTF8_NO_ENCODING 0
2161 #endif
2162 #ifndef SV_CONST_RETURN
2163 #define SV_CONST_RETURN 0
2164 #endif
2165 #ifndef SV_MUTABLE_RETURN
2166 #define SV_MUTABLE_RETURN 0
2167 #endif
2168 #ifndef SV_SMAGIC
2169 #define SV_SMAGIC 0
2170 #endif
2171 #ifndef SV_HAS_TRAILING_NUL
2172 #define SV_HAS_TRAILING_NUL 0
2173 #endif
2174 #ifndef SV_COW_SHARED_HASH_KEYS
2175 #define SV_COW_SHARED_HASH_KEYS 0
2176 #endif
2177 #if defined(PERL_USE_GCC_BRACE_GROUPS)
2178 #ifndef sv_2pv_flags
2179 #define sv_2pv_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_2pv(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_2pv(_sv, _lp); })
2180 #endif
2181 #ifndef sv_pvn_force_flags
2182 #define sv_pvn_force_flags(sv, lp, flags) ({ SV *_sv = (sv); const I32 _flags = (flags); STRLEN *_lp = lp; _lp = _lp ? : &PL_na; (!(_flags & SV_GMAGIC) && SvGMAGICAL(_sv)) ? ({ char *_pv; SvGMAGICAL_off(_sv); _pv = sv_pvn_force(_sv, _lp); SvGMAGICAL_on(_sv); _pv; }) : sv_pvn_force(_sv, _lp); })
2183 #endif
2184 #else
2185 #ifndef sv_2pv_flags
2186 #define sv_2pv_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_2pv(PL_Sv, (lp) ? (lp) : &PL_na))
2187 #endif
2188 #ifndef sv_pvn_force_flags
2189 #define sv_pvn_force_flags(sv, lp, flags) ((PL_Sv = (sv)), (!((flags) & SV_GMAGIC) && SvGMAGICAL(PL_Sv)) ? (SvGMAGICAL_off(PL_Sv), (PL_Xpv = (XPV *)sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na)), SvGMAGICAL_on(PL_Sv), (char *)PL_Xpv) : sv_pvn_force(PL_Sv, (lp) ? (lp) : &PL_na))
2190 #endif
2191 #endif
2192 #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) )
2193 #define D_PPP_SVPV_NOLEN_LP_ARG &PL_na
2194 #else
2195 #define D_PPP_SVPV_NOLEN_LP_ARG 0
2196 #endif
2197 #ifndef SvPV_const
2198 #define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
2199 #endif
2200 #ifndef SvPV_mutable
2201 #define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
2202 #endif
2203 #ifndef SvPV_flags
2204 #define SvPV_flags(sv, lp, flags) \
2205 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2206 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
2207 #endif
2208 #ifndef SvPV_flags_const
2209 #define SvPV_flags_const(sv, lp, flags) \
2210 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2211 ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
2212 (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
2213 #endif
2214 #ifndef SvPV_flags_const_nolen
2215 #define SvPV_flags_const_nolen(sv, flags) \
2216 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2217 ? SvPVX_const(sv) : \
2218 (const char*) sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN))
2219 #endif
2220 #ifndef SvPV_flags_mutable
2221 #define SvPV_flags_mutable(sv, lp, flags) \
2222 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2223 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
2224 sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
2225 #endif
2226 #ifndef SvPV_force
2227 #define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC)
2228 #endif
2229 #ifndef SvPV_force_nolen
2230 #define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC)
2231 #endif
2232 #ifndef SvPV_force_mutable
2233 #define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC)
2234 #endif
2235 #ifndef SvPV_force_nomg
2236 #define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0)
2237 #endif
2238 #ifndef SvPV_force_nomg_nolen
2239 #define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
2240 #endif
2241 #ifndef SvPV_force_flags
2242 #define SvPV_force_flags(sv, lp, flags) \
2243 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
2244 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
2245 #endif
2246 #ifndef SvPV_force_flags_nolen
2247 #define SvPV_force_flags_nolen(sv, flags) \
2248 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
2249 ? SvPVX(sv) : sv_pvn_force_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, flags))
2250 #endif
2251 #ifndef SvPV_force_flags_mutable
2252 #define SvPV_force_flags_mutable(sv, lp, flags) \
2253 ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
2254 ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
2255 : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
2256 #endif
2257 #ifndef SvPV_nolen
2258 #define SvPV_nolen(sv) \
2259 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2260 ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC))
2261 #endif
2262 #ifndef SvPV_nolen_const
2263 #define SvPV_nolen_const(sv) \
2264 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2265 ? SvPVX_const(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN))
2266 #endif
2267 #if defined(PERL_USE_GCC_BRACE_GROUPS)
2268 #ifndef SvPVx_nolen_const
2269 #define SvPVx_nolen_const(sv) ({SV *sV_ = (sv); SvPV_nolen_const(sV_); })
2270 #endif
2271 #else
2272 #ifndef SvPVx_nolen_const
2273 #define SvPVx_nolen_const(sv) (PL_Sv = sv, SvPV_nolen_const(PL_Sv))
2274 #endif
2275 #endif
2276 #ifndef SvPV_nomg
2277 #define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
2278 #endif
2279 #ifndef SvPV_nomg_const
2280 #define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0)
2281 #endif
2282 #ifndef SvPV_nomg_const_nolen
2283 #define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0)
2284 #endif
2285 #ifndef SvPV_nomg_nolen
2286 #define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
2287 ? SvPVX(sv) : sv_2pv_flags(sv, D_PPP_SVPV_NOLEN_LP_ARG, 0))
2288 #endif
2289 #ifndef SvPV_renew
2290 #define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \
2291 SvPV_set((sv), (char *) saferealloc( \
2292 (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \
2293 } STMT_END
2294 #endif
2295 #ifndef WARN_ALL
2296 #define WARN_ALL 0
2297 #endif
2298 #ifndef WARN_CLOSURE
2299 #define WARN_CLOSURE 1
2300 #endif
2301 #ifndef WARN_DEPRECATED
2302 #define WARN_DEPRECATED 2
2303 #endif
2304 #ifndef WARN_EXITING
2305 #define WARN_EXITING 3
2306 #endif
2307 #ifndef WARN_GLOB
2308 #define WARN_GLOB 4
2309 #endif
2310 #ifndef WARN_IO
2311 #define WARN_IO 5
2312 #endif
2313 #ifndef WARN_CLOSED
2314 #define WARN_CLOSED 6
2315 #endif
2316 #ifndef WARN_EXEC
2317 #define WARN_EXEC 7
2318 #endif
2319 #ifndef WARN_LAYER
2320 #define WARN_LAYER 8
2321 #endif
2322 #ifndef WARN_NEWLINE
2323 #define WARN_NEWLINE 9
2324 #endif
2325 #ifndef WARN_PIPE
2326 #define WARN_PIPE 10
2327 #endif
2328 #ifndef WARN_UNOPENED
2329 #define WARN_UNOPENED 11
2330 #endif
2331 #ifndef WARN_MISC
2332 #define WARN_MISC 12
2333 #endif
2334 #ifndef WARN_NUMERIC
2335 #define WARN_NUMERIC 13
2336 #endif
2337 #ifndef WARN_ONCE
2338 #define WARN_ONCE 14
2339 #endif
2340 #ifndef WARN_OVERFLOW
2341 #define WARN_OVERFLOW 15
2342 #endif
2343 #ifndef WARN_PACK
2344 #define WARN_PACK 16
2345 #endif
2346 #ifndef WARN_PORTABLE
2347 #define WARN_PORTABLE 17
2348 #endif
2349 #ifndef WARN_RECURSION
2350 #define WARN_RECURSION 18
2351 #endif
2352 #ifndef WARN_REDEFINE
2353 #define WARN_REDEFINE 19
2354 #endif
2355 #ifndef WARN_REGEXP
2356 #define WARN_REGEXP 20
2357 #endif
2358 #ifndef WARN_SEVERE
2359 #define WARN_SEVERE 21
2360 #endif
2361 #ifndef WARN_DEBUGGING
2362 #define WARN_DEBUGGING 22
2363 #endif
2364 #ifndef WARN_INPLACE
2365 #define WARN_INPLACE 23
2366 #endif
2367 #ifndef WARN_INTERNAL
2368 #define WARN_INTERNAL 24
2369 #endif
2370 #ifndef WARN_MALLOC
2371 #define WARN_MALLOC 25
2372 #endif
2373 #ifndef WARN_SIGNAL
2374 #define WARN_SIGNAL 26
2375 #endif
2376 #ifndef WARN_SUBSTR
2377 #define WARN_SUBSTR 27
2378 #endif
2379 #ifndef WARN_SYNTAX
2380 #define WARN_SYNTAX 28
2381 #endif
2382 #ifndef WARN_AMBIGUOUS
2383 #define WARN_AMBIGUOUS 29
2384 #endif
2385 #ifndef WARN_BAREWORD
2386 #define WARN_BAREWORD 30
2387 #endif
2388 #ifndef WARN_DIGIT
2389 #define WARN_DIGIT 31
2390 #endif
2391 #ifndef WARN_PARENTHESIS
2392 #define WARN_PARENTHESIS 32
2393 #endif
2394 #ifndef WARN_PRECEDENCE
2395 #define WARN_PRECEDENCE 33
2396 #endif
2397 #ifndef WARN_PRINTF
2398 #define WARN_PRINTF 34
2399 #endif
2400 #ifndef WARN_PROTOTYPE
2401 #define WARN_PROTOTYPE 35
2402 #endif
2403 #ifndef WARN_QW
2404 #define WARN_QW 36
2405 #endif
2406 #ifndef WARN_RESERVED
2407 #define WARN_RESERVED 37
2408 #endif
2409 #ifndef WARN_SEMICOLON
2410 #define WARN_SEMICOLON 38
2411 #endif
2412 #ifndef WARN_TAINT
2413 #define WARN_TAINT 39
2414 #endif
2415 #ifndef WARN_THREADS
2416 #define WARN_THREADS 40
2417 #endif
2418 #ifndef WARN_UNINITIALIZED
2419 #define WARN_UNINITIALIZED 41
2420 #endif
2421 #ifndef WARN_UNPACK
2422 #define WARN_UNPACK 42
2423 #endif
2424 #ifndef WARN_UNTIE
2425 #define WARN_UNTIE 43
2426 #endif
2427 #ifndef WARN_UTF8
2428 #define WARN_UTF8 44
2429 #endif
2430 #ifndef WARN_VOID
2431 #define WARN_VOID 45
2432 #endif
2433 #ifndef WARN_ASSERTIONS
2434 #define WARN_ASSERTIONS 46
2435 #endif
2436 #ifndef packWARN
2437 #define packWARN(a) (a)
2438 #endif
2439 #ifndef packWARN2
2440 #define packWARN2(a,b) (packWARN(a) << 8 | (b))
2441 #endif
2442 #ifndef packWARN3
2443 #define packWARN3(a,b,c) (packWARN2(a,b) << 8 | (c))
2444 #endif
2445 #ifndef packWARN4
2446 #define packWARN4(a,b,c,d) (packWARN3(a,b,c) << 8 | (d))
2447 #endif
2448 #ifndef ckWARN
2449 #ifdef G_WARN_ON
2450 #define ckWARN(a) (PL_dowarn & G_WARN_ON)
2451 #else
2452 #define ckWARN(a) PL_dowarn
2453 #endif
2454 #endif
2455 #ifndef ckWARN2
2456 #define ckWARN2(a,b) (ckWARN(a) || ckWARN(b))
2457 #endif
2458 #ifndef ckWARN3
2459 #define ckWARN3(a,b,c) (ckWARN(c) || ckWARN2(a,b))
2460 #endif
2461 #ifndef ckWARN4
2462 #define ckWARN4(a,b,c,d) (ckWARN(d) || ckWARN3(a,b,c))
2463 #endif
2464 #ifndef ckWARN_d
2465 #ifdef isLEXWARN_off
2466 #define ckWARN_d(a) (isLEXWARN_off || ckWARN(a))
2467 #else
2468 #define ckWARN_d(a) 1
2469 #endif
2470 #endif
2471 #ifndef ckWARN2_d
2472 #define ckWARN2_d(a,b) (ckWARN_d(a) || ckWARN_d(b))
2473 #endif
2474 #ifndef ckWARN3_d
2475 #define ckWARN3_d(a,b,c) (ckWARN_d(c) || ckWARN2_d(a,b))
2476 #endif
2477 #ifndef ckWARN4_d
2478 #define ckWARN4_d(a,b,c,d) (ckWARN_d(d) || ckWARN3_d(a,b,c))
2479 #endif
2480 #ifndef vwarner
2481 #define vwarner(err, pat, argsp) \
2482 STMT_START { SV *sv; \
2483 PERL_UNUSED_ARG(err); \
2484 sv = vnewSVpvf(pat, argsp); \
2485 sv_2mortal(sv); \
2486 warn("%s", SvPV_nolen(sv)); \
2487 } STMT_END
2488 #endif
2489 #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner)
2490 #if defined(NEED_warner)
2491 static void DPPP_(my_warner)(U32 err, const char * pat, ...);
2492 static
2493 #else
2494 extern void DPPP_(my_warner)(U32 err, const char * pat, ...);
2495 #endif
2496 #if defined(NEED_warner) || defined(NEED_warner_GLOBAL)
2497 #define Perl_warner DPPP_(my_warner)
2498 void
DPPP_(my_warner)2499 DPPP_(my_warner)(U32 err, const char *pat, ...)
2500 {
2501 va_list args;
2502 va_start(args, pat);
2503 vwarner(err, pat, &args);
2504 va_end(args);
2505 }
2506 #define warner Perl_warner
2507 #define Perl_warner_nocontext Perl_warner
2508 #endif
2509 #endif
2510 #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner)
2511 #if defined(NEED_ck_warner)
2512 static void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...);
2513 static
2514 #else
2515 extern void DPPP_(my_ck_warner)(pTHX_ U32 err, const char * pat, ...);
2516 #endif
2517 #if defined(NEED_ck_warner) || defined(NEED_ck_warner_GLOBAL)
2518 #define Perl_ck_warner DPPP_(my_ck_warner)
2519 void
DPPP_(my_ck_warner)2520 DPPP_(my_ck_warner)(pTHX_ U32 err, const char *pat, ...)
2521 {
2522 va_list args;
2523 if ( ! ckWARN((err ) & 0xFF)
2524 && ! ckWARN((err >> 8) & 0xFF)
2525 && ! ckWARN((err >> 16) & 0xFF)
2526 && ! ckWARN((err >> 24) & 0xFF))
2527 {
2528 return;
2529 }
2530 va_start(args, pat);
2531 vwarner(err, pat, &args);
2532 va_end(args);
2533 }
2534 #define ck_warner Perl_ck_warner
2535 #endif
2536 #endif
2537 #if (PERL_BCDVERSION >= 0x5004000) && !defined(ck_warner_d)
2538 #if defined(NEED_ck_warner_d)
2539 static void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...);
2540 static
2541 #else
2542 extern void DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char * pat, ...);
2543 #endif
2544 #if defined(NEED_ck_warner_d) || defined(NEED_ck_warner_d_GLOBAL)
2545 #define Perl_ck_warner_d DPPP_(my_ck_warner_d)
2546 void
DPPP_(my_ck_warner_d)2547 DPPP_(my_ck_warner_d)(pTHX_ U32 err, const char *pat, ...)
2548 {
2549 va_list args;
2550 if ( ! ckWARN_d((err ) & 0xFF)
2551 && ! ckWARN_d((err >> 8) & 0xFF)
2552 && ! ckWARN_d((err >> 16) & 0xFF)
2553 && ! ckWARN_d((err >> 24) & 0xFF))
2554 {
2555 return;
2556 }
2557 va_start(args, pat);
2558 vwarner(err, pat, &args);
2559 va_end(args);
2560 }
2561 #define ck_warner_d Perl_ck_warner_d
2562 #endif
2563 #endif
2564 #ifndef IVdf
2565 #if IVSIZE == LONGSIZE
2566 #define IVdf "ld"
2567 #define UVuf "lu"
2568 #define UVof "lo"
2569 #define UVxf "lx"
2570 #define UVXf "lX"
2571 #elif IVSIZE == INTSIZE
2572 #define IVdf "d"
2573 #define UVuf "u"
2574 #define UVof "o"
2575 #define UVxf "x"
2576 #define UVXf "X"
2577 #else
2578 #error "cannot define IV/UV formats"
2579 #endif
2580 #endif
2581 #ifndef NVef
2582 #if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
2583 defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
2584 #define NVef PERL_PRIeldbl
2585 #define NVff PERL_PRIfldbl
2586 #define NVgf PERL_PRIgldbl
2587 #else
2588 #define NVef "e"
2589 #define NVff "f"
2590 #define NVgf "g"
2591 #endif
2592 #endif
2593 #ifndef sv_setuv
2594 #define sv_setuv(sv, uv) \
2595 STMT_START { \
2596 UV TeMpUv = uv; \
2597 if (TeMpUv <= IV_MAX) \
2598 sv_setiv(sv, TeMpUv); \
2599 else \
2600 sv_setnv(sv, (double)TeMpUv); \
2601 } STMT_END
2602 #endif
2603 #ifndef newSVuv
2604 #define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
2605 #endif
2606 #if defined(PERL_USE_GCC_BRACE_GROUPS)
2607 #ifndef sv_2uv
2608 #define sv_2uv(sv) ({ SV *_sv = (sv); (UV) (SvNOK(_sv) ? SvNV(_sv) : sv_2nv(_sv)); })
2609 #endif
2610 #else
2611 #ifndef sv_2uv
2612 #define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
2613 #endif
2614 #endif
2615 #ifndef SvUVX
2616 #define SvUVX(sv) ((UV)SvIVX(sv))
2617 #endif
2618 #ifndef SvUVXx
2619 #define SvUVXx(sv) SvUVX(sv)
2620 #endif
2621 #ifndef SvUV
2622 #define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
2623 #endif
2624 #if defined(PERL_USE_GCC_BRACE_GROUPS)
2625 #ifndef SvUVx
2626 #define SvUVx(sv) ({ SV *_sv = (sv)); SvUV(_sv); })
2627 #endif
2628 #else
2629 #ifndef SvUVx
2630 #define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
2631 #endif
2632 #endif
2633 #ifndef sv_uv
2634 #define sv_uv(sv) SvUVx(sv)
2635 #endif
2636 #if !defined(SvUOK) && defined(SvIOK_UV)
2637 #define SvUOK(sv) SvIOK_UV(sv)
2638 #endif
2639 #ifndef XST_mUV
2640 #define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
2641 #endif
2642 #ifndef XSRETURN_UV
2643 #define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
2644 #endif
2645 #ifndef PUSHu
2646 #define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
2647 #endif
2648 #ifndef XPUSHu
2649 #define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
2650 #endif
2651 #if !defined(my_strnlen)
2652 #if defined(NEED_my_strnlen)
2653 static Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen);
2654 static
2655 #else
2656 extern Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen);
2657 #endif
2658 #if defined(NEED_my_strnlen) || defined(NEED_my_strnlen_GLOBAL)
2659 #define my_strnlen DPPP_(my_my_strnlen)
2660 #define Perl_my_strnlen DPPP_(my_my_strnlen)
2661 Size_t
DPPP_(my_my_strnlen)2662 DPPP_(my_my_strnlen)(const char *str, Size_t maxlen)
2663 {
2664 const char *p = str;
2665 while(maxlen-- && *p)
2666 p++;
2667 return p - str;
2668 }
2669 #endif
2670 #endif
2671 #ifdef HAS_MEMCMP
2672 #ifndef memNE
2673 #define memNE(s1,s2,l) (memcmp(s1,s2,l))
2674 #endif
2675 #ifndef memEQ
2676 #define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
2677 #endif
2678 #else
2679 #ifndef memNE
2680 #define memNE(s1,s2,l) (bcmp(s1,s2,l))
2681 #endif
2682 #ifndef memEQ
2683 #define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
2684 #endif
2685 #endif
2686 #ifndef memEQs
2687 #define memEQs(s1, l, s2) \
2688 (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1)))
2689 #endif
2690 #ifndef memNEs
2691 #define memNEs(s1, l, s2) !memEQs(s1, l, s2)
2692 #endif
2693 #ifndef memCHRs
2694 #define memCHRs(s, c) ((const char *) memchr("" s "" , c, sizeof(s)-1))
2695 #endif
2696 #ifndef MoveD
2697 #define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
2698 #endif
2699 #ifndef CopyD
2700 #define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
2701 #endif
2702 #ifdef HAS_MEMSET
2703 #ifndef ZeroD
2704 #define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
2705 #endif
2706 #else
2707 #ifndef ZeroD
2708 #define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
2709 #endif
2710 #endif
2711 #ifndef PoisonWith
2712 #define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t))
2713 #endif
2714 #ifndef PoisonNew
2715 #define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB)
2716 #endif
2717 #ifndef PoisonFree
2718 #define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF)
2719 #endif
2720 #ifndef Poison
2721 #define Poison(d,n,t) PoisonFree(d,n,t)
2722 #endif
2723 #ifndef Newx
2724 #define Newx(v,n,t) New(0,v,n,t)
2725 #endif
2726 #ifndef Newxc
2727 #define Newxc(v,n,t,c) Newc(0,v,n,t,c)
2728 #endif
2729 #ifndef Newxz
2730 #define Newxz(v,n,t) Newz(0,v,n,t)
2731 #endif
2732 #ifdef NEED_mess_sv
2733 #define NEED_mess
2734 #endif
2735 #ifdef NEED_mess
2736 #define NEED_mess_nocontext
2737 #define NEED_vmess
2738 #endif
2739 #ifndef croak_sv
2740 #if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) )
2741 #if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) )
2742 #define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \
2743 STMT_START { \
2744 SV *_errsv = ERRSV; \
2745 SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) | \
2746 (SvFLAGS(sv) & SVf_UTF8); \
2747 } STMT_END
2748 #else
2749 #define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END
2750 #endif
2751 #define croak_sv(sv) \
2752 STMT_START { \
2753 SV *_sv = (sv); \
2754 if (SvROK(_sv)) { \
2755 sv_setsv(ERRSV, _sv); \
2756 croak(NULL); \
2757 } else { \
2758 D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \
2759 croak("%" SVf, SVfARG(_sv)); \
2760 } \
2761 } STMT_END
2762 #elif (PERL_BCDVERSION >= 0x5004000)
2763 #define croak_sv(sv) croak("%" SVf, SVfARG(sv))
2764 #else
2765 #define croak_sv(sv) croak("%s", SvPV_nolen(sv))
2766 #endif
2767 #endif
2768 #ifndef die_sv
2769 #if defined(NEED_die_sv)
2770 static OP * DPPP_(my_die_sv)(pTHX_ SV * baseex);
2771 static
2772 #else
2773 extern OP * DPPP_(my_die_sv)(pTHX_ SV * baseex);
2774 #endif
2775 #if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL)
2776 #ifdef die_sv
2777 #undef die_sv
2778 #endif
2779 #define die_sv(a) DPPP_(my_die_sv)(aTHX_ a)
2780 #define Perl_die_sv DPPP_(my_die_sv)
2781 OP *
DPPP_(my_die_sv)2782 DPPP_(my_die_sv)(pTHX_ SV *baseex)
2783 {
2784 croak_sv(baseex);
2785 return (OP *)NULL;
2786 }
2787 #endif
2788 #endif
2789 #ifndef warn_sv
2790 #if (PERL_BCDVERSION >= 0x5004000)
2791 #define warn_sv(sv) warn("%" SVf, SVfARG(sv))
2792 #else
2793 #define warn_sv(sv) warn("%s", SvPV_nolen(sv))
2794 #endif
2795 #endif
2796 #if ! defined vmess && (PERL_BCDVERSION >= 0x5004000)
2797 #if defined(NEED_vmess)
2798 static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args);
2799 static
2800 #else
2801 extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args);
2802 #endif
2803 #if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL)
2804 #ifdef vmess
2805 #undef vmess
2806 #endif
2807 #define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b)
2808 #define Perl_vmess DPPP_(my_vmess)
2809 SV*
DPPP_(my_vmess)2810 DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args)
2811 {
2812 mess(pat, args);
2813 return PL_mess_sv;
2814 }
2815 #endif
2816 #endif
2817 #if (PERL_BCDVERSION < 0x5006000) && (PERL_BCDVERSION >= 0x5004000)
2818 #undef mess
2819 #endif
2820 #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && (PERL_BCDVERSION >= 0x5004000)
2821 #if defined(NEED_mess_nocontext)
2822 static SV * DPPP_(my_mess_nocontext)(const char * pat, ...);
2823 static
2824 #else
2825 extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...);
2826 #endif
2827 #if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL)
2828 #define mess_nocontext DPPP_(my_mess_nocontext)
2829 #define Perl_mess_nocontext DPPP_(my_mess_nocontext)
2830 SV*
DPPP_(my_mess_nocontext)2831 DPPP_(my_mess_nocontext)(const char* pat, ...)
2832 {
2833 dTHX;
2834 SV *sv;
2835 va_list args;
2836 va_start(args, pat);
2837 sv = vmess(pat, &args);
2838 va_end(args);
2839 return sv;
2840 }
2841 #endif
2842 #endif
2843 #ifndef mess
2844 #if defined(NEED_mess)
2845 static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
2846 static
2847 #else
2848 extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...);
2849 #endif
2850 #if defined(NEED_mess) || defined(NEED_mess_GLOBAL)
2851 #define Perl_mess DPPP_(my_mess)
2852 SV*
DPPP_(my_mess)2853 DPPP_(my_mess)(pTHX_ const char* pat, ...)
2854 {
2855 SV *sv;
2856 va_list args;
2857 va_start(args, pat);
2858 sv = vmess(pat, &args);
2859 va_end(args);
2860 return sv;
2861 }
2862 #ifdef mess_nocontext
2863 #define mess mess_nocontext
2864 #else
2865 #define mess Perl_mess_nocontext
2866 #endif
2867 #endif
2868 #endif
2869 #if ! defined mess_sv && (PERL_BCDVERSION >= 0x5004000)
2870 #if defined(NEED_mess_sv)
2871 static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume);
2872 static
2873 #else
2874 extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume);
2875 #endif
2876 #if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL)
2877 #ifdef mess_sv
2878 #undef mess_sv
2879 #endif
2880 #define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b)
2881 #define Perl_mess_sv DPPP_(my_mess_sv)
2882 SV *
DPPP_(my_mess_sv)2883 DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume)
2884 {
2885 SV *tmp;
2886 SV *ret;
2887 if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') {
2888 if (consume)
2889 return basemsg;
2890 ret = mess("");
2891 SvSetSV_nosteal(ret, basemsg);
2892 return ret;
2893 }
2894 if (consume) {
2895 sv_catsv(basemsg, mess(""));
2896 return basemsg;
2897 }
2898 ret = mess("");
2899 tmp = newSVsv(ret);
2900 SvSetSV_nosteal(ret, basemsg);
2901 sv_catsv(ret, tmp);
2902 sv_dec(tmp);
2903 return ret;
2904 }
2905 #endif
2906 #endif
2907 #ifndef warn_nocontext
2908 #define warn_nocontext warn
2909 #endif
2910 #ifndef croak_nocontext
2911 #define croak_nocontext croak
2912 #endif
2913 #ifndef croak_no_modify
2914 #define croak_no_modify() croak_nocontext("%s", PL_no_modify)
2915 #define Perl_croak_no_modify() croak_no_modify()
2916 #endif
2917 #ifndef croak_memory_wrap
2918 #if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) )
2919 #define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap)
2920 #else
2921 #define croak_memory_wrap() croak_nocontext("panic: memory wrap")
2922 #endif
2923 #endif
2924 #ifndef croak_xs_usage
2925 #if defined(NEED_croak_xs_usage)
2926 static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params);
2927 static
2928 #else
2929 extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params);
2930 #endif
2931 #if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL)
2932 #define croak_xs_usage DPPP_(my_croak_xs_usage)
2933 #define Perl_croak_xs_usage DPPP_(my_croak_xs_usage)
2934 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
2935 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
2936 void
DPPP_(my_croak_xs_usage)2937 DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params)
2938 {
2939 dTHX;
2940 const GV *const gv = CvGV(cv);
2941 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
2942 if (gv) {
2943 const char *const gvname = GvNAME(gv);
2944 const HV *const stash = GvSTASH(gv);
2945 const char *const hvname = stash ? HvNAME(stash) : NULL;
2946 if (hvname)
2947 croak("Usage: %s::%s(%s)", hvname, gvname, params);
2948 else
2949 croak("Usage: %s(%s)", gvname, params);
2950 } else {
2951 croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
2952 }
2953 }
2954 #endif
2955 #endif
2956 #endif
2957 #ifndef mPUSHs
2958 #define mPUSHs(s) PUSHs(sv_2mortal(s))
2959 #endif
2960 #ifndef PUSHmortal
2961 #define PUSHmortal PUSHs(sv_newmortal())
2962 #endif
2963 #ifndef mPUSHp
2964 #define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l))
2965 #endif
2966 #ifndef mPUSHn
2967 #define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n))
2968 #endif
2969 #ifndef mPUSHi
2970 #define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i))
2971 #endif
2972 #ifndef mPUSHu
2973 #define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u))
2974 #endif
2975 #ifndef mXPUSHs
2976 #define mXPUSHs(s) XPUSHs(sv_2mortal(s))
2977 #endif
2978 #ifndef XPUSHmortal
2979 #define XPUSHmortal XPUSHs(sv_newmortal())
2980 #endif
2981 #ifndef mXPUSHp
2982 #define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END
2983 #endif
2984 #ifndef mXPUSHn
2985 #define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END
2986 #endif
2987 #ifndef mXPUSHi
2988 #define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END
2989 #endif
2990 #ifndef mXPUSHu
2991 #define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END
2992 #endif
2993 #ifndef call_sv
2994 #define call_sv perl_call_sv
2995 #endif
2996 #ifndef call_pv
2997 #define call_pv perl_call_pv
2998 #endif
2999 #ifndef call_argv
3000 #define call_argv perl_call_argv
3001 #endif
3002 #ifndef call_method
3003 #define call_method perl_call_method
3004 #endif
3005 #ifndef eval_sv
3006 #define eval_sv perl_eval_sv
3007 #endif
3008 #if (PERL_BCDVERSION >= 0x5003098) && (PERL_BCDVERSION < 0x5006000)
3009 #ifndef eval_pv
3010 #define eval_pv perl_eval_pv
3011 #endif
3012 #endif
3013 #if (PERL_BCDVERSION < 0x5006000)
3014 #ifndef Perl_eval_sv
3015 #define Perl_eval_sv perl_eval_sv
3016 #endif
3017 #if (PERL_BCDVERSION >= 0x5003098)
3018 #ifndef Perl_eval_pv
3019 #define Perl_eval_pv perl_eval_pv
3020 #endif
3021 #endif
3022 #endif
3023 #ifndef PERL_LOADMOD_DENY
3024 #define PERL_LOADMOD_DENY 0x1
3025 #endif
3026 #ifndef PERL_LOADMOD_NOIMPORT
3027 #define PERL_LOADMOD_NOIMPORT 0x2
3028 #endif
3029 #ifndef PERL_LOADMOD_IMPORT_OPS
3030 #define PERL_LOADMOD_IMPORT_OPS 0x4
3031 #endif
3032 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3033 #define D_PPP_CROAK_IF_ERROR(cond) ({ SV *_errsv; ((cond) && (_errsv = ERRSV) && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); })
3034 #else
3035 #define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1))
3036 #endif
3037 #ifndef G_METHOD
3038 #define G_METHOD 64
3039 #ifdef call_sv
3040 #undef call_sv
3041 #endif
3042 #if (PERL_BCDVERSION < 0x5006000)
3043 #define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \
3044 (flags) & ~G_METHOD) : perl_call_sv(sv, flags))
3045 #else
3046 #define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
3047 (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
3048 #endif
3049 #endif
3050 #ifndef G_RETHROW
3051 #define G_RETHROW 8192
3052 #ifdef eval_sv
3053 #undef eval_sv
3054 #endif
3055 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3056 #define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; })
3057 #else
3058 #define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na)
3059 #endif
3060 #endif
3061 #if (PERL_BCDVERSION < 0x5031002)
3062 #ifdef eval_pv
3063 #undef eval_pv
3064 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3065 #define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; })
3066 #else
3067 #define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv)
3068 #endif
3069 #endif
3070 #endif
3071 #ifndef eval_pv
3072 #if defined(NEED_eval_pv)
3073 static SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error);
3074 static
3075 #else
3076 extern SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error);
3077 #endif
3078 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
3079 #ifdef eval_pv
3080 #undef eval_pv
3081 #endif
3082 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
3083 #define Perl_eval_pv DPPP_(my_eval_pv)
3084 SV*
DPPP_(my_eval_pv)3085 DPPP_(my_eval_pv)(const char *p, I32 croak_on_error)
3086 {
3087 dSP;
3088 SV* sv = newSVpv(p, 0);
3089 PUSHMARK(sp);
3090 eval_sv(sv, G_SCALAR);
3091 SvREFCNT_dec(sv);
3092 SPAGAIN;
3093 sv = POPs;
3094 PUTBACK;
3095 D_PPP_CROAK_IF_ERROR(croak_on_error);
3096 return sv;
3097 }
3098 #endif
3099 #endif
3100 #if ! defined(vload_module) && defined(start_subparse)
3101 #if defined(NEED_vload_module)
3102 static void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
3103 static
3104 #else
3105 extern void DPPP_(my_vload_module)(U32 flags, SV * name, SV * ver, va_list * args);
3106 #endif
3107 #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL)
3108 #ifdef vload_module
3109 #undef vload_module
3110 #endif
3111 #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d)
3112 #define Perl_vload_module DPPP_(my_vload_module)
3113 void
DPPP_(my_vload_module)3114 DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args)
3115 {
3116 dTHR;
3117 dVAR;
3118 OP *veop, *imop;
3119 OP * const modname = newSVOP(OP_CONST, 0, name);
3120 SvREADONLY_off(((SVOP*)modname)->op_sv);
3121 modname->op_private |= OPpCONST_BARE;
3122 if (ver) {
3123 veop = newSVOP(OP_CONST, 0, ver);
3124 }
3125 else
3126 veop = NULL;
3127 if (flags & PERL_LOADMOD_NOIMPORT) {
3128 imop = sawparens(newNULLLIST());
3129 }
3130 else if (flags & PERL_LOADMOD_IMPORT_OPS) {
3131 imop = va_arg(*args, OP*);
3132 }
3133 else {
3134 SV *sv;
3135 imop = NULL;
3136 sv = va_arg(*args, SV*);
3137 while (sv) {
3138 imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
3139 sv = va_arg(*args, SV*);
3140 }
3141 }
3142 {
3143 const line_t ocopline = PL_copline;
3144 COP * const ocurcop = PL_curcop;
3145 const int oexpect = PL_expect;
3146 utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
3147 #if (PERL_BCDVERSION > 0x5003000)
3148 veop,
3149 #endif
3150 modname, imop);
3151 PL_expect = oexpect;
3152 PL_copline = ocopline;
3153 PL_curcop = ocurcop;
3154 }
3155 }
3156 #endif
3157 #endif
3158 #ifndef load_module
3159 #if defined(NEED_load_module)
3160 static void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
3161 static
3162 #else
3163 extern void DPPP_(my_load_module)(U32 flags, SV * name, SV * ver, ...);
3164 #endif
3165 #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL)
3166 #ifdef load_module
3167 #undef load_module
3168 #endif
3169 #define load_module DPPP_(my_load_module)
3170 #define Perl_load_module DPPP_(my_load_module)
3171 void
DPPP_(my_load_module)3172 DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...)
3173 {
3174 va_list args;
3175 va_start(args, ver);
3176 vload_module(flags, name, ver, &args);
3177 va_end(args);
3178 }
3179 #endif
3180 #endif
3181 #ifndef newRV_inc
3182 #define newRV_inc(sv) newRV(sv)
3183 #endif
3184 #ifndef newRV_noinc
3185 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3186 #define newRV_noinc(sv) ({ SV *_sv = (SV *)newRV((sv)); SvREFCNT_dec((sv)); _sv; })
3187 #else
3188 #define newRV_noinc(sv) ((PL_Sv = (SV *)newRV((sv))), SvREFCNT_dec((sv)), PL_Sv)
3189 #endif
3190 #endif
3191 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
3192 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
3193 #ifndef START_MY_CXT
3194 #define START_MY_CXT
3195 #if (PERL_BCDVERSION < 0x5004068)
3196 #define dMY_CXT_SV \
3197 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
3198 #else
3199 #define dMY_CXT_SV \
3200 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
3201 sizeof(MY_CXT_KEY)-1, TRUE)
3202 #endif
3203 #define dMY_CXT \
3204 dMY_CXT_SV; \
3205 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
3206 #define MY_CXT_INIT \
3207 dMY_CXT_SV; \
3208 \
3209 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
3210 Zero(my_cxtp, 1, my_cxt_t); \
3211 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
3212 #define MY_CXT (*my_cxtp)
3213 #define pMY_CXT my_cxt_t *my_cxtp
3214 #define pMY_CXT_ pMY_CXT,
3215 #define _pMY_CXT ,pMY_CXT
3216 #define aMY_CXT my_cxtp
3217 #define aMY_CXT_ aMY_CXT,
3218 #define _aMY_CXT ,aMY_CXT
3219 #endif
3220 #ifndef MY_CXT_CLONE
3221 #define MY_CXT_CLONE \
3222 dMY_CXT_SV; \
3223 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
3224 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
3225 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
3226 #endif
3227 #else
3228 #ifndef START_MY_CXT
3229 #define START_MY_CXT static my_cxt_t my_cxt;
3230 #define dMY_CXT_SV dNOOP
3231 #define dMY_CXT dNOOP
3232 #define MY_CXT_INIT NOOP
3233 #define MY_CXT my_cxt
3234 #define pMY_CXT void
3235 #define pMY_CXT_
3236 #define _pMY_CXT
3237 #define aMY_CXT
3238 #define aMY_CXT_
3239 #define _aMY_CXT
3240 #endif
3241 #ifndef MY_CXT_CLONE
3242 #define MY_CXT_CLONE NOOP
3243 #endif
3244 #endif
3245 #ifndef SvREFCNT_inc
3246 #ifdef PERL_USE_GCC_BRACE_GROUPS
3247 #define SvREFCNT_inc(sv) \
3248 ({ \
3249 SV * const _sv = (SV*)(sv); \
3250 if (_sv) \
3251 (SvREFCNT(_sv))++; \
3252 _sv; \
3253 })
3254 #else
3255 #define SvREFCNT_inc(sv) \
3256 ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
3257 #endif
3258 #endif
3259 #ifndef SvREFCNT_inc_simple
3260 #ifdef PERL_USE_GCC_BRACE_GROUPS
3261 #define SvREFCNT_inc_simple(sv) \
3262 ({ \
3263 if (sv) \
3264 (SvREFCNT(sv))++; \
3265 (SV *)(sv); \
3266 })
3267 #else
3268 #define SvREFCNT_inc_simple(sv) \
3269 ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL)
3270 #endif
3271 #endif
3272 #ifndef SvREFCNT_inc_NN
3273 #ifdef PERL_USE_GCC_BRACE_GROUPS
3274 #define SvREFCNT_inc_NN(sv) \
3275 ({ \
3276 SV * const _sv = (SV*)(sv); \
3277 SvREFCNT(_sv)++; \
3278 _sv; \
3279 })
3280 #else
3281 #define SvREFCNT_inc_NN(sv) \
3282 (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv)
3283 #endif
3284 #endif
3285 #ifndef SvREFCNT_inc_void
3286 #ifdef PERL_USE_GCC_BRACE_GROUPS
3287 #define SvREFCNT_inc_void(sv) \
3288 ({ \
3289 SV * const _sv = (SV*)(sv); \
3290 if (_sv) \
3291 (void)(SvREFCNT(_sv)++); \
3292 })
3293 #else
3294 #define SvREFCNT_inc_void(sv) \
3295 (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0)
3296 #endif
3297 #endif
3298 #ifndef SvREFCNT_inc_simple_void
3299 #define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END
3300 #endif
3301 #ifndef SvREFCNT_inc_simple_NN
3302 #define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv))
3303 #endif
3304 #ifndef SvREFCNT_inc_void_NN
3305 #define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
3306 #endif
3307 #ifndef SvREFCNT_inc_simple_void_NN
3308 #define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv)))
3309 #endif
3310 #ifndef newSV_type
3311 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3312 #define newSV_type(t) ({ SV *_sv = newSV(0); sv_upgrade(_sv, (t)); _sv; })
3313 #else
3314 #define newSV_type(t) ((PL_Sv = newSV(0)), sv_upgrade(PL_Sv, (t)), PL_Sv)
3315 #endif
3316 #endif
3317 #if (PERL_BCDVERSION < 0x5006000)
3318 #define D_PPP_CONSTPV_ARG(x) ((char *) (x))
3319 #else
3320 #define D_PPP_CONSTPV_ARG(x) (x)
3321 #endif
3322 #ifndef newSVpvn
3323 #define newSVpvn(data,len) ((data) \
3324 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
3325 : newSV(0))
3326 #endif
3327 #ifndef newSVpvn_utf8
3328 #define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0)
3329 #endif
3330 #ifndef SVf_UTF8
3331 #define SVf_UTF8 0
3332 #endif
3333 #ifndef newSVpvn_flags
3334 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3335 #define newSVpvn_flags(s, len, flags) ({ SV *_sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len)); SvFLAGS(_sv) |= ((flags) & SVf_UTF8); ((flags) & SVs_TEMP) ? sv_2mortal(_sv) : _sv; })
3336 #else
3337 #define newSVpvn_flags(s, len, flags) ((PL_Sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len))), SvFLAGS(PL_Sv) |= ((flags) & SVf_UTF8), (((flags) & SVs_TEMP) ? sv_2mortal(PL_Sv) : PL_Sv))
3338 #endif
3339 #endif
3340 #ifndef SV_NOSTEAL
3341 #define SV_NOSTEAL 16
3342 #endif
3343 #if ( (PERL_BCDVERSION >= 0x5007003) && (PERL_BCDVERSION < 0x5008007) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009002) )
3344 #undef sv_setsv_flags
3345 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3346 #define sv_setsv_flags(dstr, sstr, flags) \
3347 STMT_START { \
3348 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \
3349 SvTEMP_off((SV *)(sstr)); \
3350 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \
3351 SvTEMP_on((SV *)(sstr)); \
3352 } else { \
3353 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \
3354 } \
3355 } STMT_END
3356 #else
3357 ( \
3358 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \
3359 SvTEMP_off((SV *)(sstr)), \
3360 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \
3361 SvTEMP_on((SV *)(sstr)), \
3362 1 \
3363 ) : ( \
3364 Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL), \
3365 1 \
3366 ) \
3367 )
3368 #endif
3369 #endif
3370 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3371 #ifndef sv_setsv_flags
3372 #define sv_setsv_flags(dstr, sstr, flags) \
3373 STMT_START { \
3374 if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \
3375 SvTEMP_off((SV *)(sstr)); \
3376 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \
3377 SvGMAGICAL_off((SV *)(sstr)); \
3378 sv_setsv((dstr), (sstr)); \
3379 SvGMAGICAL_on((SV *)(sstr)); \
3380 } else { \
3381 sv_setsv((dstr), (sstr)); \
3382 } \
3383 SvTEMP_on((SV *)(sstr)); \
3384 } else { \
3385 if (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) { \
3386 SvGMAGICAL_off((SV *)(sstr)); \
3387 sv_setsv((dstr), (sstr)); \
3388 SvGMAGICAL_on((SV *)(sstr)); \
3389 } else { \
3390 sv_setsv((dstr), (sstr)); \
3391 } \
3392 } \
3393 } STMT_END
3394 #endif
3395 #else
3396 #ifndef sv_setsv_flags
3397 #define sv_setsv_flags(dstr, sstr, flags) \
3398 ( \
3399 (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) ? ( \
3400 SvTEMP_off((SV *)(sstr)), \
3401 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \
3402 SvGMAGICAL_off((SV *)(sstr)), \
3403 sv_setsv((dstr), (sstr)), \
3404 SvGMAGICAL_on((SV *)(sstr)), \
3405 1 \
3406 ) : ( \
3407 sv_setsv((dstr), (sstr)), \
3408 1 \
3409 ), \
3410 SvTEMP_on((SV *)(sstr)), \
3411 1 \
3412 ) : ( \
3413 (!((flags) & SV_GMAGIC) && (sstr) && SvGMAGICAL((SV *)(sstr))) ? ( \
3414 SvGMAGICAL_off((SV *)(sstr)), \
3415 sv_setsv((dstr), (sstr)), \
3416 SvGMAGICAL_on((SV *)(sstr)), \
3417 1 \
3418 ) : ( \
3419 sv_setsv((dstr), (sstr)), \
3420 1 \
3421 ) \
3422 ) \
3423 )
3424 #endif
3425 #endif
3426 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3427 #ifndef newSVsv_flags
3428 #define newSVsv_flags(sv, flags) ({ SV *_sv = newSV(0); sv_setsv_flags(_sv, (sv), (flags)); _sv; })
3429 #endif
3430 #else
3431 #ifndef newSVsv_flags
3432 #define newSVsv_flags(sv, flags) ((PL_Sv = newSV(0)), sv_setsv_flags(PL_Sv, (sv), (flags)), PL_Sv)
3433 #endif
3434 #endif
3435 #ifndef newSVsv_nomg
3436 #define newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL)
3437 #endif
3438 #if (PERL_BCDVERSION >= 0x5017005)
3439 #ifndef sv_mortalcopy_flags
3440 #define sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags))
3441 #endif
3442 #else
3443 #ifndef sv_mortalcopy_flags
3444 #define sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags)))
3445 #endif
3446 #endif
3447 #ifndef SvMAGIC_set
3448 #define SvMAGIC_set(sv, val) \
3449 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
3450 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
3451 #endif
3452 #if (PERL_BCDVERSION < 0x5009003)
3453 #ifndef SvPVX_const
3454 #define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
3455 #endif
3456 #ifndef SvPVX_mutable
3457 #define SvPVX_mutable(sv) (0 + SvPVX(sv))
3458 #endif
3459 #ifndef SvRV_set
3460 #define SvRV_set(sv, val) \
3461 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
3462 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
3463 #endif
3464 #else
3465 #ifndef SvPVX_const
3466 #define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
3467 #endif
3468 #ifndef SvPVX_mutable
3469 #define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
3470 #endif
3471 #ifndef SvRV_set
3472 #define SvRV_set(sv, val) \
3473 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
3474 ((sv)->sv_u.svu_rv = (val)); } STMT_END
3475 #endif
3476 #endif
3477 #ifndef SvSTASH_set
3478 #define SvSTASH_set(sv, val) \
3479 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
3480 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
3481 #endif
3482 #if (PERL_BCDVERSION < 0x5004000)
3483 #ifndef SvUV_set
3484 #define SvUV_set(sv, val) \
3485 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
3486 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
3487 #endif
3488 #else
3489 #ifndef SvUV_set
3490 #define SvUV_set(sv, val) \
3491 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
3492 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
3493 #endif
3494 #endif
3495 #ifndef newSVpvn_share
3496 #if defined(NEED_newSVpvn_share)
3497 static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash);
3498 static
3499 #else
3500 extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash);
3501 #endif
3502 #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL)
3503 #ifdef newSVpvn_share
3504 #undef newSVpvn_share
3505 #endif
3506 #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c)
3507 #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share)
3508 SV *
DPPP_(my_newSVpvn_share)3509 DPPP_(my_newSVpvn_share)(pTHX_ const char *s, I32 len, U32 hash)
3510 {
3511 SV *sv;
3512 if (len < 0)
3513 len = -len;
3514 if (!hash)
3515 PERL_HASH(hash, (char*) s, len);
3516 sv = newSVpvn((char *) s, len);
3517 sv_upgrade(sv, SVt_PVIV);
3518 SvIVX(sv) = hash;
3519 SvREADONLY_on(sv);
3520 SvPOK_on(sv);
3521 return sv;
3522 }
3523 #endif
3524 #endif
3525 #ifndef SvSHARED_HASH
3526 #define SvSHARED_HASH(sv) (0 + SvUVX(sv))
3527 #endif
3528 #ifndef HvNAME_get
3529 #define HvNAME_get(hv) HvNAME(hv)
3530 #endif
3531 #ifndef HvNAMELEN_get
3532 #define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0)
3533 #endif
3534 #if (PERL_BCDVERSION >= 0x5009002) && (PERL_BCDVERSION <= 0x5009003)
3535 #undef gv_fetchpvn_flags
3536 #endif
3537 #ifdef GV_NOADD_MASK
3538 #define D_PPP_GV_NOADD_MASK GV_NOADD_MASK
3539 #else
3540 #define D_PPP_GV_NOADD_MASK 0xE0
3541 #endif
3542 #ifndef gv_fetchpvn_flags
3543 #define gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & D_PPP_GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type))
3544 #endif
3545 #ifndef GvSVn
3546 #define GvSVn(gv) GvSV(gv)
3547 #endif
3548 #ifndef isGV_with_GP
3549 #define isGV_with_GP(gv) isGV(gv)
3550 #endif
3551 #ifndef gv_fetchsv
3552 #define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt)
3553 #endif
3554 #ifndef get_cvn_flags
3555 #define get_cvn_flags(name, namelen, flags) get_cv(name, flags)
3556 #endif
3557 #ifndef gv_init_pvn
3558 #define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE)
3559 #endif
3560 #ifndef STR_WITH_LEN
3561 #define STR_WITH_LEN(s) (s ""), (sizeof(s)-1)
3562 #endif
3563 #ifndef newSVpvs
3564 #define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1)
3565 #endif
3566 #ifndef newSVpvs_flags
3567 #define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags)
3568 #endif
3569 #ifndef newSVpvs_share
3570 #define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0)
3571 #endif
3572 #ifndef sv_catpvs
3573 #define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1)
3574 #endif
3575 #ifndef sv_setpvs
3576 #define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1)
3577 #endif
3578 #ifndef hv_fetchs
3579 #define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval)
3580 #endif
3581 #ifndef hv_stores
3582 #define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0)
3583 #endif
3584 #ifndef gv_fetchpvs
3585 #define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt)
3586 #endif
3587 #ifndef gv_stashpvs
3588 #define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags)
3589 #endif
3590 #ifndef get_cvs
3591 #define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags)
3592 #endif
3593 #ifndef SvGETMAGIC
3594 #define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
3595 #endif
3596 #ifndef sv_catpvn_nomg
3597 #define sv_catpvn_nomg sv_catpvn
3598 #endif
3599 #ifndef sv_catsv_nomg
3600 #define sv_catsv_nomg sv_catsv
3601 #endif
3602 #ifndef sv_setsv_nomg
3603 #define sv_setsv_nomg sv_setsv
3604 #endif
3605 #ifndef sv_pvn_nomg
3606 #define sv_pvn_nomg sv_pvn
3607 #endif
3608 #ifdef SVf_IVisUV
3609 #if defined(PERL_USE_GCC_BRACE_GROUPS)
3610 #ifndef SvIV_nomg
3611 #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ({ SV *_sviv = sv_mortalcopy_flags((sv), SV_NOSTEAL); IV _iv = SvIV(_sviv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_sviv) & SVf_IVisUV); _iv; }))
3612 #endif
3613 #ifndef SvUV_nomg
3614 #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : ({ SV *_svuv = sv_mortalcopy_flags((sv), SV_NOSTEAL); UV _uv = SvUV(_svuv); SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(_svuv) & SVf_IVisUV); _uv; }))
3615 #endif
3616 #else
3617 #ifndef SvIV_nomg
3618 #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvIVX(PL_Sv) = SvIV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvIVX(PL_Sv)))
3619 #endif
3620 #ifndef SvUV_nomg
3621 #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : ((PL_Sv = sv_mortalcopy_flags((sv), SV_NOSTEAL)), sv_upgrade(PL_Sv, SVt_PVIV), (SvUVX(PL_Sv) = SvUV(PL_Sv)), (SvFLAGS((sv)) = (SvFLAGS((sv)) & ~SVf_IVisUV) | (SvFLAGS(PL_Sv) & SVf_IVisUV)), SvUVX(PL_Sv)))
3622 #endif
3623 #endif
3624 #else
3625 #ifndef SvIV_nomg
3626 #define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
3627 #endif
3628 #ifndef SvUV_nomg
3629 #define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
3630 #endif
3631 #endif
3632 #ifndef SvNV_nomg
3633 #define SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
3634 #endif
3635 #ifndef SvTRUE_nomg
3636 #define SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL)))
3637 #endif
3638 #ifndef sv_catpv_mg
3639 #define sv_catpv_mg(sv, ptr) \
3640 STMT_START { \
3641 SV *TeMpSv = sv; \
3642 sv_catpv(TeMpSv,ptr); \
3643 SvSETMAGIC(TeMpSv); \
3644 } STMT_END
3645 #endif
3646 #ifndef sv_catpvn_mg
3647 #define sv_catpvn_mg(sv, ptr, len) \
3648 STMT_START { \
3649 SV *TeMpSv = sv; \
3650 sv_catpvn(TeMpSv,ptr,len); \
3651 SvSETMAGIC(TeMpSv); \
3652 } STMT_END
3653 #endif
3654 #ifndef sv_catsv_mg
3655 #define sv_catsv_mg(dsv, ssv) \
3656 STMT_START { \
3657 SV *TeMpSv = dsv; \
3658 sv_catsv(TeMpSv,ssv); \
3659 SvSETMAGIC(TeMpSv); \
3660 } STMT_END
3661 #endif
3662 #ifndef sv_setiv_mg
3663 #define sv_setiv_mg(sv, i) \
3664 STMT_START { \
3665 SV *TeMpSv = sv; \
3666 sv_setiv(TeMpSv,i); \
3667 SvSETMAGIC(TeMpSv); \
3668 } STMT_END
3669 #endif
3670 #ifndef sv_setnv_mg
3671 #define sv_setnv_mg(sv, num) \
3672 STMT_START { \
3673 SV *TeMpSv = sv; \
3674 sv_setnv(TeMpSv,num); \
3675 SvSETMAGIC(TeMpSv); \
3676 } STMT_END
3677 #endif
3678 #ifndef sv_setpv_mg
3679 #define sv_setpv_mg(sv, ptr) \
3680 STMT_START { \
3681 SV *TeMpSv = sv; \
3682 sv_setpv(TeMpSv,ptr); \
3683 SvSETMAGIC(TeMpSv); \
3684 } STMT_END
3685 #endif
3686 #ifndef sv_setpvn_mg
3687 #define sv_setpvn_mg(sv, ptr, len) \
3688 STMT_START { \
3689 SV *TeMpSv = sv; \
3690 sv_setpvn(TeMpSv,ptr,len); \
3691 SvSETMAGIC(TeMpSv); \
3692 } STMT_END
3693 #endif
3694 #ifndef sv_setsv_mg
3695 #define sv_setsv_mg(dsv, ssv) \
3696 STMT_START { \
3697 SV *TeMpSv = dsv; \
3698 sv_setsv(TeMpSv,ssv); \
3699 SvSETMAGIC(TeMpSv); \
3700 } STMT_END
3701 #endif
3702 #ifndef sv_setuv_mg
3703 #define sv_setuv_mg(sv, i) \
3704 STMT_START { \
3705 SV *TeMpSv = sv; \
3706 sv_setuv(TeMpSv,i); \
3707 SvSETMAGIC(TeMpSv); \
3708 } STMT_END
3709 #endif
3710 #ifndef sv_usepvn_mg
3711 #define sv_usepvn_mg(sv, ptr, len) \
3712 STMT_START { \
3713 SV *TeMpSv = sv; \
3714 sv_usepvn(TeMpSv,ptr,len); \
3715 SvSETMAGIC(TeMpSv); \
3716 } STMT_END
3717 #endif
3718 #ifndef SvVSTRING_mg
3719 #define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL)
3720 #endif
3721 #if (PERL_BCDVERSION < 0x5004000)
3722 #elif (PERL_BCDVERSION < 0x5008000)
3723 #define sv_magic_portable(sv, obj, how, name, namlen) \
3724 STMT_START { \
3725 SV *SvMp_sv = (sv); \
3726 char *SvMp_name = (char *) (name); \
3727 I32 SvMp_namlen = (namlen); \
3728 if (SvMp_name && SvMp_namlen == 0) \
3729 { \
3730 MAGIC *mg; \
3731 sv_magic(SvMp_sv, obj, how, 0, 0); \
3732 mg = SvMAGIC(SvMp_sv); \
3733 mg->mg_len = -42; \
3734 mg->mg_ptr = SvMp_name; \
3735 } \
3736 else \
3737 { \
3738 sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \
3739 } \
3740 } STMT_END
3741 #else
3742 #define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e)
3743 #endif
3744 #if !defined(mg_findext)
3745 #if defined(NEED_mg_findext)
3746 static MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl);
3747 static
3748 #else
3749 extern MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl);
3750 #endif
3751 #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL)
3752 #define mg_findext DPPP_(my_mg_findext)
3753 #define Perl_mg_findext DPPP_(my_mg_findext)
3754 MAGIC *
DPPP_(my_mg_findext)3755 DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL *vtbl) {
3756 if (sv) {
3757 MAGIC *mg;
3758 #ifdef AvPAD_NAMELIST
3759 assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
3760 #endif
3761 for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) {
3762 if (mg->mg_type == type && mg->mg_virtual == vtbl)
3763 return mg;
3764 }
3765 }
3766 return NULL;
3767 }
3768 #endif
3769 #endif
3770 #if !defined(sv_unmagicext)
3771 #if defined(NEED_sv_unmagicext)
3772 static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
3773 static
3774 #else
3775 extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl);
3776 #endif
3777 #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL)
3778 #ifdef sv_unmagicext
3779 #undef sv_unmagicext
3780 #endif
3781 #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c)
3782 #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext)
3783 int
DPPP_(my_sv_unmagicext)3784 DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl)
3785 {
3786 MAGIC* mg;
3787 MAGIC** mgp;
3788 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3789 return 0;
3790 mgp = &(SvMAGIC(sv));
3791 for (mg = *mgp; mg; mg = *mgp) {
3792 const MGVTBL* const virt = mg->mg_virtual;
3793 if (mg->mg_type == type && virt == vtbl) {
3794 *mgp = mg->mg_moremagic;
3795 if (virt && virt->svt_free)
3796 virt->svt_free(aTHX_ sv, mg);
3797 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
3798 if (mg->mg_len > 0)
3799 Safefree(mg->mg_ptr);
3800 else if (mg->mg_len == HEf_SVKEY)
3801 SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
3802 else if (mg->mg_type == PERL_MAGIC_utf8)
3803 Safefree(mg->mg_ptr);
3804 }
3805 if (mg->mg_flags & MGf_REFCOUNTED)
3806 SvREFCNT_dec(mg->mg_obj);
3807 Safefree(mg);
3808 }
3809 else
3810 mgp = &mg->mg_moremagic;
3811 }
3812 if (SvMAGIC(sv)) {
3813 if (SvMAGICAL(sv))
3814 mg_magical(sv);
3815 }
3816 else {
3817 SvMAGICAL_off(sv);
3818 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3819 }
3820 return 0;
3821 }
3822 #endif
3823 #endif
3824 #ifdef USE_ITHREADS
3825 #ifndef CopFILE
3826 #define CopFILE(c) ((c)->cop_file)
3827 #endif
3828 #ifndef CopFILEGV
3829 #define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
3830 #endif
3831 #ifndef CopFILE_set
3832 #define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
3833 #endif
3834 #ifndef CopFILESV
3835 #define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
3836 #endif
3837 #ifndef CopFILEAV
3838 #define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
3839 #endif
3840 #ifndef CopSTASHPV
3841 #define CopSTASHPV(c) ((c)->cop_stashpv)
3842 #endif
3843 #ifndef CopSTASHPV_set
3844 #define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
3845 #endif
3846 #ifndef CopSTASH
3847 #define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
3848 #endif
3849 #ifndef CopSTASH_set
3850 #define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
3851 #endif
3852 #ifndef CopSTASH_eq
3853 #define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
3854 || (CopSTASHPV(c) && HvNAME(hv) \
3855 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
3856 #endif
3857 #else
3858 #ifndef CopFILEGV
3859 #define CopFILEGV(c) ((c)->cop_filegv)
3860 #endif
3861 #ifndef CopFILEGV_set
3862 #define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
3863 #endif
3864 #ifndef CopFILE_set
3865 #define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
3866 #endif
3867 #ifndef CopFILESV
3868 #define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
3869 #endif
3870 #ifndef CopFILEAV
3871 #define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
3872 #endif
3873 #ifndef CopFILE
3874 #define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
3875 #endif
3876 #ifndef CopSTASH
3877 #define CopSTASH(c) ((c)->cop_stash)
3878 #endif
3879 #ifndef CopSTASH_set
3880 #define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
3881 #endif
3882 #ifndef CopSTASHPV
3883 #define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
3884 #endif
3885 #ifndef CopSTASHPV_set
3886 #define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
3887 #endif
3888 #ifndef CopSTASH_eq
3889 #define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
3890 #endif
3891 #endif
3892 #if (PERL_BCDVERSION >= 0x5006000)
3893 #ifndef caller_cx
3894 #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
3895 static I32
DPPP_dopoptosub_at(const PERL_CONTEXT * cxstk,I32 startingblock)3896 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock)
3897 {
3898 I32 i;
3899 for (i = startingblock; i >= 0; i--) {
3900 const PERL_CONTEXT * const cx = &cxstk[i];
3901 switch (CxTYPE(cx)) {
3902 default:
3903 continue;
3904 case CXt_EVAL:
3905 case CXt_SUB:
3906 case CXt_FORMAT:
3907 return i;
3908 }
3909 }
3910 return i;
3911 }
3912 #endif
3913 #if defined(NEED_caller_cx)
3914 static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp);
3915 static
3916 #else
3917 extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp);
3918 #endif
3919 #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL)
3920 #ifdef caller_cx
3921 #undef caller_cx
3922 #endif
3923 #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b)
3924 #define Perl_caller_cx DPPP_(my_caller_cx)
3925 const PERL_CONTEXT *
DPPP_(my_caller_cx)3926 DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT **dbcxp)
3927 {
3928 I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix);
3929 const PERL_CONTEXT *cx;
3930 const PERL_CONTEXT *ccstack = cxstack;
3931 const PERL_SI *top_si = PL_curstackinfo;
3932 for (;;) {
3933 while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
3934 top_si = top_si->si_prev;
3935 ccstack = top_si->si_cxstack;
3936 cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix);
3937 }
3938 if (cxix < 0)
3939 return NULL;
3940 if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
3941 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
3942 level++;
3943 if (!level--)
3944 break;
3945 cxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
3946 }
3947 cx = &ccstack[cxix];
3948 if (dbcxp) *dbcxp = cx;
3949 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3950 const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1);
3951 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
3952 cx = &ccstack[dbcxix];
3953 }
3954 return cx;
3955 }
3956 #endif
3957 #endif
3958 #endif
3959 #ifndef IN_PERL_COMPILETIME
3960 #define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
3961 #endif
3962 #ifndef IN_LOCALE_RUNTIME
3963 #define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
3964 #endif
3965 #ifndef IN_LOCALE_COMPILETIME
3966 #define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
3967 #endif
3968 #ifndef IN_LOCALE
3969 #define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
3970 #endif
3971 #ifndef IS_NUMBER_IN_UV
3972 #define IS_NUMBER_IN_UV 0x01
3973 #endif
3974 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
3975 #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
3976 #endif
3977 #ifndef IS_NUMBER_NOT_INT
3978 #define IS_NUMBER_NOT_INT 0x04
3979 #endif
3980 #ifndef IS_NUMBER_NEG
3981 #define IS_NUMBER_NEG 0x08
3982 #endif
3983 #ifndef IS_NUMBER_INFINITY
3984 #define IS_NUMBER_INFINITY 0x10
3985 #endif
3986 #ifndef IS_NUMBER_NAN
3987 #define IS_NUMBER_NAN 0x20
3988 #endif
3989 #ifndef GROK_NUMERIC_RADIX
3990 #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
3991 #endif
3992 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
3993 #define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
3994 #endif
3995 #ifndef PERL_SCAN_SILENT_ILLDIGIT
3996 #define PERL_SCAN_SILENT_ILLDIGIT 0x04
3997 #endif
3998 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
3999 #define PERL_SCAN_ALLOW_UNDERSCORES 0x01
4000 #endif
4001 #ifndef PERL_SCAN_DISALLOW_PREFIX
4002 #define PERL_SCAN_DISALLOW_PREFIX 0x02
4003 #endif
4004 #ifndef grok_numeric_radix
4005 #if defined(NEED_grok_numeric_radix)
4006 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char * * sp, const char * send);
4007 static
4008 #else
4009 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char * * sp, const char * send);
4010 #endif
4011 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
4012 #ifdef grok_numeric_radix
4013 #undef grok_numeric_radix
4014 #endif
4015 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
4016 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
4017 bool
DPPP_(my_grok_numeric_radix)4018 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
4019 {
4020 #ifdef USE_LOCALE_NUMERIC
4021 #ifdef PL_numeric_radix_sv
4022 if (PL_numeric_radix_sv && IN_LOCALE) {
4023 STRLEN len;
4024 char* radix = SvPV(PL_numeric_radix_sv, len);
4025 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4026 *sp += len;
4027 return TRUE;
4028 }
4029 }
4030 #else
4031 #include <locale.h>
4032 dTHR;
4033 struct lconv *lc = localeconv();
4034 char *radix = lc->decimal_point;
4035 if (radix && IN_LOCALE) {
4036 STRLEN len = strlen(radix);
4037 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4038 *sp += len;
4039 return TRUE;
4040 }
4041 }
4042 #endif
4043 #endif
4044 if (*sp < send && **sp == '.') {
4045 ++*sp;
4046 return TRUE;
4047 }
4048 return FALSE;
4049 }
4050 #endif
4051 #endif
4052 #ifndef grok_number
4053 #if defined(NEED_grok_number)
4054 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4055 static
4056 #else
4057 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4058 #endif
4059 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
4060 #ifdef grok_number
4061 #undef grok_number
4062 #endif
4063 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
4064 #define Perl_grok_number DPPP_(my_grok_number)
4065 int
DPPP_(my_grok_number)4066 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
4067 {
4068 const char *s = pv;
4069 const char *send = pv + len;
4070 const UV max_div_10 = UV_MAX / 10;
4071 const char max_mod_10 = UV_MAX % 10;
4072 int numtype = 0;
4073 int sawinf = 0;
4074 int sawnan = 0;
4075 while (s < send && isSPACE(*s))
4076 s++;
4077 if (s == send) {
4078 return 0;
4079 } else if (*s == '-') {
4080 s++;
4081 numtype = IS_NUMBER_NEG;
4082 }
4083 else if (*s == '+')
4084 s++;
4085 if (s == send)
4086 return 0;
4087 if (isDIGIT(*s)) {
4088 UV value = *s - '0';
4089 if (++s < send) {
4090 int digit = *s - '0';
4091 if (digit >= 0 && digit <= 9) {
4092 value = value * 10 + digit;
4093 if (++s < send) {
4094 digit = *s - '0';
4095 if (digit >= 0 && digit <= 9) {
4096 value = value * 10 + digit;
4097 if (++s < send) {
4098 digit = *s - '0';
4099 if (digit >= 0 && digit <= 9) {
4100 value = value * 10 + digit;
4101 if (++s < send) {
4102 digit = *s - '0';
4103 if (digit >= 0 && digit <= 9) {
4104 value = value * 10 + digit;
4105 if (++s < send) {
4106 digit = *s - '0';
4107 if (digit >= 0 && digit <= 9) {
4108 value = value * 10 + digit;
4109 if (++s < send) {
4110 digit = *s - '0';
4111 if (digit >= 0 && digit <= 9) {
4112 value = value * 10 + digit;
4113 if (++s < send) {
4114 digit = *s - '0';
4115 if (digit >= 0 && digit <= 9) {
4116 value = value * 10 + digit;
4117 if (++s < send) {
4118 digit = *s - '0';
4119 if (digit >= 0 && digit <= 9) {
4120 value = value * 10 + digit;
4121 if (++s < send) {
4122 digit = *s - '0';
4123 while (digit >= 0 && digit <= 9
4124 && (value < max_div_10
4125 || (value == max_div_10
4126 && digit <= max_mod_10))) {
4127 value = value * 10 + digit;
4128 if (++s < send)
4129 digit = *s - '0';
4130 else
4131 break;
4132 }
4133 if (digit >= 0 && digit <= 9
4134 && (s < send)) {
4135 do {
4136 s++;
4137 } while (s < send && isDIGIT(*s));
4138 numtype |=
4139 IS_NUMBER_GREATER_THAN_UV_MAX;
4140 goto skip_value;
4141 }
4142 }
4143 }
4144 }
4145 }
4146 }
4147 }
4148 }
4149 }
4150 }
4151 }
4152 }
4153 }
4154 }
4155 }
4156 }
4157 }
4158 }
4159 numtype |= IS_NUMBER_IN_UV;
4160 if (valuep)
4161 *valuep = value;
4162 skip_value:
4163 if (GROK_NUMERIC_RADIX(&s, send)) {
4164 numtype |= IS_NUMBER_NOT_INT;
4165 while (s < send && isDIGIT(*s))
4166 s++;
4167 }
4168 }
4169 else if (GROK_NUMERIC_RADIX(&s, send)) {
4170 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV;
4171 if (s < send && isDIGIT(*s)) {
4172 do {
4173 s++;
4174 } while (s < send && isDIGIT(*s));
4175 if (valuep) {
4176 *valuep = 0;
4177 }
4178 }
4179 else
4180 return 0;
4181 } else if (*s == 'I' || *s == 'i') {
4182 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4183 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
4184 s++; if (s < send && (*s == 'I' || *s == 'i')) {
4185 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4186 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
4187 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
4188 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
4189 s++;
4190 }
4191 sawinf = 1;
4192 } else if (*s == 'N' || *s == 'n') {
4193 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
4194 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4195 s++;
4196 sawnan = 1;
4197 } else
4198 return 0;
4199 if (sawinf) {
4200 numtype &= IS_NUMBER_NEG;
4201 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
4202 } else if (sawnan) {
4203 numtype &= IS_NUMBER_NEG;
4204 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
4205 } else if (s < send) {
4206 if (*s == 'e' || *s == 'E') {
4207 numtype &= IS_NUMBER_NEG;
4208 numtype |= IS_NUMBER_NOT_INT;
4209 s++;
4210 if (s < send && (*s == '-' || *s == '+'))
4211 s++;
4212 if (s < send && isDIGIT(*s)) {
4213 do {
4214 s++;
4215 } while (s < send && isDIGIT(*s));
4216 }
4217 else
4218 return 0;
4219 }
4220 }
4221 while (s < send && isSPACE(*s))
4222 s++;
4223 if (s >= send)
4224 return numtype;
4225 if (len == 10 && memEQ(pv, "0 but true", 10)) {
4226 if (valuep)
4227 *valuep = 0;
4228 return IS_NUMBER_IN_UV;
4229 }
4230 return 0;
4231 }
4232 #endif
4233 #endif
4234 #ifndef grok_bin
4235 #if defined(NEED_grok_bin)
4236 static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4237 static
4238 #else
4239 extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4240 #endif
4241 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
4242 #ifdef grok_bin
4243 #undef grok_bin
4244 #endif
4245 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
4246 #define Perl_grok_bin DPPP_(my_grok_bin)
4247 UV
DPPP_(my_grok_bin)4248 DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
4249 {
4250 const char *s = start;
4251 STRLEN len = *len_p;
4252 UV value = 0;
4253 NV value_nv = 0;
4254 const UV max_div_2 = UV_MAX / 2;
4255 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4256 bool overflowed = FALSE;
4257 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
4258 if (len >= 1) {
4259 if (s[0] == 'b') {
4260 s++;
4261 len--;
4262 }
4263 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
4264 s+=2;
4265 len-=2;
4266 }
4267 }
4268 }
4269 for (; len-- && *s; s++) {
4270 char bit = *s;
4271 if (bit == '0' || bit == '1') {
4272 redo:
4273 if (!overflowed) {
4274 if (value <= max_div_2) {
4275 value = (value << 1) | (bit - '0');
4276 continue;
4277 }
4278 warn("Integer overflow in binary number");
4279 overflowed = TRUE;
4280 value_nv = (NV) value;
4281 }
4282 value_nv *= 2.0;
4283 value_nv += (NV)(bit - '0');
4284 continue;
4285 }
4286 if (bit == '_' && len && allow_underscores && (bit = s[1])
4287 && (bit == '0' || bit == '1'))
4288 {
4289 --len;
4290 ++s;
4291 goto redo;
4292 }
4293 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4294 warn("Illegal binary digit '%c' ignored", *s);
4295 break;
4296 }
4297 if ( ( overflowed && value_nv > 4294967295.0)
4298 #if UVSIZE > 4
4299 || (!overflowed && value > 0xffffffff )
4300 #endif
4301 ) {
4302 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
4303 }
4304 *len_p = s - start;
4305 if (!overflowed) {
4306 *flags = 0;
4307 return value;
4308 }
4309 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4310 if (result)
4311 *result = value_nv;
4312 return UV_MAX;
4313 }
4314 #endif
4315 #endif
4316 #ifndef grok_hex
4317 #if defined(NEED_grok_hex)
4318 static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4319 static
4320 #else
4321 extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4322 #endif
4323 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
4324 #ifdef grok_hex
4325 #undef grok_hex
4326 #endif
4327 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
4328 #define Perl_grok_hex DPPP_(my_grok_hex)
4329 UV
DPPP_(my_grok_hex)4330 DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
4331 {
4332 const char *s = start;
4333 STRLEN len = *len_p;
4334 UV value = 0;
4335 NV value_nv = 0;
4336 const UV max_div_16 = UV_MAX / 16;
4337 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4338 bool overflowed = FALSE;
4339 const char *xdigit;
4340 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
4341 if (len >= 1) {
4342 if (s[0] == 'x') {
4343 s++;
4344 len--;
4345 }
4346 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
4347 s+=2;
4348 len-=2;
4349 }
4350 }
4351 }
4352 for (; len-- && *s; s++) {
4353 xdigit = strchr((char *) PL_hexdigit, *s);
4354 if (xdigit) {
4355 redo:
4356 if (!overflowed) {
4357 if (value <= max_div_16) {
4358 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
4359 continue;
4360 }
4361 warn("Integer overflow in hexadecimal number");
4362 overflowed = TRUE;
4363 value_nv = (NV) value;
4364 }
4365 value_nv *= 16.0;
4366 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
4367 continue;
4368 }
4369 if (*s == '_' && len && allow_underscores && s[1]
4370 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
4371 {
4372 --len;
4373 ++s;
4374 goto redo;
4375 }
4376 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4377 warn("Illegal hexadecimal digit '%c' ignored", *s);
4378 break;
4379 }
4380 if ( ( overflowed && value_nv > 4294967295.0)
4381 #if UVSIZE > 4
4382 || (!overflowed && value > 0xffffffff )
4383 #endif
4384 ) {
4385 warn("Hexadecimal number > 0xffffffff non-portable");
4386 }
4387 *len_p = s - start;
4388 if (!overflowed) {
4389 *flags = 0;
4390 return value;
4391 }
4392 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4393 if (result)
4394 *result = value_nv;
4395 return UV_MAX;
4396 }
4397 #endif
4398 #endif
4399 #ifndef grok_oct
4400 #if defined(NEED_grok_oct)
4401 static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4402 static
4403 #else
4404 extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result);
4405 #endif
4406 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
4407 #ifdef grok_oct
4408 #undef grok_oct
4409 #endif
4410 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
4411 #define Perl_grok_oct DPPP_(my_grok_oct)
4412 UV
DPPP_(my_grok_oct)4413 DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
4414 {
4415 const char *s = start;
4416 STRLEN len = *len_p;
4417 UV value = 0;
4418 NV value_nv = 0;
4419 const UV max_div_8 = UV_MAX / 8;
4420 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4421 bool overflowed = FALSE;
4422 for (; len-- && *s; s++) {
4423 int digit = *s - '0';
4424 if (digit >= 0 && digit <= 7) {
4425 redo:
4426 if (!overflowed) {
4427 if (value <= max_div_8) {
4428 value = (value << 3) | digit;
4429 continue;
4430 }
4431 warn("Integer overflow in octal number");
4432 overflowed = TRUE;
4433 value_nv = (NV) value;
4434 }
4435 value_nv *= 8.0;
4436 value_nv += (NV)digit;
4437 continue;
4438 }
4439 if (digit == ('_' - '0') && len && allow_underscores
4440 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
4441 {
4442 --len;
4443 ++s;
4444 goto redo;
4445 }
4446 if (digit == 8 || digit == 9) {
4447 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4448 warn("Illegal octal digit '%c' ignored", *s);
4449 }
4450 break;
4451 }
4452 if ( ( overflowed && value_nv > 4294967295.0)
4453 #if UVSIZE > 4
4454 || (!overflowed && value > 0xffffffff )
4455 #endif
4456 ) {
4457 warn("Octal number > 037777777777 non-portable");
4458 }
4459 *len_p = s - start;
4460 if (!overflowed) {
4461 *flags = 0;
4462 return value;
4463 }
4464 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4465 if (result)
4466 *result = value_nv;
4467 return UV_MAX;
4468 }
4469 #endif
4470 #endif
4471 #if !defined(my_snprintf)
4472 #if defined(NEED_my_snprintf)
4473 static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
4474 static
4475 #else
4476 extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...);
4477 #endif
4478 #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL)
4479 #define my_snprintf DPPP_(my_my_snprintf)
4480 #define Perl_my_snprintf DPPP_(my_my_snprintf)
4481 int
DPPP_(my_my_snprintf)4482 DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...)
4483 {
4484 dTHX;
4485 int retval;
4486 va_list ap;
4487 va_start(ap, format);
4488 #ifdef HAS_VSNPRINTF
4489 retval = vsnprintf(buffer, len, format, ap);
4490 #else
4491 retval = vsprintf(buffer, format, ap);
4492 #endif
4493 va_end(ap);
4494 if (retval < 0 || (len > 0 && (Size_t)retval >= len))
4495 Perl_croak(aTHX_ "panic: my_snprintf buffer overflow");
4496 return retval;
4497 }
4498 #endif
4499 #endif
4500 #if !defined(my_sprintf)
4501 #if defined(NEED_my_sprintf)
4502 static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
4503 static
4504 #else
4505 extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...);
4506 #endif
4507 #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL)
4508 #define my_sprintf DPPP_(my_my_sprintf)
4509 int
DPPP_(my_my_sprintf)4510 DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...)
4511 {
4512 va_list args;
4513 va_start(args, pat);
4514 vsprintf(buffer, pat, args);
4515 va_end(args);
4516 return strlen(buffer);
4517 }
4518 #endif
4519 #endif
4520 #ifdef NO_XSLOCKS
4521 #ifdef dJMPENV
4522 #define dXCPT dJMPENV; int rEtV = 0
4523 #define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
4524 #define XCPT_TRY_END JMPENV_POP;
4525 #define XCPT_CATCH if (rEtV != 0)
4526 #define XCPT_RETHROW JMPENV_JUMP(rEtV)
4527 #else
4528 #define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
4529 #define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
4530 #define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
4531 #define XCPT_CATCH if (rEtV != 0)
4532 #define XCPT_RETHROW Siglongjmp(top_env, rEtV)
4533 #endif
4534 #endif
4535 #if !defined(my_strlcat)
4536 #if defined(NEED_my_strlcat)
4537 static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
4538 static
4539 #else
4540 extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size);
4541 #endif
4542 #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
4543 #define my_strlcat DPPP_(my_my_strlcat)
4544 #define Perl_my_strlcat DPPP_(my_my_strlcat)
4545 Size_t
DPPP_(my_my_strlcat)4546 DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
4547 {
4548 Size_t used, length, copy;
4549 used = strlen(dst);
4550 length = strlen(src);
4551 if (size > 0 && used < size - 1) {
4552 copy = (length >= size - used) ? size - used - 1 : length;
4553 memcpy(dst + used, src, copy);
4554 dst[used + copy] = '\0';
4555 }
4556 return used + length;
4557 }
4558 #endif
4559 #endif
4560 #if !defined(my_strlcpy)
4561 #if defined(NEED_my_strlcpy)
4562 static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
4563 static
4564 #else
4565 extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size);
4566 #endif
4567 #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
4568 #define my_strlcpy DPPP_(my_my_strlcpy)
4569 #define Perl_my_strlcpy DPPP_(my_my_strlcpy)
4570 Size_t
DPPP_(my_my_strlcpy)4571 DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
4572 {
4573 Size_t length, copy;
4574 length = strlen(src);
4575 if (size > 0) {
4576 copy = (length >= size) ? size - 1 : length;
4577 memcpy(dst, src, copy);
4578 dst[copy] = '\0';
4579 }
4580 return length;
4581 }
4582 #endif
4583 #endif
4584 #ifdef SVf_UTF8
4585 #ifndef SvUTF8
4586 #define SvUTF8(sv) (SvFLAGS(sv) & SVf_UTF8)
4587 #endif
4588 #endif
4589 #if (PERL_BCDVERSION == 0x5019001)
4590 #undef UTF8f
4591 #endif
4592 #ifdef SVf_UTF8
4593 #ifndef UTF8f
4594 #define UTF8f SVf
4595 #endif
4596 #ifndef UTF8fARG
4597 #define UTF8fARG(u,l,p) newSVpvn_flags((p), (l), ((u) ? SVf_UTF8 : 0) | SVs_TEMP)
4598 #endif
4599 #endif
4600 #define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b))
4601 #ifndef UNICODE_REPLACEMENT
4602 #define UNICODE_REPLACEMENT 0xFFFD
4603 #endif
4604 #ifdef UTF8_MAXLEN
4605 #ifndef UTF8_MAXBYTES
4606 #define UTF8_MAXBYTES UTF8_MAXLEN
4607 #endif
4608 #endif
4609 #ifndef UTF_START_MARK
4610 #define UTF_START_MARK(len) \
4611 (((len) > 7) ? 0xFF : (0xFF & (0xFE << (7-(len)))))
4612 #endif
4613 #if (PERL_BCDVERSION < 0x5018000)
4614 #undef UTF8_MAXBYTES_CASE
4615 #endif
4616 #if 'A' == 65
4617 #define D_PPP_BYTE_INFO_BITS 6
4618 #ifndef UTF8_MAXBYTES_CASE
4619 #define UTF8_MAXBYTES_CASE 13
4620 #endif
4621 #else
4622 #define D_PPP_BYTE_INFO_BITS 5
4623 #ifndef UTF8_MAXBYTES_CASE
4624 #define UTF8_MAXBYTES_CASE 15
4625 #endif
4626 #endif
4627 #ifndef UTF_ACCUMULATION_SHIFT
4628 #define UTF_ACCUMULATION_SHIFT D_PPP_BYTE_INFO_BITS
4629 #endif
4630 #ifdef NATIVE_TO_UTF
4631 #ifndef NATIVE_UTF8_TO_I8
4632 #define NATIVE_UTF8_TO_I8(c) NATIVE_TO_UTF(c)
4633 #endif
4634 #else
4635 #ifndef NATIVE_UTF8_TO_I8
4636 #define NATIVE_UTF8_TO_I8(c) (c)
4637 #endif
4638 #endif
4639 #ifdef UTF_TO_NATIVE
4640 #ifndef I8_TO_NATIVE_UTF8
4641 #define I8_TO_NATIVE_UTF8(c) UTF_TO_NATIVE(c)
4642 #endif
4643 #else
4644 #ifndef I8_TO_NATIVE_UTF8
4645 #define I8_TO_NATIVE_UTF8(c) (c)
4646 #endif
4647 #endif
4648 #ifndef UTF_START_MASK
4649 #define UTF_START_MASK(len) \
4650 (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2)))
4651 #endif
4652 #ifndef UTF_IS_CONTINUATION_MASK
4653 #define UTF_IS_CONTINUATION_MASK \
4654 ((U8) (0xFF << UTF_ACCUMULATION_SHIFT))
4655 #endif
4656 #ifndef UTF_CONTINUATION_MARK
4657 #define UTF_CONTINUATION_MARK \
4658 (UTF_IS_CONTINUATION_MASK & 0xB0)
4659 #endif
4660 #ifndef UTF_MIN_START_BYTE
4661 #define UTF_MIN_START_BYTE \
4662 ((UTF_CONTINUATION_MARK >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2))
4663 #endif
4664 #ifndef UTF_MIN_ABOVE_LATIN1_BYTE
4665 #define UTF_MIN_ABOVE_LATIN1_BYTE \
4666 ((0x100 >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2))
4667 #endif
4668 #if (PERL_BCDVERSION < 0x5007000)
4669 #undef UTF8_IS_DOWNGRADEABLE_START
4670 #endif
4671 #ifndef UTF8_IS_DOWNGRADEABLE_START
4672 #define UTF8_IS_DOWNGRADEABLE_START(c) \
4673 inRANGE(NATIVE_UTF8_TO_I8(c), \
4674 UTF_MIN_START_BYTE, UTF_MIN_ABOVE_LATIN1_BYTE - 1)
4675 #endif
4676 #ifndef UTF_CONTINUATION_MASK
4677 #define UTF_CONTINUATION_MASK \
4678 ((U8) ((1U << UTF_ACCUMULATION_SHIFT) - 1))
4679 #endif
4680 #ifndef UTF8_ACCUMULATE
4681 #define UTF8_ACCUMULATE(base, added) \
4682 (((base) << UTF_ACCUMULATION_SHIFT) \
4683 | ((NATIVE_UTF8_TO_I8(added)) \
4684 & UTF_CONTINUATION_MASK))
4685 #endif
4686 #ifndef UTF8_ALLOW_ANYUV
4687 #define UTF8_ALLOW_ANYUV 0
4688 #endif
4689 #ifndef UTF8_ALLOW_EMPTY
4690 #define UTF8_ALLOW_EMPTY 0x0001
4691 #endif
4692 #ifndef UTF8_ALLOW_CONTINUATION
4693 #define UTF8_ALLOW_CONTINUATION 0x0002
4694 #endif
4695 #ifndef UTF8_ALLOW_NON_CONTINUATION
4696 #define UTF8_ALLOW_NON_CONTINUATION 0x0004
4697 #endif
4698 #ifndef UTF8_ALLOW_SHORT
4699 #define UTF8_ALLOW_SHORT 0x0008
4700 #endif
4701 #ifndef UTF8_ALLOW_LONG
4702 #define UTF8_ALLOW_LONG 0x0010
4703 #endif
4704 #ifndef UTF8_ALLOW_OVERFLOW
4705 #define UTF8_ALLOW_OVERFLOW 0x0080
4706 #endif
4707 #ifndef UTF8_ALLOW_ANY
4708 #define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \
4709 |UTF8_ALLOW_NON_CONTINUATION \
4710 |UTF8_ALLOW_SHORT \
4711 |UTF8_ALLOW_LONG \
4712 |UTF8_ALLOW_OVERFLOW)
4713 #endif
4714 #if defined UTF8SKIP
4715 #undef UTF8_SAFE_SKIP
4716 #undef UTF8_CHK_SKIP
4717 #ifndef UTF8_SAFE_SKIP
4718 #define UTF8_SAFE_SKIP(s, e) ( \
4719 ((((e) - (s)) <= 0) \
4720 ? 0 \
4721 : D_PPP_MIN(((e) - (s)), UTF8SKIP(s))))
4722 #endif
4723 #ifndef UTF8_CHK_SKIP
4724 #define UTF8_CHK_SKIP(s) \
4725 (s[0] == '\0' ? 1 : ((U8) D_PPP_MIN(my_strnlen((char *) (s), UTF8SKIP(s)), \
4726 UTF8SKIP(s))))
4727 #endif
4728 #ifndef UTF8_SKIP
4729 #define UTF8_SKIP(s) UTF8SKIP(s)
4730 #endif
4731 #endif
4732 #if 'A' == 65
4733 #ifndef UTF8_IS_INVARIANT
4734 #define UTF8_IS_INVARIANT(c) isASCII(c)
4735 #endif
4736 #else
4737 #ifndef UTF8_IS_INVARIANT
4738 #define UTF8_IS_INVARIANT(c) (isASCII(c) || isCNTRL_L1(c))
4739 #endif
4740 #endif
4741 #ifndef UVCHR_IS_INVARIANT
4742 #define UVCHR_IS_INVARIANT(c) UTF8_IS_INVARIANT(c)
4743 #endif
4744 #ifdef UVCHR_IS_INVARIANT
4745 #if 'A' != 65 || UVSIZE < 8
4746 #define D_PPP_UVCHR_SKIP_UPPER(c) 7
4747 #else
4748 #define D_PPP_UVCHR_SKIP_UPPER(c) \
4749 (((WIDEST_UTYPE) (c)) < \
4750 (((WIDEST_UTYPE) 1) << (6 * D_PPP_BYTE_INFO_BITS)) ? 7 : 13)
4751 #endif
4752 #ifndef UVCHR_SKIP
4753 #define UVCHR_SKIP(c) \
4754 UVCHR_IS_INVARIANT(c) ? 1 : \
4755 (WIDEST_UTYPE) (c) < (32 * (1U << ( D_PPP_BYTE_INFO_BITS))) ? 2 : \
4756 (WIDEST_UTYPE) (c) < (16 * (1U << (2 * D_PPP_BYTE_INFO_BITS))) ? 3 : \
4757 (WIDEST_UTYPE) (c) < ( 8 * (1U << (3 * D_PPP_BYTE_INFO_BITS))) ? 4 : \
4758 (WIDEST_UTYPE) (c) < ( 4 * (1U << (4 * D_PPP_BYTE_INFO_BITS))) ? 5 : \
4759 (WIDEST_UTYPE) (c) < ( 2 * (1U << (5 * D_PPP_BYTE_INFO_BITS))) ? 6 : \
4760 D_PPP_UVCHR_SKIP_UPPER(c)
4761 #endif
4762 #endif
4763 #ifdef is_ascii_string
4764 #ifndef is_invariant_string
4765 #define is_invariant_string(s,l) is_ascii_string(s,l)
4766 #endif
4767 #ifndef is_utf8_invariant_string
4768 #define is_utf8_invariant_string(s,l) is_ascii_string(s,l)
4769 #endif
4770 #endif
4771 #ifdef ibcmp_utf8
4772 #ifndef foldEQ_utf8
4773 #define foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \
4774 cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2))
4775 #endif
4776 #endif
4777 #if defined(is_utf8_string) && defined(UTF8SKIP)
4778 #ifndef isUTF8_CHAR
4779 #define isUTF8_CHAR(s, e) ( \
4780 (e) <= (s) || ! is_utf8_string(s, UTF8_SAFE_SKIP(s, e)) \
4781 ? 0 \
4782 : UTF8SKIP(s))
4783 #endif
4784 #endif
4785 #if 'A' == 65
4786 #ifndef BOM_UTF8
4787 #define BOM_UTF8 "\xEF\xBB\xBF"
4788 #endif
4789 #ifndef REPLACEMENT_CHARACTER_UTF8
4790 #define REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD"
4791 #endif
4792 #elif '^' == 95
4793 #ifndef BOM_UTF8
4794 #define BOM_UTF8 "\xDD\x73\x66\x73"
4795 #endif
4796 #ifndef REPLACEMENT_CHARACTER_UTF8
4797 #define REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71"
4798 #endif
4799 #elif '^' == 176
4800 #ifndef BOM_UTF8
4801 #define BOM_UTF8 "\xDD\x72\x65\x72"
4802 #endif
4803 #ifndef REPLACEMENT_CHARACTER_UTF8
4804 #define REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70"
4805 #endif
4806 #else
4807 #error Unknown character set
4808 #endif
4809 #if (PERL_BCDVERSION < 0x5031004)
4810 #undef utf8_to_uvchr_buf
4811 #endif
4812 #if (PERL_BCDVERSION >= 0x5006001) && ! defined(utf8_to_uvchr_buf)
4813 #if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv)
4814 #if defined(utf8n_to_uvchr)
4815 #define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr
4816 #elif \
4817 defined(utf8_to_uv) && defined(utf8_to_uv_simple)
4818 #define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv
4819 #elif defined(utf8_to_uvchr)
4820 #define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \
4821 utf8_to_uvchr((U8 *)(s), (retlen))
4822 #else
4823 #define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \
4824 utf8_to_uv((U8 *)(s), (retlen))
4825 #endif
4826 #endif
4827 #if defined(NEED_utf8_to_uvchr_buf)
4828 static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen);
4829 static
4830 #else
4831 extern UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen);
4832 #endif
4833 #if defined(NEED_utf8_to_uvchr_buf) || defined(NEED_utf8_to_uvchr_buf_GLOBAL)
4834 #ifdef utf8_to_uvchr_buf
4835 #undef utf8_to_uvchr_buf
4836 #endif
4837 #define utf8_to_uvchr_buf(a,b,c) DPPP_(my_utf8_to_uvchr_buf)(aTHX_ a,b,c)
4838 #define Perl_utf8_to_uvchr_buf DPPP_(my_utf8_to_uvchr_buf)
4839 UV
DPPP_(my_utf8_to_uvchr_buf)4840 DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
4841 {
4842 UV ret;
4843 STRLEN curlen;
4844 bool overflows = 0;
4845 const U8 *cur_s = s;
4846 const bool do_warnings = ckWARN_d(WARN_UTF8);
4847 #if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC)
4848 STRLEN overflow_length = 0;
4849 #endif
4850 if (send > s) {
4851 curlen = send - s;
4852 }
4853 else {
4854 assert(0);
4855 curlen = 0;
4856 if (! do_warnings) {
4857 if (retlen) *retlen = 0;
4858 return UNICODE_REPLACEMENT;
4859 }
4860 }
4861 #if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC)
4862 if (curlen > 0 && UNLIKELY(*s >= 0xFE)) {
4863 if (sizeof(ret) < 8) {
4864 overflows = 1;
4865 overflow_length = (*s == 0xFE) ? 7 : 13;
4866 }
4867 else {
4868 const U8 highest[] =
4869 "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF";
4870 const U8 *cur_h = highest;
4871 for (cur_s = s; cur_s < send; cur_s++, cur_h++) {
4872 if (UNLIKELY(*cur_s == *cur_h)) {
4873 continue;
4874 }
4875 overflows = *cur_s > *cur_h;
4876 break;
4877 }
4878 overflow_length = 13;
4879 }
4880 }
4881 if (UNLIKELY(overflows)) {
4882 ret = 0;
4883 if (! do_warnings && retlen) {
4884 *retlen = overflow_length;
4885 }
4886 }
4887 else
4888 #endif
4889 ret = D_PPP_utf8_to_uvchr_buf_callee(
4890 (U8 *)
4891 s, curlen, retlen, (UTF8_ALLOW_ANYUV
4892 & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY)));
4893 #if (PERL_BCDVERSION >= 0x5026000) && (PERL_BCDVERSION < 0x5028000)
4894 if (UNLIKELY(ret > IV_MAX)) {
4895 overflows = 1;
4896 }
4897 #endif
4898 if (UNLIKELY(overflows)) {
4899 if (! do_warnings) {
4900 if (retlen) {
4901 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
4902 *retlen = D_PPP_MIN(*retlen, curlen);
4903 }
4904 return UNICODE_REPLACEMENT;
4905 }
4906 else {
4907 Perl_warner(aTHX_ packWARN(WARN_UTF8),
4908 "Malformed UTF-8 character (overflow at 0x%" UVxf
4909 ", byte 0x%02x, after start byte 0x%02x)",
4910 ret, *cur_s, *s);
4911 if (retlen) {
4912 *retlen = (STRLEN) -1;
4913 }
4914 return 0;
4915 }
4916 }
4917 if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) {
4918 if (do_warnings) {
4919 *retlen = (STRLEN) -1;
4920 }
4921 else {
4922 ret = D_PPP_utf8_to_uvchr_buf_callee(
4923 (U8 *)
4924 s, curlen, retlen, UTF8_ALLOW_ANY);
4925 ret = UNICODE_REPLACEMENT;
4926 #if (PERL_BCDVERSION < 0x5016000)
4927 if (retlen && (IV) *retlen >= 0) {
4928 unsigned int i = 1;
4929 *retlen = D_PPP_MIN(*retlen, curlen);
4930 *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s));
4931 do {
4932 #ifdef UTF8_IS_CONTINUATION
4933 if (! UTF8_IS_CONTINUATION(s[i]))
4934 #else
4935 if (s[i] < 0x80 || s[i] > 0xBF)
4936 #endif
4937 {
4938 *retlen = i;
4939 break;
4940 }
4941 } while (++i < *retlen);
4942 }
4943 #endif
4944 }
4945 }
4946 return ret;
4947 }
4948 #endif
4949 #endif
4950 #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf)
4951 #undef utf8_to_uvchr
4952 #ifndef utf8_to_uvchr
4953 #define utf8_to_uvchr(s, lp) \
4954 ((*(s) == '\0') \
4955 ? utf8_to_uvchr_buf(s,((s)+1), lp) \
4956 : utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp)))
4957 #endif
4958 #endif
4959 #ifdef sv_len_utf8
4960 #if (PERL_BCDVERSION < 0x5017005)
4961 #undef sv_len_utf8
4962 #if defined(PERL_USE_GCC_BRACE_GROUPS)
4963 #define sv_len_utf8_nomg(sv) ({ SV *_sv2 = (sv); (SvUTF8(_sv2) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(_sv2) ? _sv2 : sv_mortalcopy_flags(_sv2, SV_NOSTEAL))) : ({ STRLEN _len; SvPV_nomg(_sv2, _len); _len; })); })
4964 #define sv_len_utf8(sv) ({ SV *_sv1 = (sv); SvGETMAGIC(_sv1); sv_len_utf8_nomg(_sv1); })
4965 #else
4966 #define sv_len_utf8_nomg(sv) (PL_Sv = (sv), (SvUTF8(PL_Sv) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) : (SvPV_nomg(PL_Sv, PL_na), PL_na)))
4967 #define sv_len_utf8(sv) (PL_Sv = (sv), SvGETMAGIC(PL_Sv), sv_len_utf8_nomg(PL_Sv))
4968 #endif
4969 #endif
4970 #if defined(PERL_USE_GCC_BRACE_GROUPS)
4971 #ifndef sv_len_utf8_nomg
4972 #define sv_len_utf8_nomg(sv) ({ SV *_sv = (sv); sv_len_utf8(!SvGMAGICAL(_sv) ? _sv : sv_mortalcopy_flags(_sv, SV_NOSTEAL)); })
4973 #endif
4974 #else
4975 #ifndef sv_len_utf8_nomg
4976 #define sv_len_utf8_nomg(sv) ((PL_Sv = (sv)), sv_len_utf8(!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL)))
4977 #endif
4978 #endif
4979 #endif
4980 #ifndef PERL_PV_ESCAPE_QUOTE
4981 #define PERL_PV_ESCAPE_QUOTE 0x0001
4982 #endif
4983 #ifndef PERL_PV_PRETTY_QUOTE
4984 #define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE
4985 #endif
4986 #ifndef PERL_PV_PRETTY_ELLIPSES
4987 #define PERL_PV_PRETTY_ELLIPSES 0x0002
4988 #endif
4989 #ifndef PERL_PV_PRETTY_LTGT
4990 #define PERL_PV_PRETTY_LTGT 0x0004
4991 #endif
4992 #ifndef PERL_PV_ESCAPE_FIRSTCHAR
4993 #define PERL_PV_ESCAPE_FIRSTCHAR 0x0008
4994 #endif
4995 #ifndef PERL_PV_ESCAPE_UNI
4996 #define PERL_PV_ESCAPE_UNI 0x0100
4997 #endif
4998 #ifndef PERL_PV_ESCAPE_UNI_DETECT
4999 #define PERL_PV_ESCAPE_UNI_DETECT 0x0200
5000 #endif
5001 #ifndef PERL_PV_ESCAPE_ALL
5002 #define PERL_PV_ESCAPE_ALL 0x1000
5003 #endif
5004 #ifndef PERL_PV_ESCAPE_NOBACKSLASH
5005 #define PERL_PV_ESCAPE_NOBACKSLASH 0x2000
5006 #endif
5007 #ifndef PERL_PV_ESCAPE_NOCLEAR
5008 #define PERL_PV_ESCAPE_NOCLEAR 0x4000
5009 #endif
5010 #ifndef PERL_PV_ESCAPE_RE
5011 #define PERL_PV_ESCAPE_RE 0x8000
5012 #endif
5013 #ifndef PERL_PV_PRETTY_NOCLEAR
5014 #define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR
5015 #endif
5016 #ifndef PERL_PV_PRETTY_DUMP
5017 #define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
5018 #endif
5019 #ifndef PERL_PV_PRETTY_REGPROP
5020 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
5021 #endif
5022 #ifndef pv_escape
5023 #if defined(NEED_pv_escape)
5024 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);
5025 static
5026 #else
5027 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);
5028 #endif
5029 #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL)
5030 #ifdef pv_escape
5031 #undef pv_escape
5032 #endif
5033 #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f)
5034 #define Perl_pv_escape DPPP_(my_pv_escape)
5035 char *
DPPP_(my_pv_escape)5036 DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str,
5037 const STRLEN count, const STRLEN max,
5038 STRLEN * const escaped, const U32 flags)
5039 {
5040 const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
5041 const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
5042 char octbuf[32] = "%123456789ABCDF";
5043 STRLEN wrote = 0;
5044 STRLEN chsize = 0;
5045 STRLEN readsize = 1;
5046 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
5047 bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
5048 #endif
5049 const char *pv = str;
5050 const char * const end = pv + count;
5051 octbuf[0] = esc;
5052 if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
5053 sv_setpvs(dsv, "");
5054 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
5055 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
5056 isuni = 1;
5057 #endif
5058 for (; pv < end && (!max || wrote < max) ; pv += readsize) {
5059 const UV u =
5060 #if defined(is_utf8_string) && defined(utf8_to_uvchr_buf)
5061 isuni ? utf8_to_uvchr_buf((U8*)pv, end, &readsize) :
5062 #endif
5063 (U8)*pv;
5064 const U8 c = (U8)u & 0xFF;
5065 if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
5066 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
5067 chsize = my_snprintf(octbuf, sizeof octbuf,
5068 "%" UVxf, u);
5069 else
5070 chsize = my_snprintf(octbuf, sizeof octbuf,
5071 "%cx{%" UVxf "}", esc, u);
5072 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
5073 chsize = 1;
5074 } else {
5075 if (c == dq || c == esc || !isPRINT(c)) {
5076 chsize = 2;
5077 switch (c) {
5078 case '\\' :
5079 case '%' : if (c == esc)
5080 octbuf[1] = esc;
5081 else
5082 chsize = 1;
5083 break;
5084 case '\v' : octbuf[1] = 'v'; break;
5085 case '\t' : octbuf[1] = 't'; break;
5086 case '\r' : octbuf[1] = 'r'; break;
5087 case '\n' : octbuf[1] = 'n'; break;
5088 case '\f' : octbuf[1] = 'f'; break;
5089 case '"' : if (dq == '"')
5090 octbuf[1] = '"';
5091 else
5092 chsize = 1;
5093 break;
5094 default: chsize = my_snprintf(octbuf, sizeof octbuf,
5095 pv < end && isDIGIT((U8)*(pv+readsize))
5096 ? "%c%03o" : "%c%o", esc, c);
5097 }
5098 } else {
5099 chsize = 1;
5100 }
5101 }
5102 if (max && wrote + chsize > max) {
5103 break;
5104 } else if (chsize > 1) {
5105 sv_catpvn(dsv, octbuf, chsize);
5106 wrote += chsize;
5107 } else {
5108 char tmp[2];
5109 my_snprintf(tmp, sizeof tmp, "%c", c);
5110 sv_catpvn(dsv, tmp, 1);
5111 wrote++;
5112 }
5113 if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
5114 break;
5115 }
5116 if (escaped != NULL)
5117 *escaped= pv - str;
5118 return SvPVX(dsv);
5119 }
5120 #endif
5121 #endif
5122 #ifndef pv_pretty
5123 #if defined(NEED_pv_pretty)
5124 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);
5125 static
5126 #else
5127 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);
5128 #endif
5129 #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL)
5130 #ifdef pv_pretty
5131 #undef pv_pretty
5132 #endif
5133 #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g)
5134 #define Perl_pv_pretty DPPP_(my_pv_pretty)
5135 char *
DPPP_(my_pv_pretty)5136 DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count,
5137 const STRLEN max, char const * const start_color, char const * const end_color,
5138 const U32 flags)
5139 {
5140 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
5141 STRLEN escaped;
5142 if (!(flags & PERL_PV_PRETTY_NOCLEAR))
5143 sv_setpvs(dsv, "");
5144 if (dq == '"')
5145 sv_catpvs(dsv, "\"");
5146 else if (flags & PERL_PV_PRETTY_LTGT)
5147 sv_catpvs(dsv, "<");
5148 if (start_color != NULL)
5149 sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
5150 pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
5151 if (end_color != NULL)
5152 sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
5153 if (dq == '"')
5154 sv_catpvs(dsv, "\"");
5155 else if (flags & PERL_PV_PRETTY_LTGT)
5156 sv_catpvs(dsv, ">");
5157 if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
5158 sv_catpvs(dsv, "...");
5159 return SvPVX(dsv);
5160 }
5161 #endif
5162 #endif
5163 #ifndef pv_display
5164 #if defined(NEED_pv_display)
5165 static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
5166 static
5167 #else
5168 extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim);
5169 #endif
5170 #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL)
5171 #ifdef pv_display
5172 #undef pv_display
5173 #endif
5174 #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e)
5175 #define Perl_pv_display DPPP_(my_pv_display)
5176 char *
DPPP_(my_pv_display)5177 DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
5178 {
5179 pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
5180 if (len > cur && pv[cur] == '\0')
5181 sv_catpvs(dsv, "\\0");
5182 return SvPVX(dsv);
5183 }
5184 #endif
5185 #endif
5186 #if PERL_VERSION_LT(5,27,9)
5187 #ifndef LC_NUMERIC_LOCK
5188 #define LC_NUMERIC_LOCK
5189 #endif
5190 #ifndef LC_NUMERIC_UNLOCK
5191 #define LC_NUMERIC_UNLOCK
5192 #endif
5193 #if PERL_VERSION_LT(5,19,0)
5194 #undef STORE_LC_NUMERIC_SET_STANDARD
5195 #undef RESTORE_LC_NUMERIC
5196 #undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
5197 #ifdef USE_LOCALE
5198 #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
5199 #define DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *LoC_
5200 #endif
5201 #ifndef STORE_NUMERIC_SET_STANDARD
5202 #define STORE_NUMERIC_SET_STANDARD() \
5203 LoC_ = savepv(setlocale(LC_NUMERIC, NULL)); \
5204 SAVEFREEPV(LoC_); \
5205 setlocale(LC_NUMERIC, "C");
5206 #endif
5207 #ifndef RESTORE_LC_NUMERIC
5208 #define RESTORE_LC_NUMERIC() \
5209 setlocale(LC_NUMERIC, LoC_);
5210 #endif
5211 #else
5212 #ifndef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
5213 #define DECLARATION_FOR_LC_NUMERIC_MANIPULATION
5214 #endif
5215 #ifndef STORE_LC_NUMERIC_SET_STANDARD
5216 #define STORE_LC_NUMERIC_SET_STANDARD()
5217 #endif
5218 #ifndef RESTORE_LC_NUMERIC
5219 #define RESTORE_LC_NUMERIC()
5220 #endif
5221 #endif
5222 #endif
5223 #endif
5224 #ifndef LOCK_NUMERIC_STANDARD
5225 #define LOCK_NUMERIC_STANDARD()
5226 #endif
5227 #ifndef UNLOCK_NUMERIC_STANDARD
5228 #define UNLOCK_NUMERIC_STANDARD()
5229 #endif
5230 #ifndef LOCK_LC_NUMERIC_STANDARD
5231 #define LOCK_LC_NUMERIC_STANDARD LOCK_NUMERIC_STANDARD
5232 #endif
5233 #ifndef UNLOCK_LC_NUMERIC_STANDARD
5234 #define UNLOCK_LC_NUMERIC_STANDARD UNLOCK_NUMERIC_STANDARD
5235 #endif
5236 #ifndef switch_to_global_locale
5237 #define switch_to_global_locale()
5238 #endif
5239 #ifdef sync_locale
5240 #if (PERL_BCDVERSION < 0x5027009)
5241 #if (PERL_BCDVERSION >= 0x5021003)
5242 #undef sync_locale
5243 #define sync_locale() (Perl_sync_locale(aTHX), 1)
5244 #elif defined(sync_locale)
5245 #undef sync_locale
5246 #define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \
5247 new_collate(setlocale(LC_COLLATE, NULL)), \
5248 set_numeric_local(), \
5249 new_numeric(setlocale(LC_NUMERIC, NULL)), \
5250 1)
5251 #elif defined(new_ctype) && defined(LC_CTYPE)
5252 #define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1)
5253 #endif
5254 #endif
5255 #endif
5256 #ifndef sync_locale
5257 #define sync_locale() 1
5258 #endif
5259 #endif
5260