5 ----------------------------------------------------------------------
7 ppport.h -- Perl/Pollution/Portability Version 3.03
9 Automatically created by Devel::PPPort running under
10 perl 5.008004 on Thu Sep 16 09:09:58 2004.
12 Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
13 includes in parts/inc/ instead.
15 Use 'perldoc ppport.h' to view the documentation below.
17 ----------------------------------------------------------------------
25 ppport.h - Perl/Pollution/Portability version 3.03
29 perl ppport.h [options] [files]
31 --help show short help
33 --patch=file write one patch file with changes
34 --copy=suffix write changed copies with suffix
35 --diff=program use diff program and options
37 --compat-version=version provide compatibility with Perl version
38 --cplusplus accept C++ comments
40 --quiet don't output anything except fatal errors
41 --nodiag don't show diagnostics
42 --nohints don't show hints
43 --nochanges don't suggest changes
45 --list-provided list provided API
46 --list-unsupported list unsupported API
50 This version of F<ppport.h> is designed to support operation with Perl
51 installations back to 5.003, and has been tested up to 5.9.2.
57 Display a brief usage summary.
59 =head2 --patch=I<file>
61 If this option is given, a single patch file will be created if
62 any changes are suggested. This requires a working diff program
63 to be installed on your system.
65 =head2 --copy=I<suffix>
67 If this option is given, a copy of each file will be saved with
68 the given suffix that contains the suggested changes. This does
69 not require any external programs.
71 If neither C<--patch> or C<--copy> are given, the default is to
72 simply print the diffs for each file. This requires either
73 C<Text::Diff> or a C<diff> program to be installed.
75 =head2 --diff=I<program>
77 Manually set the diff program and options to use. The default
78 is to use C<Text::Diff>, when installed, and output unified
81 =head2 --compat-version=I<version>
83 Tell F<ppport.h> to check for compatibility with the given
84 Perl version. The default is to check for compatibility with Perl
85 version 5.003. You can use this option to reduce the output
86 of F<ppport.h> if you intend to be backward compatible only
87 up to a certain Perl version.
91 Usually, F<ppport.h> will detect C++ style comments and
92 replace them with C style comments for portability reasons.
93 Using this option instructs F<ppport.h> to leave C++
98 Be quiet. Don't print anything except fatal errors.
102 Don't output any diagnostic messages. Only portability
103 alerts will be printed.
107 Don't output any hints. Hints often contain useful portability
112 Don't suggest any changes. Only give diagnostic output and hints
113 unless these are also deactivated.
115 =head2 --list-provided
117 Lists the API elements for which compatibility is provided by
118 F<ppport.h>. Also lists if it must be explicitly requested,
119 if it has dependencies, and if there are hints for it.
121 =head2 --list-unsupported
123 Lists the API elements that are known not to be supported by
124 F<ppport.h> and below which version of Perl they probably
125 won't be available or work.
129 In order for a Perl extension (XS) module to be as portable as possible
130 across differing versions of Perl itself, certain steps need to be taken.
136 Including this header is the first major one. This alone will give you
137 access to a large part of the Perl API that hasn't been available in
138 earlier Perl releases. Use
140 perl ppport.h --list-provided
142 to see which API elements are provided by ppport.h.
146 You should avoid using deprecated parts of the API. For example, using
147 global Perl variables without the C<PL_> prefix is deprecated. Also,
148 some API functions used to have a C<perl_> prefix. Using this form is
149 also deprecated. You can safely use the supported API, as F<ppport.h>
150 will provide wrappers for older Perl versions.
154 If you use one of a few functions that were not present in earlier
155 versions of Perl, and that can't be provided using a macro, you have
156 to explicitly request support for these functions by adding one or
157 more C<#define>s in your source code before the inclusion of F<ppport.h>.
159 These functions will be marked C<explicit> in the list shown by
162 Depending on whether you module has a single or multiple files that
163 use such functions, you want either C<static> or global variants.
165 For a C<static> function, use:
167 #define NEED_function
169 For a global function, use:
171 #define NEED_function_GLOBAL
173 Note that you mustn't have more than one global request for one
174 function in your project.
176 Function Static Request Global Request
177 -----------------------------------------------------------------------------------------
178 eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
179 grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
180 grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
181 grok_number() NEED_grok_number NEED_grok_number_GLOBAL
182 grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
183 grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
184 newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
185 newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
186 sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
187 sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
188 sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
189 sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
190 sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
191 sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
192 vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
194 To avoid namespace conflicts, you can change the namespace of the
195 explicitly exported functions using the C<DPPP_NAMESPACE> macro.
196 Just C<#define> the macro before including C<ppport.h>:
198 #define DPPP_NAMESPACE MyOwnNamespace_
201 The default namespace is C<DPPP_>.
205 The good thing is that most of the above can be checked by running
206 F<ppport.h> on your source code. See the next section for
211 To verify whether F<ppport.h> is needed for your module, whether you
212 should make any changes to your code, and whether any special defines
213 should be used, F<ppport.h> can be run as a Perl script to check your
214 source code. Simply say:
218 The result will usually be a list of patches suggesting changes
219 that should at least be acceptable, if not necessarily the most
220 efficient solution, or a fix for all possible problems.
222 If you know that your XS module uses features only available in
223 newer Perl releases, if you're aware that it uses C++ comments,
224 and if you want all suggestions as a single patch file, you could
225 use something like this:
227 perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
229 If you only want your code to be scanned without any suggestions
232 perl ppport.h --nochanges
234 You can specify a different C<diff> program or options, using
235 the C<--diff> option:
237 perl ppport.h --diff='diff -C 10'
239 This would output context diffs with 10 lines of context.
243 If this version of F<ppport.h> is causing failure during
244 the compilation of this module, please check if newer versions
245 of either this module or C<Devel::PPPort> are available on CPAN
246 before sending a bug report.
248 If F<ppport.h> was generated using the latest version of
249 C<Devel::PPPort> and is causing failure of this module, please
250 file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
252 Please include the following information:
258 The complete output from running "perl -V"
266 The name and version of the module you were trying to build.
270 A full log of the build that failed.
274 Any other information that you think could be relevant.
278 For the latest version of this code, please get the C<Devel::PPPort>
283 Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz.
285 Version 2.x, Copyright (C) 2001, Paul Marquess.
287 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
289 This program is free software; you can redistribute it and/or
290 modify it under the same terms as Perl itself.
294 See L<Devel::PPPort>.
308 my($ppport) = $0 =~ /([\w.]+)$/;
309 my $LF = '(?:\r\n|[\r\n])'; # line feed
310 my $HS = "[ \t]"; # horizontal whitespace
313 require Getopt::Long;
314 Getopt::Long::GetOptions(\%opt, qw(
315 help quiet diag! hints! changes! cplusplus
316 patch=s copy=s diff=s compat-version=s
317 list-provided list-unsupported
321 if ($@ and grep /^-/, @ARGV) {
322 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
323 die "Getopt::Long not found. Please don't use any options.\n";
326 usage() if $opt{help};
328 if (exists $opt{'compat-version'}) {
329 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
331 die "Invalid version number format: '$opt{'compat-version'}'\n";
333 die "Only Perl 5 is supported\n" if $r != 5;
334 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000;
335 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
338 $opt{'compat-version'} = 5;
341 # Never use C comments in this file!!!!!
344 my $rccs = quotemeta $ccs;
345 my $rcce = quotemeta $cce;
350 @files = map { glob $_ } @ARGV;
355 File::Find::find(sub {
356 $File::Find::name =~ /\.(xs|c|h|cc)$/i
357 and push @files, $File::Find::name;
361 @files = map { glob $_ } qw(*.xs *.c *.h *.cc);
363 my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files;
364 @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files;
368 die "No input files given!\n";
371 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
373 ($2 ? ( base => $2 ) : ()),
374 ($3 ? ( todo => $3 ) : ()),
375 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
376 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
377 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
379 : die "invalid spec: $_" } qw(
385 CopFILEAV|5.006000||p
386 CopFILEGV_set|5.006000||p
387 CopFILEGV|5.006000||p
388 CopFILESV|5.006000||p
389 CopFILE_set|5.006000||p
391 CopSTASHPV_set|5.006000||p
392 CopSTASHPV|5.006000||p
393 CopSTASH_eq|5.006000||p
394 CopSTASH_set|5.006000||p
402 END_EXTERN_C|5.005000||p
410 GROK_NUMERIC_RADIX|5.007002||p
425 HeSVKEY_force||5.004000|
426 HeSVKEY_set||5.004000|
431 IN_LOCALE_COMPILETIME|5.007002||p
432 IN_LOCALE_RUNTIME|5.007002||p
433 IN_LOCALE|5.007002||p
434 IN_PERL_COMPILETIME|5.008001||p
435 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
436 IS_NUMBER_INFINITY|5.007002||p
437 IS_NUMBER_IN_UV|5.007002||p
438 IS_NUMBER_NAN|5.007003||p
439 IS_NUMBER_NEG|5.007002||p
440 IS_NUMBER_NOT_INT|5.007002||p
447 MY_CXT_CLONE|5.009002||p
448 MY_CXT_INIT|5.007003||p
470 PAD_COMPNAME_FLAGS|||
472 PAD_COMPNAME_OURSTASH|||
477 PAD_SAVE_SETNULLPAD|||
479 PAD_SET_CUR_NOSAVE|||
483 PERL_BCDVERSION|5.009002||p
484 PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
485 PERL_INT_MAX|5.004000||p
486 PERL_INT_MIN|5.004000||p
487 PERL_LONG_MAX|5.004000||p
488 PERL_LONG_MIN|5.004000||p
489 PERL_MAGIC_arylen|5.007002||p
490 PERL_MAGIC_backref|5.007002||p
491 PERL_MAGIC_bm|5.007002||p
492 PERL_MAGIC_collxfrm|5.007002||p
493 PERL_MAGIC_dbfile|5.007002||p
494 PERL_MAGIC_dbline|5.007002||p
495 PERL_MAGIC_defelem|5.007002||p
496 PERL_MAGIC_envelem|5.007002||p
497 PERL_MAGIC_env|5.007002||p
498 PERL_MAGIC_ext|5.007002||p
499 PERL_MAGIC_fm|5.007002||p
500 PERL_MAGIC_glob|5.007002||p
501 PERL_MAGIC_isaelem|5.007002||p
502 PERL_MAGIC_isa|5.007002||p
503 PERL_MAGIC_mutex|5.007002||p
504 PERL_MAGIC_nkeys|5.007002||p
505 PERL_MAGIC_overload_elem|5.007002||p
506 PERL_MAGIC_overload_table|5.007002||p
507 PERL_MAGIC_overload|5.007002||p
508 PERL_MAGIC_pos|5.007002||p
509 PERL_MAGIC_qr|5.007002||p
510 PERL_MAGIC_regdata|5.007002||p
511 PERL_MAGIC_regdatum|5.007002||p
512 PERL_MAGIC_regex_global|5.007002||p
513 PERL_MAGIC_shared_scalar|5.007003||p
514 PERL_MAGIC_shared|5.007003||p
515 PERL_MAGIC_sigelem|5.007002||p
516 PERL_MAGIC_sig|5.007002||p
517 PERL_MAGIC_substr|5.007002||p
518 PERL_MAGIC_sv|5.007002||p
519 PERL_MAGIC_taint|5.007002||p
520 PERL_MAGIC_tiedelem|5.007002||p
521 PERL_MAGIC_tiedscalar|5.007002||p
522 PERL_MAGIC_tied|5.007002||p
523 PERL_MAGIC_utf8|5.008001||p
524 PERL_MAGIC_uvar_elem|5.007003||p
525 PERL_MAGIC_uvar|5.007002||p
526 PERL_MAGIC_vec|5.007002||p
527 PERL_MAGIC_vstring|5.008001||p
528 PERL_QUAD_MAX|5.004000||p
529 PERL_QUAD_MIN|5.004000||p
530 PERL_REVISION|5.006000||p
531 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
532 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
533 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
534 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
535 PERL_SHORT_MAX|5.004000||p
536 PERL_SHORT_MIN|5.004000||p
537 PERL_SUBVERSION|5.006000||p
538 PERL_UCHAR_MAX|5.004000||p
539 PERL_UCHAR_MIN|5.004000||p
540 PERL_UINT_MAX|5.004000||p
541 PERL_UINT_MIN|5.004000||p
542 PERL_ULONG_MAX|5.004000||p
543 PERL_ULONG_MIN|5.004000||p
544 PERL_UNUSED_DECL|5.007002||p
545 PERL_UQUAD_MAX|5.004000||p
546 PERL_UQUAD_MIN|5.004000||p
547 PERL_USHORT_MAX|5.004000||p
548 PERL_USHORT_MIN|5.004000||p
549 PERL_VERSION|5.006000||p
554 PL_compiling|5.004050||p
555 PL_copline|5.005000||p
556 PL_curcop|5.004050||p
557 PL_curstash|5.004050||p
558 PL_debstash|5.004050||p
560 PL_diehook|5.004050||p
564 PL_hexdigit|5.005000||p
567 PL_modglobal||5.005000|n
569 PL_no_modify|5.006000||p
571 PL_perl_destruct_level|5.004050||p
572 PL_perldb|5.004050||p
573 PL_ppaddr|5.006000||p
574 PL_rsfp_filters|5.004050||p
577 PL_stack_base|5.004050||p
578 PL_stack_sp|5.004050||p
579 PL_stdingv|5.004050||p
580 PL_sv_arenaroot|5.004050||p
581 PL_sv_no|5.004050||pn
582 PL_sv_undef|5.004050||pn
583 PL_sv_yes|5.004050||pn
584 PL_tainted|5.004050||p
585 PL_tainting|5.004050||p
589 POPpbytex||5.007001|n
600 PUSHmortal|5.009002||p
606 PerlIO_clearerr||5.007003|
607 PerlIO_close||5.007003|
608 PerlIO_eof||5.007003|
609 PerlIO_error||5.007003|
610 PerlIO_fileno||5.007003|
611 PerlIO_fill||5.007003|
612 PerlIO_flush||5.007003|
613 PerlIO_get_base||5.007003|
614 PerlIO_get_bufsiz||5.007003|
615 PerlIO_get_cnt||5.007003|
616 PerlIO_get_ptr||5.007003|
617 PerlIO_read||5.007003|
618 PerlIO_seek||5.007003|
619 PerlIO_set_cnt||5.007003|
620 PerlIO_set_ptrcnt||5.007003|
621 PerlIO_setlinebuf||5.007003|
622 PerlIO_stderr||5.007003|
623 PerlIO_stdin||5.007003|
624 PerlIO_stdout||5.007003|
625 PerlIO_tell||5.007003|
626 PerlIO_unread||5.007003|
627 PerlIO_write||5.007003|
636 SAVE_DEFSV|5.004050||p
639 START_EXTERN_C|5.005000||p
640 START_MY_CXT|5.007003||p
658 SvGETMAGIC|5.004050||p
661 SvIOK_notUV||5.006000|
663 SvIOK_only_UV||5.006000|
669 SvIV_nomg|5.009001||p
672 SvIsCOW_shared_hash||5.008003|
690 SvPOK_only_UTF8||5.006000|
696 SvPV_force_nomg|5.007002||p
698 SvPV_nolen|5.006000||p
699 SvPV_nomg|5.007002||p
700 SvPVbyte_force||5.009002|
701 SvPVbyte_nolen||5.006000|
702 SvPVbytex_force||5.006000|
705 SvPVutf8_force||5.006000|
706 SvPVutf8_nolen||5.006000|
707 SvPVutf8x_force||5.006000|
722 SvSetMagicSV_nosteal||5.004000|
723 SvSetMagicSV||5.004000|
724 SvSetSV_nosteal||5.004000|
726 SvTAINTED_off||5.004000|
727 SvTAINTED_on||5.004000|
735 SvUTF8_off||5.006000|
740 SvUV_nomg|5.009001||p
753 XPUSHmortal|5.009002||p
764 XSRETURN_UV|5.008001||p
774 XS_VERSION_BOOTCHECK|||
793 apply_attrs_string||5.006001|
798 atfork_lock||5.007003|n
799 atfork_unlock||5.007003|n
820 block_gimme||5.004000|
824 boot_core_UNIVERSAL|||
826 bytes_from_utf8||5.007001|
827 bytes_to_utf8||5.006001|
829 call_argv|5.006000||p
830 call_atexit||5.006000|
834 call_method|5.006000||p
841 cast_ulong||5.006000|
858 csighandler||5.007001|n
859 custom_op_desc||5.007003|
860 custom_op_name||5.007003|
863 cv_const_sv||5.004000|
872 dMY_CXT_SV|5.007003||p
881 dUNDERBAR|5.009002||p
889 debprofdump||5.005000|
891 debstackptrs||5.007003|
913 despatch_signals||5.007001|
923 do_binmode||5.004050|
932 do_gv_dump||5.006000|
933 do_gvgv_dump||5.006000|
934 do_hv_dump||5.006000|
939 do_magic_dump||5.006000|
943 do_op_dump||5.006000|
948 do_pmop_dump||5.006000|
957 do_sv_dump||5.006000|
960 do_trans_complex_utf8|||
962 do_trans_count_utf8|||
964 do_trans_simple_utf8|||
977 doing_taint||5.008001|n
992 dump_indent||5.006000|v
994 dump_packsubs||5.006000|
996 dump_vindent||5.006000|
1003 fbm_compile||5.005000|
1004 fbm_instr||5.005000|
1014 find_rundefsvoffset||5.009002|
1027 fprintf_nocontext|||vn
1028 free_tied_hv_pool|||
1030 gen_constant_list|||
1032 get_context||5.006000|n
1041 get_op_descs||5.005000|
1042 get_op_names||5.005000|
1044 get_ppaddr||5.006000|
1047 getcwd_sv||5.007002|
1052 grok_bin|5.007003||p
1053 grok_hex|5.007003||p
1054 grok_number|5.007002||p
1055 grok_numeric_radix|5.007002||p
1056 grok_oct|5.007003||p
1061 gv_autoload4||5.004000|
1064 gv_efullname3||5.004000|
1065 gv_efullname4||5.006001|
1069 gv_fetchmeth_autoload||5.007003|
1070 gv_fetchmethod_autoload||5.004000|
1074 gv_fullname3||5.004000|
1075 gv_fullname4||5.006001|
1077 gv_handler||5.007001|
1081 gv_stashpvn|5.006000||p
1087 hv_assert||5.009001|
1088 hv_clear_placeholders||5.009001|
1090 hv_delayfree_ent||5.004000|
1092 hv_delete_ent||5.004000|
1094 hv_exists_ent||5.004000|
1097 hv_fetch_ent||5.004000|
1099 hv_free_ent||5.004000|
1101 hv_iterkeysv||5.004000|
1103 hv_iternext_flags||5.008000|
1107 hv_ksplit||5.004000|
1111 hv_scalar||5.009001|
1112 hv_store_ent||5.004000|
1113 hv_store_flags||5.008000|
1116 ibcmp_locale||5.004000|
1117 ibcmp_utf8||5.007003|
1123 init_argv_symbols|||
1125 init_i18nl10n||5.006000|
1126 init_i18nl14n||5.006000|
1132 init_postdump_symbols|||
1133 init_predump_symbols|||
1134 init_stacks||5.005000|
1150 is_handle_constructor|||
1151 is_lvalue_sub||5.007001|
1152 is_uni_alnum_lc||5.006000|
1153 is_uni_alnumc_lc||5.006000|
1154 is_uni_alnumc||5.006000|
1155 is_uni_alnum||5.006000|
1156 is_uni_alpha_lc||5.006000|
1157 is_uni_alpha||5.006000|
1158 is_uni_ascii_lc||5.006000|
1159 is_uni_ascii||5.006000|
1160 is_uni_cntrl_lc||5.006000|
1161 is_uni_cntrl||5.006000|
1162 is_uni_digit_lc||5.006000|
1163 is_uni_digit||5.006000|
1164 is_uni_graph_lc||5.006000|
1165 is_uni_graph||5.006000|
1166 is_uni_idfirst_lc||5.006000|
1167 is_uni_idfirst||5.006000|
1168 is_uni_lower_lc||5.006000|
1169 is_uni_lower||5.006000|
1170 is_uni_print_lc||5.006000|
1171 is_uni_print||5.006000|
1172 is_uni_punct_lc||5.006000|
1173 is_uni_punct||5.006000|
1174 is_uni_space_lc||5.006000|
1175 is_uni_space||5.006000|
1176 is_uni_upper_lc||5.006000|
1177 is_uni_upper||5.006000|
1178 is_uni_xdigit_lc||5.006000|
1179 is_uni_xdigit||5.006000|
1180 is_utf8_alnumc||5.006000|
1181 is_utf8_alnum||5.006000|
1182 is_utf8_alpha||5.006000|
1183 is_utf8_ascii||5.006000|
1184 is_utf8_char||5.006000|
1185 is_utf8_cntrl||5.006000|
1186 is_utf8_digit||5.006000|
1187 is_utf8_graph||5.006000|
1188 is_utf8_idcont||5.008000|
1189 is_utf8_idfirst||5.006000|
1190 is_utf8_lower||5.006000|
1191 is_utf8_mark||5.006000|
1192 is_utf8_print||5.006000|
1193 is_utf8_punct||5.006000|
1194 is_utf8_space||5.006000|
1195 is_utf8_string_loc||5.008001|
1196 is_utf8_string||5.006001|
1197 is_utf8_upper||5.006000|
1198 is_utf8_xdigit||5.006000|
1211 load_module_nocontext|||vn
1212 load_module||5.006000|v
1214 looks_like_number|||
1224 magic_clear_all_env|||
1228 magic_dump||5.006000|
1244 magic_killbackrefs|||
1249 magic_regdata_cnt|||
1250 magic_regdatum_get|||
1251 magic_regdatum_set|||
1253 magic_set_all_env|||
1257 magic_setcollxfrm|||
1297 mg_length||5.005000|
1301 mini_mktime||5.007002|
1303 mode_from_discipline|||
1337 my_failure_exit||5.004000|
1338 my_fflush_all||5.006000|
1361 my_memcmp||5.004000|n
1364 my_pclose||5.004000|
1365 my_popen_list||5.007001|
1368 my_socketpair||5.007003|n
1370 my_strftime||5.007002|
1375 newANONATTRSUB||5.006000|
1380 newATTRSUB||5.006000|
1385 newCONSTSUB|5.006000||p
1409 newRV_inc|5.004000||p
1410 newRV_noinc|5.006000||p
1419 newSVpvf_nocontext|||vn
1420 newSVpvf||5.004000|v
1421 newSVpvn_share||5.007001|
1422 newSVpvn|5.006000||p
1429 newWHILEOP||5.004040|
1430 newXSproto||5.006000|
1432 new_collate||5.006000|
1434 new_ctype||5.006000|
1437 new_numeric||5.006000|
1438 new_stackinfo||5.005000|
1439 new_version||5.009000|
1456 no_bareword_allowed|||
1460 nothreadhook||5.008000|
1472 pMY_CXT_|5.007003||p
1487 pad_fixup_inner_anons|||
1499 parse_unicode_opts|||
1503 perl_alloc_using|||n
1505 perl_clone_using|||n
1508 perl_destruct||5.007003|n
1510 perl_parse||5.006000|n
1514 pmop_dump||5.006000|
1522 printf_nocontext|||vn
1531 pv_display||5.006000|
1532 pv_uni_display||5.007003|
1536 re_intuit_start||5.006000|
1537 re_intuit_string||5.006000|
1541 reentrant_retry|||vn
1550 regclass_swash||5.007003|
1557 regexec_flags||5.005000|
1563 reginitcolors||5.006000|
1582 require_pv||5.006000|
1586 rsignal_state||5.004000|
1589 runops_debug||5.005000|
1590 runops_standard||5.005000|
1594 safesyscalloc||5.006000|n
1595 safesysfree||5.006000|n
1596 safesysmalloc||5.006000|n
1597 safesysrealloc||5.006000|n
1602 save_aelem||5.004050|
1603 save_alloc||5.006000|
1606 save_bool||5.008001|
1609 save_destructor_x||5.006000|
1610 save_destructor||5.006000|
1614 save_generic_pvref||5.006001|
1615 save_generic_svref||5.005030|
1619 save_helem||5.004050|
1620 save_hints||5.005000|
1629 save_mortalizesv||5.007001|
1632 save_padsv||5.007001|
1634 save_re_context||5.006000|
1637 save_set_svflags||5.009000|
1638 save_shared_pvref||5.007003|
1641 save_threadsv||5.005000|
1642 save_vptr||5.006000|
1645 savesharedpv||5.007003|
1646 savestack_grow_cnt||5.008001|
1669 scan_version||5.009001|
1670 scan_vstring||5.008001|
1673 screaminstr||5.005000|
1675 set_context||5.006000|n
1677 set_numeric_local||5.006000|
1678 set_numeric_radix||5.006000|
1679 set_numeric_standard||5.006000|
1692 start_subparse||5.004000|
1700 str_to_version||5.006000|
1711 sv_2iuv_non_preserve|||
1712 sv_2iv_flags||5.009001|
1716 sv_2pv_flags||5.007002|
1717 sv_2pv_nolen|5.006000||p
1719 sv_2pvbyte|5.006000||p
1720 sv_2pvutf8_nolen||5.006000|
1721 sv_2pvutf8||5.006000|
1723 sv_2uv_flags||5.009001|
1729 sv_cat_decode||5.008001|
1730 sv_catpv_mg|5.006000||p
1731 sv_catpvf_mg_nocontext|||pvn
1732 sv_catpvf_mg|5.006000|5.004000|pv
1733 sv_catpvf_nocontext|||vn
1734 sv_catpvf||5.004000|v
1735 sv_catpvn_flags||5.007002|
1736 sv_catpvn_mg|5.006000||p
1737 sv_catpvn_nomg|5.007002||p
1740 sv_catsv_flags||5.007002|
1741 sv_catsv_mg|5.006000||p
1742 sv_catsv_nomg|5.007002||p
1748 sv_cmp_locale||5.004000|
1751 sv_compile_2op||5.008001|
1752 sv_copypv||5.007003|
1755 sv_derived_from||5.004000|
1759 sv_force_normal_flags||5.007001|
1760 sv_force_normal||5.006000|
1771 sv_len_utf8||5.006000|
1773 sv_magicext||5.007003|
1778 sv_nolocking||5.007003|
1779 sv_nosharing||5.007003|
1780 sv_nounlocking||5.007003|
1783 sv_pos_b2u||5.006000|
1784 sv_pos_u2b||5.006000|
1785 sv_pvbyten_force||5.006000|
1786 sv_pvbyten||5.006000|
1787 sv_pvbyte||5.006000|
1788 sv_pvn_force_flags||5.007002|
1790 sv_pvn_nomg|5.007003||p
1792 sv_pvutf8n_force||5.006000|
1793 sv_pvutf8n||5.006000|
1794 sv_pvutf8||5.006000|
1796 sv_recode_to_utf8||5.007003|
1803 sv_rvweaken||5.006000|
1804 sv_setiv_mg|5.006000||p
1806 sv_setnv_mg|5.006000||p
1808 sv_setpv_mg|5.006000||p
1809 sv_setpvf_mg_nocontext|||pvn
1810 sv_setpvf_mg|5.006000|5.004000|pv
1811 sv_setpvf_nocontext|||vn
1812 sv_setpvf||5.004000|v
1813 sv_setpviv_mg||5.008001|
1814 sv_setpviv||5.008001|
1815 sv_setpvn_mg|5.006000||p
1822 sv_setref_uv||5.007001|
1824 sv_setsv_flags||5.007002|
1825 sv_setsv_mg|5.006000||p
1826 sv_setsv_nomg|5.007002||p
1828 sv_setuv_mg|5.006000||p
1829 sv_setuv|5.006000||p
1830 sv_tainted||5.004000|
1834 sv_uni_display||5.007003|
1836 sv_unref_flags||5.007001|
1838 sv_untaint||5.004000|
1840 sv_usepvn_mg|5.006000||p
1842 sv_utf8_decode||5.006000|
1843 sv_utf8_downgrade||5.006000|
1844 sv_utf8_encode||5.006000|
1845 sv_utf8_upgrade_flags||5.007002|
1846 sv_utf8_upgrade||5.007001|
1848 sv_vcatpvf_mg|5.006000|5.004000|p
1849 sv_vcatpvfn||5.004000|
1850 sv_vcatpvf|5.006000|5.004000|p
1851 sv_vsetpvf_mg|5.006000|5.004000|p
1852 sv_vsetpvfn||5.004000|
1853 sv_vsetpvf|5.006000|5.004000|p
1856 swash_fetch||5.007002|
1857 swash_init||5.006000|
1863 tmps_grow||5.006000|
1867 to_uni_fold||5.007003|
1868 to_uni_lower_lc||5.006000|
1869 to_uni_lower||5.007003|
1870 to_uni_title_lc||5.006000|
1871 to_uni_title||5.007003|
1872 to_uni_upper_lc||5.006000|
1873 to_uni_upper||5.007003|
1874 to_utf8_case||5.007003|
1875 to_utf8_fold||5.007003|
1876 to_utf8_lower||5.007003|
1878 to_utf8_title||5.007003|
1879 to_utf8_upper||5.007003|
1882 too_few_arguments|||
1883 too_many_arguments|||
1886 unpack_str||5.007003|
1887 unpackstring||5.008001|
1888 unshare_hek_or_pvn|||
1890 unsharepvn||5.004000|
1891 upg_version||5.009000|
1894 utf16_to_utf8_reversed||5.006001|
1895 utf16_to_utf8||5.006001|
1896 utf16rev_textfilter|||
1897 utf8_distance||5.006000|
1899 utf8_length||5.007001|
1902 utf8_to_bytes||5.006001|
1903 utf8_to_uvchr||5.007001|
1904 utf8_to_uvuni||5.007001|
1905 utf8n_to_uvchr||5.007001|
1906 utf8n_to_uvuni||5.007001|
1908 uvchr_to_utf8_flags||5.007003|
1909 uvchr_to_utf8||5.007001|
1910 uvuni_to_utf8_flags||5.007003|
1911 uvuni_to_utf8||5.007001|
1925 vload_module||5.006000|
1927 vnewSVpvf|5.006000|5.004000|p
1932 vstringify||5.009000|
1937 warner_nocontext|||vn
1949 if (exists $opt{'list-unsupported'}) {
1951 for $f (sort { lc $a cmp lc $b } keys %API) {
1952 next unless $API{$f}{todo};
1953 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
1958 # Scan for possible replacement candidates
1960 my(%replace, %need, %hints, %depends);
1966 if (m{^\s*\*\s(.*?)\s*$}) {
1967 $hints{$hint} ||= ''; # suppress warning with older perls
1968 $hints{$hint} .= "$1\n";
1974 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
1976 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
1977 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
1978 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
1979 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
1981 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
1982 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
1985 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
1988 if (exists $opt{'list-provided'}) {
1990 for $f (sort { lc $a cmp lc $b } keys %API) {
1991 next unless $API{$f}{provided};
1993 push @flags, 'explicit' if exists $need{$f};
1994 push @flags, 'depend' if exists $depends{$f};
1995 push @flags, 'hint' if exists $hints{$f};
1996 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
2002 my(%files, %global, %revreplace);
2003 %revreplace = reverse %replace;
2005 my $patch_opened = 0;
2007 for $filename (@files) {
2008 unless (open IN, "<$filename") {
2009 warn "Unable to read from $filename: $!\n";
2013 info("Scanning $filename ...");
2015 my $c = do { local $/; <IN> };
2018 my %file = (orig => $c, changes => 0);
2020 # temporarily remove C comments from the code
2026 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
2028 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
2032 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
2037 defined $2 and push @ccom, $2;
2038 defined $1 ? $1 : "$ccs$#ccom$cce";
2041 $file{ccom} = \@ccom;
2043 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
2047 for $func (keys %API) {
2049 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
2050 if ($c =~ /\b(?:Perl_)?($match)\b/) {
2051 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
2052 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
2053 if (exists $API{$func}{provided}) {
2054 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
2055 $file{uses}{$func}++;
2056 my @deps = rec_depend($func);
2058 $file{uses_deps}{$func} = \@deps;
2060 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
2063 for ($func, @deps) {
2064 if (exists $need{$_}) {
2065 $file{needs}{$_} = 'static';
2070 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
2071 if ($c =~ /\b$func\b/) {
2072 $file{uses_todo}{$func}++;
2078 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
2079 if (exists $need{$2}) {
2080 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
2083 warning("Possibly wrong #define $1 in $filename");
2087 for (qw(uses needs uses_todo needed_global needed_static)) {
2088 for $func (keys %{$file{$_}}) {
2089 push @{$global{$_}{$func}}, $filename;
2093 $files{$filename} = \%file;
2096 # Globally resolve NEED_'s
2098 for $need (keys %{$global{needs}}) {
2099 if (@{$global{needs}{$need}} > 1) {
2100 my @targets = @{$global{needs}{$need}};
2101 my @t = grep $files{$_}{needed_global}{$need}, @targets;
2102 @targets = @t if @t;
2103 @t = grep /\.xs$/i, @targets;
2104 @targets = @t if @t;
2105 my $target = shift @targets;
2106 $files{$target}{needs}{$need} = 'global';
2107 for (@{$global{needs}{$need}}) {
2108 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
2113 for $filename (@files) {
2114 exists $files{$filename} or next;
2116 info("=== Analyzing $filename ===");
2118 my %file = %{$files{$filename}};
2120 my $c = $file{code};
2122 for $func (sort keys %{$file{uses_Perl}}) {
2123 if ($API{$func}{varargs}) {
2124 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
2125 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
2127 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
2128 $file{changes} += $changes;
2132 warning("Uses Perl_$func instead of $func");
2133 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
2138 for $func (sort keys %{$file{uses_replace}}) {
2139 warning("Uses $func instead of $replace{$func}");
2140 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
2143 for $func (sort keys %{$file{uses}}) {
2144 next unless $file{uses}{$func}; # if it's only a dependency
2145 if (exists $file{uses_deps}{$func}) {
2146 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
2148 elsif (exists $replace{$func}) {
2149 warning("Uses $func instead of $replace{$func}");
2150 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
2158 for $func (sort keys %{$file{uses_todo}}) {
2159 warning("Uses $func, which may not be portable below perl ",
2160 format_version($API{$func}{todo}));
2163 for $func (sort keys %{$file{needed_static}}) {
2165 if (not exists $file{uses}{$func}) {
2166 $message = "No need to define NEED_$func if $func is never used";
2168 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
2169 $message = "No need to define NEED_$func when already needed globally";
2173 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
2177 for $func (sort keys %{$file{needed_global}}) {
2179 if (not exists $global{uses}{$func}) {
2180 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
2182 elsif (exists $file{needs}{$func}) {
2183 if ($file{needs}{$func} eq 'extern') {
2184 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
2186 elsif ($file{needs}{$func} eq 'static') {
2187 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
2192 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
2196 $file{needs_inc_ppport} = keys %{$file{uses}};
2198 if ($file{needs_inc_ppport}) {
2201 for $func (sort keys %{$file{needs}}) {
2202 my $type = $file{needs}{$func};
2203 next if $type eq 'extern';
2204 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
2205 unless (exists $file{"needed_$type"}{$func}) {
2206 if ($type eq 'global') {
2207 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
2210 diag("File needs $func, adding static request");
2212 $pp .= "#define NEED_$func$suffix\n";
2216 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
2221 unless ($file{has_inc_ppport}) {
2222 diag("Needs to include '$ppport'");
2223 $pp .= qq(#include "$ppport"\n)
2227 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
2228 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
2229 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
2230 || ($c =~ s/^/$pp/);
2234 if ($file{has_inc_ppport}) {
2235 diag("No need to include '$ppport'");
2236 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
2240 # put back in our C comments
2243 my @ccom = @{$file{ccom}};
2244 for $ix (0 .. $#ccom) {
2245 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
2247 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
2250 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
2255 my $s = $cppc != 1 ? 's' : '';
2256 warning("Uses $cppc C++ style comment$s, which is not portable");
2259 if ($file{changes}) {
2260 if (exists $opt{copy}) {
2261 my $newfile = "$filename$opt{copy}";
2263 error("'$newfile' already exists, refusing to write copy of '$filename'");
2267 if (open F, ">$newfile") {
2268 info("Writing copy of '$filename' with changes to '$newfile'");
2273 error("Cannot open '$newfile' for writing: $!");
2277 elsif (exists $opt{patch} || $opt{changes}) {
2278 if (exists $opt{patch}) {
2279 unless ($patch_opened) {
2280 if (open PATCH, ">$opt{patch}") {
2284 error("Cannot open '$opt{patch}' for writing: $!");
2290 mydiff(\*PATCH, $filename, $c);
2294 info("Suggested changes:");
2295 mydiff(\*STDOUT, $filename, $c);
2299 my $s = $file{changes} == 1 ? '' : 's';
2300 info("$file{changes} potentially required change$s detected");
2308 close PATCH if $patch_opened;
2316 my($file, $str) = @_;
2319 if (exists $opt{diff}) {
2320 $diff = run_diff($opt{diff}, $file, $str);
2323 if (!defined $diff and can_use('Text::Diff')) {
2324 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
2325 $diff = <<HEADER . $diff;
2331 if (!defined $diff) {
2332 $diff = run_diff('diff -u', $file, $str);
2335 if (!defined $diff) {
2336 $diff = run_diff('diff', $file, $str);
2339 if (!defined $diff) {
2340 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
2350 my($prog, $file, $str) = @_;
2351 my $tmp = 'dppptemp';
2356 while (-e "$tmp.$suf") { $suf++ }
2359 if (open F, ">$tmp") {
2363 if (open F, "$prog $file $tmp |") {
2365 s/\Q$tmp\E/$file.patched/;
2376 error("Cannot open '$tmp' for writing: $!");
2392 return () unless exists $depends{$func};
2393 grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
2400 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
2401 return ($1, $2, $3);
2403 elsif ($ver !~ /^\d+\.[\d_]+$/) {
2404 die "cannot parse version '$ver'\n";
2408 $ver =~ s/$/000000/;
2410 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
2415 if ($r < 5 || ($r == 5 && $v < 6)) {
2417 die "cannot parse version '$ver'\n";
2421 return ($r, $v, $s);
2428 $ver =~ s/$/000000/;
2429 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
2434 if ($r < 5 || ($r == 5 && $v < 6)) {
2436 die "invalid version '$ver'\n";
2440 $ver = sprintf "%d.%03d", $r, $v;
2441 $s > 0 and $ver .= sprintf "_%02d", $s;
2446 return sprintf "%d.%d.%d", $r, $v, $s;
2451 $opt{quiet} and return;
2457 $opt{quiet} and return;
2458 $opt{diag} and print @_, "\n";
2463 $opt{quiet} and return;
2464 print "*** ", @_, "\n";
2469 print "*** ERROR: ", @_, "\n";
2475 $opt{quiet} and return;
2476 $opt{hints} or return;
2478 exists $hints{$func} or return;
2479 $given_hints{$func}++ and return;
2480 my $hint = $hints{$func};
2482 print " --- hint for $func ---\n", $hint;
2487 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
2488 my %M = ( 'I' => '*' );
2489 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
2490 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
2496 See perldoc $0 for details.
2506 #ifndef _P_P_PORTABILITY_H_
2507 #define _P_P_PORTABILITY_H_
2509 #ifndef DPPP_NAMESPACE
2510 # define DPPP_NAMESPACE DPPP_
2513 #define DPPP_CAT2(x,y) CAT2(x,y)
2514 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
2516 #ifndef PERL_REVISION
2517 # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
2518 # define PERL_PATCHLEVEL_H_IMPLICIT
2519 # include <patchlevel.h>
2521 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
2522 # include <could_not_find_Perl_patchlevel.h>
2524 # ifndef PERL_REVISION
2525 # define PERL_REVISION (5)
2527 # define PERL_VERSION PATCHLEVEL
2528 # define PERL_SUBVERSION SUBVERSION
2529 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
2534 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
2536 /* It is very unlikely that anyone will try to use this with Perl 6
2537 (or greater), but who knows.
2539 #if PERL_REVISION != 5
2540 # error ppport.h only works with Perl version 5
2541 #endif /* PERL_REVISION != 5 */
2544 # include <limits.h>
2547 #ifndef PERL_UCHAR_MIN
2548 # define PERL_UCHAR_MIN ((unsigned char)0)
2551 #ifndef PERL_UCHAR_MAX
2553 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
2556 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
2558 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
2563 #ifndef PERL_USHORT_MIN
2564 # define PERL_USHORT_MIN ((unsigned short)0)
2567 #ifndef PERL_USHORT_MAX
2569 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
2572 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
2575 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
2577 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
2583 #ifndef PERL_SHORT_MAX
2585 # define PERL_SHORT_MAX ((short)SHORT_MAX)
2587 # ifdef MAXSHORT /* Often used in <values.h> */
2588 # define PERL_SHORT_MAX ((short)MAXSHORT)
2591 # define PERL_SHORT_MAX ((short)SHRT_MAX)
2593 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
2599 #ifndef PERL_SHORT_MIN
2601 # define PERL_SHORT_MIN ((short)SHORT_MIN)
2604 # define PERL_SHORT_MIN ((short)MINSHORT)
2607 # define PERL_SHORT_MIN ((short)SHRT_MIN)
2609 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
2615 #ifndef PERL_UINT_MAX
2617 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
2620 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
2622 # define PERL_UINT_MAX (~(unsigned int)0)
2627 #ifndef PERL_UINT_MIN
2628 # define PERL_UINT_MIN ((unsigned int)0)
2631 #ifndef PERL_INT_MAX
2633 # define PERL_INT_MAX ((int)INT_MAX)
2635 # ifdef MAXINT /* Often used in <values.h> */
2636 # define PERL_INT_MAX ((int)MAXINT)
2638 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
2643 #ifndef PERL_INT_MIN
2645 # define PERL_INT_MIN ((int)INT_MIN)
2648 # define PERL_INT_MIN ((int)MININT)
2650 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
2655 #ifndef PERL_ULONG_MAX
2657 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
2660 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
2662 # define PERL_ULONG_MAX (~(unsigned long)0)
2667 #ifndef PERL_ULONG_MIN
2668 # define PERL_ULONG_MIN ((unsigned long)0L)
2671 #ifndef PERL_LONG_MAX
2673 # define PERL_LONG_MAX ((long)LONG_MAX)
2676 # define PERL_LONG_MAX ((long)MAXLONG)
2678 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
2683 #ifndef PERL_LONG_MIN
2685 # define PERL_LONG_MIN ((long)LONG_MIN)
2688 # define PERL_LONG_MIN ((long)MINLONG)
2690 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
2695 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
2696 # ifndef PERL_UQUAD_MAX
2697 # ifdef ULONGLONG_MAX
2698 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
2700 # ifdef MAXULONGLONG
2701 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
2703 # define PERL_UQUAD_MAX (~(unsigned long long)0)
2708 # ifndef PERL_UQUAD_MIN
2709 # define PERL_UQUAD_MIN ((unsigned long long)0L)
2712 # ifndef PERL_QUAD_MAX
2713 # ifdef LONGLONG_MAX
2714 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
2717 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
2719 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
2724 # ifndef PERL_QUAD_MIN
2725 # ifdef LONGLONG_MIN
2726 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
2729 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
2731 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
2737 /* This is based on code from 5.003 perl.h */
2745 # define IV_MIN PERL_INT_MIN
2749 # define IV_MAX PERL_INT_MAX
2753 # define UV_MIN PERL_UINT_MIN
2757 # define UV_MAX PERL_UINT_MAX
2762 # define IVSIZE INTSIZE
2767 # if defined(convex) || defined(uts)
2769 # define IVTYPE long long
2773 # define IV_MIN PERL_QUAD_MIN
2777 # define IV_MAX PERL_QUAD_MAX
2781 # define UV_MIN PERL_UQUAD_MIN
2785 # define UV_MAX PERL_UQUAD_MAX
2788 # ifdef LONGLONGSIZE
2790 # define IVSIZE LONGLONGSIZE
2796 # define IVTYPE long
2800 # define IV_MIN PERL_LONG_MIN
2804 # define IV_MAX PERL_LONG_MAX
2808 # define UV_MIN PERL_ULONG_MIN
2812 # define UV_MAX PERL_ULONG_MAX
2817 # define IVSIZE LONGSIZE
2827 #ifndef PERL_QUAD_MIN
2828 # define PERL_QUAD_MIN IV_MIN
2831 #ifndef PERL_QUAD_MAX
2832 # define PERL_QUAD_MAX IV_MAX
2835 #ifndef PERL_UQUAD_MIN
2836 # define PERL_UQUAD_MIN UV_MIN
2839 #ifndef PERL_UQUAD_MAX
2840 # define PERL_UQUAD_MAX UV_MAX
2845 # define IVTYPE long
2849 # define IV_MIN PERL_LONG_MIN
2853 # define IV_MAX PERL_LONG_MAX
2857 # define UV_MIN PERL_ULONG_MIN
2861 # define UV_MAX PERL_ULONG_MAX
2868 # define IVSIZE LONGSIZE
2870 # define IVSIZE 4 /* A bold guess, but the best we can make. */
2874 # define UVTYPE unsigned IVTYPE
2878 # define UVSIZE IVSIZE
2882 # define sv_setuv(sv, uv) \
2885 if (TeMpUv <= IV_MAX) \
2886 sv_setiv(sv, TeMpUv); \
2888 sv_setnv(sv, (double)TeMpUv); \
2893 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
2896 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
2900 # define SvUVX(sv) ((UV)SvIVX(sv))
2904 # define SvUVXx(sv) SvUVX(sv)
2908 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
2912 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
2916 * Always use the SvUVx() macro instead of sv_uv().
2919 # define sv_uv(sv) SvUVx(sv)
2922 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
2926 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
2929 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
2933 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
2936 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
2938 # define PL_DBsingle DBsingle
2939 # define PL_DBsub DBsub
2941 # define PL_compiling compiling
2942 # define PL_copline copline
2943 # define PL_curcop curcop
2944 # define PL_curstash curstash
2945 # define PL_debstash debstash
2946 # define PL_defgv defgv
2947 # define PL_diehook diehook
2948 # define PL_dirty dirty
2949 # define PL_dowarn dowarn
2950 # define PL_errgv errgv
2951 # define PL_hexdigit hexdigit
2952 # define PL_hints hints
2954 # define PL_no_modify no_modify
2955 # define PL_perl_destruct_level perl_destruct_level
2956 # define PL_perldb perldb
2957 # define PL_ppaddr ppaddr
2958 # define PL_rsfp_filters rsfp_filters
2959 # define PL_rsfp rsfp
2960 # define PL_stack_base stack_base
2961 # define PL_stack_sp stack_sp
2962 # define PL_stdingv stdingv
2963 # define PL_sv_arenaroot sv_arenaroot
2964 # define PL_sv_no sv_no
2965 # define PL_sv_undef sv_undef
2966 # define PL_sv_yes sv_yes
2967 # define PL_tainted tainted
2968 # define PL_tainting tainting
2973 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
2974 # define PERL_UNUSED_DECL
2976 # define PERL_UNUSED_DECL __attribute__((unused))
2979 # define PERL_UNUSED_DECL
2982 # define NOOP (void)0
2986 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
2990 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
2991 # define NVTYPE long double
2993 # define NVTYPE double
3000 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
3002 # define INT2PTR(any,d) (any)(d)
3004 # if PTRSIZE == LONGSIZE
3005 # define PTRV unsigned long
3007 # define PTRV unsigned
3009 # define INT2PTR(any,d) (any)(PTRV)(d)
3012 # define NUM2PTR(any,d) (any)(PTRV)(d)
3013 # define PTR2IV(p) INT2PTR(IV,p)
3014 # define PTR2UV(p) INT2PTR(UV,p)
3015 # define PTR2NV(p) NUM2PTR(NV,p)
3017 # if PTRSIZE == LONGSIZE
3018 # define PTR2ul(p) (unsigned long)(p)
3020 # define PTR2ul(p) INT2PTR(unsigned long,p)
3023 #endif /* !INT2PTR */
3025 #undef START_EXTERN_C
3029 # define START_EXTERN_C extern "C" {
3030 # define END_EXTERN_C }
3031 # define EXTERN_C extern "C"
3033 # define START_EXTERN_C
3034 # define END_EXTERN_C
3035 # define EXTERN_C extern
3038 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
3039 # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
3040 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
3046 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
3047 # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
3050 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
3051 # define STMT_START if (1)
3052 # define STMT_END else (void)0
3054 # define STMT_START do
3055 # define STMT_END while (0)
3059 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
3062 /* DEFSV appears first in 5.004_56 */
3064 # define DEFSV GvSV(PL_defgv)
3068 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
3071 /* Older perls (<=5.003) lack AvFILLp */
3073 # define AvFILLp AvFILL
3076 # define ERRSV get_sv("@",FALSE)
3079 # define newSVpvn(data,len) ((data) \
3080 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
3084 /* Hint: gv_stashpvn
3085 * This function's backport doesn't support the length parameter, but
3086 * rather ignores it. Portability can only be ensured if the length
3087 * parameter is used for speed reasons, but the length can always be
3088 * correctly computed from the string argument.
3091 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
3096 # define get_cv perl_get_cv
3100 # define get_sv perl_get_sv
3104 # define get_av perl_get_av
3108 # define get_hv perl_get_hv
3115 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
3119 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
3124 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
3128 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
3133 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
3137 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
3142 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
3147 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
3152 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
3155 # define dUNDERBAR dNOOP
3159 # define UNDERBAR DEFSV
3162 # define dAX I32 ax = MARK - PL_stack_base + 1
3166 # define dITEMS I32 items = SP - MARK
3176 # define dTHXa(x) dNOOP
3194 # define dTHXoa(x) dTHXa(x)
3197 # define PUSHmortal PUSHs(sv_newmortal())
3201 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
3205 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
3209 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
3213 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
3216 # define XPUSHmortal XPUSHs(sv_newmortal())
3220 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
3224 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
3228 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
3232 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
3237 # define call_sv perl_call_sv
3241 # define call_pv perl_call_pv
3245 # define call_argv perl_call_argv
3249 # define call_method perl_call_method
3252 # define eval_sv perl_eval_sv
3257 /* Replace perl_eval_pv with eval_pv */
3258 /* eval_pv depends on eval_sv */
3261 #if defined(NEED_eval_pv)
3262 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
3265 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
3271 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
3272 #define Perl_eval_pv DPPP_(my_eval_pv)
3274 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
3277 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
3280 SV* sv = newSVpv(p, 0);
3283 eval_sv(sv, G_SCALAR);
3290 if (croak_on_error && SvTRUE(GvSV(errgv)))
3291 croak(SvPVx(GvSV(errgv), na));
3299 # define newRV_inc(sv) newRV(sv) /* Replace */
3303 #if defined(NEED_newRV_noinc)
3304 static SV * DPPP_(my_newRV_noinc)(SV *sv);
3307 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
3313 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
3314 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
3316 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
3318 DPPP_(my_newRV_noinc)(SV *sv)
3320 SV *rv = (SV *)newRV(sv);
3327 /* Hint: newCONSTSUB
3328 * Returns a CV* as of perl-5.7.1. This return value is not supported
3332 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
3333 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
3334 #if defined(NEED_newCONSTSUB)
3335 static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
3338 extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
3344 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
3345 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
3347 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
3350 DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
3352 U32 oldhints = PL_hints;
3353 HV *old_cop_stash = PL_curcop->cop_stash;
3354 HV *old_curstash = PL_curstash;
3355 line_t oldline = PL_curcop->cop_line;
3356 PL_curcop->cop_line = PL_copline;
3358 PL_hints &= ~HINT_BLOCK_SCOPE;
3360 PL_curstash = PL_curcop->cop_stash = stash;
3364 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
3366 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
3368 #else /* 5.003_23 onwards */
3369 start_subparse(FALSE, 0),
3372 newSVOP(OP_CONST, 0, newSVpv(name,0)),
3373 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
3374 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
3377 PL_hints = oldhints;
3378 PL_curcop->cop_stash = old_cop_stash;
3379 PL_curstash = old_curstash;
3380 PL_curcop->cop_line = oldline;
3386 * Boilerplate macros for initializing and accessing interpreter-local
3387 * data from C. All statics in extensions should be reworked to use
3388 * this, if you want to make the extension thread-safe. See ext/re/re.xs
3389 * for an example of the use of these macros.
3391 * Code that uses these macros is responsible for the following:
3392 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
3393 * 2. Declare a typedef named my_cxt_t that is a structure that contains
3394 * all the data that needs to be interpreter-local.
3395 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
3396 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
3397 * (typically put in the BOOT: section).
3398 * 5. Use the members of the my_cxt_t structure everywhere as
3400 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
3404 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
3405 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
3407 #ifndef START_MY_CXT
3409 /* This must appear in all extensions that define a my_cxt_t structure,
3410 * right after the definition (i.e. at file scope). The non-threads
3411 * case below uses it to declare the data as static. */
3412 #define START_MY_CXT
3414 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
3415 /* Fetches the SV that keeps the per-interpreter data. */
3416 #define dMY_CXT_SV \
3417 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
3418 #else /* >= perl5.004_68 */
3419 #define dMY_CXT_SV \
3420 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
3421 sizeof(MY_CXT_KEY)-1, TRUE)
3422 #endif /* < perl5.004_68 */
3424 /* This declaration should be used within all functions that use the
3425 * interpreter-local data. */
3428 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
3430 /* Creates and zeroes the per-interpreter data.
3431 * (We allocate my_cxtp in a Perl SV so that it will be released when
3432 * the interpreter goes away.) */
3433 #define MY_CXT_INIT \
3435 /* newSV() allocates one more than needed */ \
3436 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
3437 Zero(my_cxtp, 1, my_cxt_t); \
3438 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
3440 /* This macro must be used to access members of the my_cxt_t structure.
3441 * e.g. MYCXT.some_data */
3442 #define MY_CXT (*my_cxtp)
3444 /* Judicious use of these macros can reduce the number of times dMY_CXT
3445 * is used. Use is similar to pTHX, aTHX etc. */
3446 #define pMY_CXT my_cxt_t *my_cxtp
3447 #define pMY_CXT_ pMY_CXT,
3448 #define _pMY_CXT ,pMY_CXT
3449 #define aMY_CXT my_cxtp
3450 #define aMY_CXT_ aMY_CXT,
3451 #define _aMY_CXT ,aMY_CXT
3453 #endif /* START_MY_CXT */
3455 #ifndef MY_CXT_CLONE
3456 /* Clones the per-interpreter data. */
3457 #define MY_CXT_CLONE \
3459 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
3460 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
3461 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
3464 #else /* single interpreter */
3466 #ifndef START_MY_CXT
3468 #define START_MY_CXT static my_cxt_t my_cxt;
3469 #define dMY_CXT_SV dNOOP
3470 #define dMY_CXT dNOOP
3471 #define MY_CXT_INIT NOOP
3472 #define MY_CXT my_cxt
3474 #define pMY_CXT void
3481 #endif /* START_MY_CXT */
3483 #ifndef MY_CXT_CLONE
3484 #define MY_CXT_CLONE NOOP
3490 # if IVSIZE == LONGSIZE
3497 # if IVSIZE == INTSIZE
3508 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
3509 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
3510 # define NVef PERL_PRIeldbl
3511 # define NVff PERL_PRIfldbl
3512 # define NVgf PERL_PRIgldbl
3522 #if defined(NEED_sv_2pv_nolen)
3523 static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
3526 extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
3530 # undef sv_2pv_nolen
3532 #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
3533 #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
3535 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
3538 DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
3541 return sv_2pv(sv, &n_a);
3546 /* Hint: sv_2pv_nolen
3547 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
3550 /* SvPV_nolen depends on sv_2pv_nolen */
3551 #define SvPV_nolen(sv) \
3552 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
3553 ? SvPVX(sv) : sv_2pv_nolen(sv))
3560 * Does not work in perl-5.6.1, ppport.h implements a version
3561 * borrowed from perl-5.7.3.
3564 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
3566 #if defined(NEED_sv_2pvbyte)
3567 static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
3570 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
3576 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
3577 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
3579 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
3582 DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
3584 sv_utf8_downgrade(sv,0);
3585 return SvPV(sv,*lp);
3591 * Use the SvPVbyte() macro instead of sv_2pvbyte().
3596 /* SvPVbyte depends on sv_2pvbyte */
3597 #define SvPVbyte(sv, lp) \
3598 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
3599 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
3605 # define SvPVbyte SvPV
3606 # define sv_2pvbyte sv_2pv
3610 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
3611 #ifndef sv_2pvbyte_nolen
3612 # define sv_2pvbyte_nolen sv_2pv_nolen
3616 * Always use the SvPV() macro instead of sv_pvn().
3619 # define sv_pvn(sv, len) SvPV(sv, len)
3623 * Always use the SvPV_force() macro instead of sv_pvn_force().
3625 #ifndef sv_pvn_force
3626 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
3629 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
3630 #if defined(NEED_vnewSVpvf)
3631 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
3634 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
3640 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
3641 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
3643 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
3646 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
3648 register SV *sv = newSV(0);
3649 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3656 /* sv_vcatpvf depends on sv_vcatpvfn */
3657 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
3658 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
3661 /* sv_vsetpvf depends on sv_vsetpvfn */
3662 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
3663 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
3666 /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
3667 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
3668 #if defined(NEED_sv_catpvf_mg)
3669 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
3672 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
3675 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
3677 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
3680 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
3683 va_start(args, pat);
3684 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3692 /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
3693 #ifdef PERL_IMPLICIT_CONTEXT
3694 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
3695 #if defined(NEED_sv_catpvf_mg_nocontext)
3696 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
3699 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
3702 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
3703 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
3705 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
3708 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
3712 va_start(args, pat);
3713 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3722 #ifndef sv_catpvf_mg
3723 # ifdef PERL_IMPLICIT_CONTEXT
3724 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
3726 # define sv_catpvf_mg Perl_sv_catpvf_mg
3730 /* sv_vcatpvf_mg depends on sv_vcatpvfn */
3731 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
3732 # define sv_vcatpvf_mg(sv, pat, args) \
3734 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
3739 /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
3740 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
3741 #if defined(NEED_sv_setpvf_mg)
3742 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
3745 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
3748 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
3750 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
3753 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
3756 va_start(args, pat);
3757 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3765 /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
3766 #ifdef PERL_IMPLICIT_CONTEXT
3767 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
3768 #if defined(NEED_sv_setpvf_mg_nocontext)
3769 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
3772 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
3775 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
3776 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
3778 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
3781 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
3785 va_start(args, pat);
3786 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3795 #ifndef sv_setpvf_mg
3796 # ifdef PERL_IMPLICIT_CONTEXT
3797 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
3799 # define sv_setpvf_mg Perl_sv_setpvf_mg
3803 /* sv_vsetpvf_mg depends on sv_vsetpvfn */
3804 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
3805 # define sv_vsetpvf_mg(sv, pat, args) \
3807 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
3812 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
3814 #ifndef PERL_MAGIC_sv
3815 # define PERL_MAGIC_sv '\0'
3818 #ifndef PERL_MAGIC_overload
3819 # define PERL_MAGIC_overload 'A'
3822 #ifndef PERL_MAGIC_overload_elem
3823 # define PERL_MAGIC_overload_elem 'a'
3826 #ifndef PERL_MAGIC_overload_table
3827 # define PERL_MAGIC_overload_table 'c'
3830 #ifndef PERL_MAGIC_bm
3831 # define PERL_MAGIC_bm 'B'
3834 #ifndef PERL_MAGIC_regdata
3835 # define PERL_MAGIC_regdata 'D'
3838 #ifndef PERL_MAGIC_regdatum
3839 # define PERL_MAGIC_regdatum 'd'
3842 #ifndef PERL_MAGIC_env
3843 # define PERL_MAGIC_env 'E'
3846 #ifndef PERL_MAGIC_envelem
3847 # define PERL_MAGIC_envelem 'e'
3850 #ifndef PERL_MAGIC_fm
3851 # define PERL_MAGIC_fm 'f'
3854 #ifndef PERL_MAGIC_regex_global
3855 # define PERL_MAGIC_regex_global 'g'
3858 #ifndef PERL_MAGIC_isa
3859 # define PERL_MAGIC_isa 'I'
3862 #ifndef PERL_MAGIC_isaelem
3863 # define PERL_MAGIC_isaelem 'i'
3866 #ifndef PERL_MAGIC_nkeys
3867 # define PERL_MAGIC_nkeys 'k'
3870 #ifndef PERL_MAGIC_dbfile
3871 # define PERL_MAGIC_dbfile 'L'
3874 #ifndef PERL_MAGIC_dbline
3875 # define PERL_MAGIC_dbline 'l'
3878 #ifndef PERL_MAGIC_mutex
3879 # define PERL_MAGIC_mutex 'm'
3882 #ifndef PERL_MAGIC_shared
3883 # define PERL_MAGIC_shared 'N'
3886 #ifndef PERL_MAGIC_shared_scalar
3887 # define PERL_MAGIC_shared_scalar 'n'
3890 #ifndef PERL_MAGIC_collxfrm
3891 # define PERL_MAGIC_collxfrm 'o'
3894 #ifndef PERL_MAGIC_tied
3895 # define PERL_MAGIC_tied 'P'
3898 #ifndef PERL_MAGIC_tiedelem
3899 # define PERL_MAGIC_tiedelem 'p'
3902 #ifndef PERL_MAGIC_tiedscalar
3903 # define PERL_MAGIC_tiedscalar 'q'
3906 #ifndef PERL_MAGIC_qr
3907 # define PERL_MAGIC_qr 'r'
3910 #ifndef PERL_MAGIC_sig
3911 # define PERL_MAGIC_sig 'S'
3914 #ifndef PERL_MAGIC_sigelem
3915 # define PERL_MAGIC_sigelem 's'
3918 #ifndef PERL_MAGIC_taint
3919 # define PERL_MAGIC_taint 't'
3922 #ifndef PERL_MAGIC_uvar
3923 # define PERL_MAGIC_uvar 'U'
3926 #ifndef PERL_MAGIC_uvar_elem
3927 # define PERL_MAGIC_uvar_elem 'u'
3930 #ifndef PERL_MAGIC_vstring
3931 # define PERL_MAGIC_vstring 'V'
3934 #ifndef PERL_MAGIC_vec
3935 # define PERL_MAGIC_vec 'v'
3938 #ifndef PERL_MAGIC_utf8
3939 # define PERL_MAGIC_utf8 'w'
3942 #ifndef PERL_MAGIC_substr
3943 # define PERL_MAGIC_substr 'x'
3946 #ifndef PERL_MAGIC_defelem
3947 # define PERL_MAGIC_defelem 'y'
3950 #ifndef PERL_MAGIC_glob
3951 # define PERL_MAGIC_glob '*'
3954 #ifndef PERL_MAGIC_arylen
3955 # define PERL_MAGIC_arylen '#'
3958 #ifndef PERL_MAGIC_pos
3959 # define PERL_MAGIC_pos '.'
3962 #ifndef PERL_MAGIC_backref
3963 # define PERL_MAGIC_backref '<'
3966 #ifndef PERL_MAGIC_ext
3967 # define PERL_MAGIC_ext '~'
3970 /* That's the best we can do... */
3971 #ifndef SvPV_force_nomg
3972 # define SvPV_force_nomg SvPV_force
3976 # define SvPV_nomg SvPV
3979 #ifndef sv_catpvn_nomg
3980 # define sv_catpvn_nomg sv_catpvn
3983 #ifndef sv_catsv_nomg
3984 # define sv_catsv_nomg sv_catsv
3987 #ifndef sv_setsv_nomg
3988 # define sv_setsv_nomg sv_setsv
3992 # define sv_pvn_nomg sv_pvn
3996 # define SvIV_nomg SvIV
4000 # define SvUV_nomg SvUV
4004 # define sv_catpv_mg(sv, ptr) \
4007 sv_catpv(TeMpSv,ptr); \
4008 SvSETMAGIC(TeMpSv); \
4012 #ifndef sv_catpvn_mg
4013 # define sv_catpvn_mg(sv, ptr, len) \
4016 sv_catpvn(TeMpSv,ptr,len); \
4017 SvSETMAGIC(TeMpSv); \
4022 # define sv_catsv_mg(dsv, ssv) \
4025 sv_catsv(TeMpSv,ssv); \
4026 SvSETMAGIC(TeMpSv); \
4031 # define sv_setiv_mg(sv, i) \
4034 sv_setiv(TeMpSv,i); \
4035 SvSETMAGIC(TeMpSv); \
4040 # define sv_setnv_mg(sv, num) \
4043 sv_setnv(TeMpSv,num); \
4044 SvSETMAGIC(TeMpSv); \
4049 # define sv_setpv_mg(sv, ptr) \
4052 sv_setpv(TeMpSv,ptr); \
4053 SvSETMAGIC(TeMpSv); \
4057 #ifndef sv_setpvn_mg
4058 # define sv_setpvn_mg(sv, ptr, len) \
4061 sv_setpvn(TeMpSv,ptr,len); \
4062 SvSETMAGIC(TeMpSv); \
4067 # define sv_setsv_mg(dsv, ssv) \
4070 sv_setsv(TeMpSv,ssv); \
4071 SvSETMAGIC(TeMpSv); \
4076 # define sv_setuv_mg(sv, i) \
4079 sv_setuv(TeMpSv,i); \
4080 SvSETMAGIC(TeMpSv); \
4084 #ifndef sv_usepvn_mg
4085 # define sv_usepvn_mg(sv, ptr, len) \
4088 sv_usepvn(TeMpSv,ptr,len); \
4089 SvSETMAGIC(TeMpSv); \
4095 # define CopFILE(c) ((c)->cop_file)
4099 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
4103 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
4107 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
4111 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
4115 # define CopSTASHPV(c) ((c)->cop_stashpv)
4118 #ifndef CopSTASHPV_set
4119 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
4123 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
4126 #ifndef CopSTASH_set
4127 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
4131 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
4132 || (CopSTASHPV(c) && HvNAME(hv) \
4133 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
4138 # define CopFILEGV(c) ((c)->cop_filegv)
4141 #ifndef CopFILEGV_set
4142 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
4146 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
4150 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
4154 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
4158 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
4162 # define CopSTASH(c) ((c)->cop_stash)
4165 #ifndef CopSTASH_set
4166 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
4170 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
4173 #ifndef CopSTASHPV_set
4174 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
4178 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
4181 #endif /* USE_ITHREADS */
4182 #ifndef IN_PERL_COMPILETIME
4183 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
4186 #ifndef IN_LOCALE_RUNTIME
4187 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
4190 #ifndef IN_LOCALE_COMPILETIME
4191 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
4195 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
4197 #ifndef IS_NUMBER_IN_UV
4198 # define IS_NUMBER_IN_UV 0x01
4201 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
4202 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
4205 #ifndef IS_NUMBER_NOT_INT
4206 # define IS_NUMBER_NOT_INT 0x04
4209 #ifndef IS_NUMBER_NEG
4210 # define IS_NUMBER_NEG 0x08
4213 #ifndef IS_NUMBER_INFINITY
4214 # define IS_NUMBER_INFINITY 0x10
4217 #ifndef IS_NUMBER_NAN
4218 # define IS_NUMBER_NAN 0x20
4221 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
4222 #ifndef GROK_NUMERIC_RADIX
4223 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
4225 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
4226 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
4229 #ifndef PERL_SCAN_SILENT_ILLDIGIT
4230 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
4233 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
4234 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
4237 #ifndef PERL_SCAN_DISALLOW_PREFIX
4238 # define PERL_SCAN_DISALLOW_PREFIX 0x02
4241 #ifndef grok_numeric_radix
4242 #if defined(NEED_grok_numeric_radix)
4243 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
4246 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
4249 #ifdef grok_numeric_radix
4250 # undef grok_numeric_radix
4252 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
4253 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
4255 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
4257 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
4259 #ifdef USE_LOCALE_NUMERIC
4260 #ifdef PL_numeric_radix_sv
4261 if (PL_numeric_radix_sv && IN_LOCALE) {
4263 char* radix = SvPV(PL_numeric_radix_sv, len);
4264 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4270 /* older perls don't have PL_numeric_radix_sv so the radix
4271 * must manually be requested from locale.h
4274 dTHR; /* needed for older threaded perls */
4275 struct lconv *lc = localeconv();
4276 char *radix = lc->decimal_point;
4277 if (radix && IN_LOCALE) {
4278 STRLEN len = strlen(radix);
4279 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4284 #endif /* PERL_VERSION */
4285 #endif /* USE_LOCALE_NUMERIC */
4286 /* always try "." if numeric radix didn't match because
4287 * we may have data from different locales mixed */
4288 if (*sp < send && **sp == '.') {
4297 /* grok_number depends on grok_numeric_radix */
4300 #if defined(NEED_grok_number)
4301 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4304 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4310 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
4311 #define Perl_grok_number DPPP_(my_grok_number)
4313 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
4315 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
4318 const char *send = pv + len;
4319 const UV max_div_10 = UV_MAX / 10;
4320 const char max_mod_10 = UV_MAX % 10;
4325 while (s < send && isSPACE(*s))
4329 } else if (*s == '-') {
4331 numtype = IS_NUMBER_NEG;
4339 /* next must be digit or the radix separator or beginning of infinity */
4341 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
4343 UV value = *s - '0';
4344 /* This construction seems to be more optimiser friendly.
4345 (without it gcc does the isDIGIT test and the *s - '0' separately)
4346 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
4347 In theory the optimiser could deduce how far to unroll the loop
4348 before checking for overflow. */
4350 int digit = *s - '0';
4351 if (digit >= 0 && digit <= 9) {
4352 value = value * 10 + digit;
4355 if (digit >= 0 && digit <= 9) {
4356 value = value * 10 + digit;
4359 if (digit >= 0 && digit <= 9) {
4360 value = value * 10 + digit;
4363 if (digit >= 0 && digit <= 9) {
4364 value = value * 10 + digit;
4367 if (digit >= 0 && digit <= 9) {
4368 value = value * 10 + digit;
4371 if (digit >= 0 && digit <= 9) {
4372 value = value * 10 + digit;
4375 if (digit >= 0 && digit <= 9) {
4376 value = value * 10 + digit;
4379 if (digit >= 0 && digit <= 9) {
4380 value = value * 10 + digit;
4382 /* Now got 9 digits, so need to check
4383 each time for overflow. */
4385 while (digit >= 0 && digit <= 9
4386 && (value < max_div_10
4387 || (value == max_div_10
4388 && digit <= max_mod_10))) {
4389 value = value * 10 + digit;
4395 if (digit >= 0 && digit <= 9
4397 /* value overflowed.
4398 skip the remaining digits, don't
4399 worry about setting *valuep. */
4402 } while (s < send && isDIGIT(*s));
4404 IS_NUMBER_GREATER_THAN_UV_MAX;
4424 numtype |= IS_NUMBER_IN_UV;
4429 if (GROK_NUMERIC_RADIX(&s, send)) {
4430 numtype |= IS_NUMBER_NOT_INT;
4431 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
4435 else if (GROK_NUMERIC_RADIX(&s, send)) {
4436 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
4437 /* no digits before the radix means we need digits after it */
4438 if (s < send && isDIGIT(*s)) {
4441 } while (s < send && isDIGIT(*s));
4443 /* integer approximation is valid - it's 0. */
4449 } else if (*s == 'I' || *s == 'i') {
4450 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4451 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
4452 s++; if (s < send && (*s == 'I' || *s == 'i')) {
4453 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4454 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
4455 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
4456 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
4460 } else if (*s == 'N' || *s == 'n') {
4461 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
4462 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
4463 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
4470 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
4471 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
4472 } else if (sawnan) {
4473 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
4474 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
4475 } else if (s < send) {
4476 /* we can have an optional exponent part */
4477 if (*s == 'e' || *s == 'E') {
4478 /* The only flag we keep is sign. Blow away any "it's UV" */
4479 numtype &= IS_NUMBER_NEG;
4480 numtype |= IS_NUMBER_NOT_INT;
4482 if (s < send && (*s == '-' || *s == '+'))
4484 if (s < send && isDIGIT(*s)) {
4487 } while (s < send && isDIGIT(*s));
4493 while (s < send && isSPACE(*s))
4497 if (len == 10 && memEQ(pv, "0 but true", 10)) {
4500 return IS_NUMBER_IN_UV;
4508 * The grok_* routines have been modified to use warn() instead of
4509 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
4510 * which is why the stack variable has been renamed to 'xdigit'.
4514 #if defined(NEED_grok_bin)
4515 static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4518 extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4524 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
4525 #define Perl_grok_bin DPPP_(my_grok_bin)
4527 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
4529 DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
4531 const char *s = start;
4532 STRLEN len = *len_p;
4536 const UV max_div_2 = UV_MAX / 2;
4537 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4538 bool overflowed = FALSE;
4540 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
4541 /* strip off leading b or 0b.
4542 for compatibility silently suffer "b" and "0b" as valid binary
4549 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
4556 for (; len-- && *s; s++) {
4558 if (bit == '0' || bit == '1') {
4559 /* Write it in this wonky order with a goto to attempt to get the
4560 compiler to make the common case integer-only loop pretty tight.
4561 With gcc seems to be much straighter code than old scan_bin. */
4564 if (value <= max_div_2) {
4565 value = (value << 1) | (bit - '0');
4568 /* Bah. We're just overflowed. */
4569 warn("Integer overflow in binary number");
4571 value_nv = (NV) value;
4574 /* If an NV has not enough bits in its mantissa to
4575 * represent a UV this summing of small low-order numbers
4576 * is a waste of time (because the NV cannot preserve
4577 * the low-order bits anyway): we could just remember when
4578 * did we overflow and in the end just multiply value_nv by the
4580 value_nv += (NV)(bit - '0');
4583 if (bit == '_' && len && allow_underscores && (bit = s[1])
4584 && (bit == '0' || bit == '1'))
4590 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4591 warn("Illegal binary digit '%c' ignored", *s);
4595 if ( ( overflowed && value_nv > 4294967295.0)
4597 || (!overflowed && value > 0xffffffff )
4600 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
4607 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4616 #if defined(NEED_grok_hex)
4617 static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4620 extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4626 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
4627 #define Perl_grok_hex DPPP_(my_grok_hex)
4629 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
4631 DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
4633 const char *s = start;
4634 STRLEN len = *len_p;
4638 const UV max_div_16 = UV_MAX / 16;
4639 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4640 bool overflowed = FALSE;
4643 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
4644 /* strip off leading x or 0x.
4645 for compatibility silently suffer "x" and "0x" as valid hex numbers.
4652 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
4659 for (; len-- && *s; s++) {
4660 xdigit = strchr((char *) PL_hexdigit, *s);
4662 /* Write it in this wonky order with a goto to attempt to get the
4663 compiler to make the common case integer-only loop pretty tight.
4664 With gcc seems to be much straighter code than old scan_hex. */
4667 if (value <= max_div_16) {
4668 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
4671 warn("Integer overflow in hexadecimal number");
4673 value_nv = (NV) value;
4676 /* If an NV has not enough bits in its mantissa to
4677 * represent a UV this summing of small low-order numbers
4678 * is a waste of time (because the NV cannot preserve
4679 * the low-order bits anyway): we could just remember when
4680 * did we overflow and in the end just multiply value_nv by the
4681 * right amount of 16-tuples. */
4682 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
4685 if (*s == '_' && len && allow_underscores && s[1]
4686 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
4692 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4693 warn("Illegal hexadecimal digit '%c' ignored", *s);
4697 if ( ( overflowed && value_nv > 4294967295.0)
4699 || (!overflowed && value > 0xffffffff )
4702 warn("Hexadecimal number > 0xffffffff non-portable");
4709 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4718 #if defined(NEED_grok_oct)
4719 static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4722 extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
4728 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
4729 #define Perl_grok_oct DPPP_(my_grok_oct)
4731 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
4733 DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
4735 const char *s = start;
4736 STRLEN len = *len_p;
4740 const UV max_div_8 = UV_MAX / 8;
4741 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
4742 bool overflowed = FALSE;
4744 for (; len-- && *s; s++) {
4745 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
4746 out front allows slicker code. */
4747 int digit = *s - '0';
4748 if (digit >= 0 && digit <= 7) {
4749 /* Write it in this wonky order with a goto to attempt to get the
4750 compiler to make the common case integer-only loop pretty tight.
4754 if (value <= max_div_8) {
4755 value = (value << 3) | digit;
4758 /* Bah. We're just overflowed. */
4759 warn("Integer overflow in octal number");
4761 value_nv = (NV) value;
4764 /* If an NV has not enough bits in its mantissa to
4765 * represent a UV this summing of small low-order numbers
4766 * is a waste of time (because the NV cannot preserve
4767 * the low-order bits anyway): we could just remember when
4768 * did we overflow and in the end just multiply value_nv by the
4769 * right amount of 8-tuples. */
4770 value_nv += (NV)digit;
4773 if (digit == ('_' - '0') && len && allow_underscores
4774 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
4780 /* Allow \octal to work the DWIM way (that is, stop scanning
4781 * as soon as non-octal characters are seen, complain only iff
4782 * someone seems to want to use the digits eight and nine). */
4783 if (digit == 8 || digit == 9) {
4784 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
4785 warn("Illegal octal digit '%c' ignored", *s);
4790 if ( ( overflowed && value_nv > 4294967295.0)
4792 || (!overflowed && value > 0xffffffff )
4795 warn("Octal number > 037777777777 non-portable");
4802 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
4810 #endif /* _P_P_PORTABILITY_H_ */
4812 /* End of File ppport.h */