1 ################################################################################
3 # !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
5 ################################################################################
7 # Perl/Pollution/Portability
9 ################################################################################
13 # $Date: 2006/01/14 18:07:56 +0100 $
15 ################################################################################
17 # Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
18 # Version 2.x, Copyright (C) 2001, Paul Marquess.
19 # Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
21 # This program is free software; you can redistribute it and/or
22 # modify it under the same terms as Perl itself.
24 ################################################################################
28 Devel::PPPort - Perl/Pollution/Portability
32 Devel::PPPort::WriteFile(); # defaults to ./ppport.h
33 Devel::PPPort::WriteFile('someheader.h');
37 Perl's API has changed over time, gaining new features, new functions,
38 increasing its flexibility, and reducing the impact on the C namespace
39 environment (reduced pollution). The header file written by this module,
40 typically F<ppport.h>, attempts to bring some of the newer Perl API
41 features to older versions of Perl, so that you can worry less about
42 keeping track of old releases, but users can still reap the benefit.
44 C<Devel::PPPort> contains a single function, called C<WriteFile>. Its
45 only purpose is to write the F<ppport.h> C header file. This file
46 contains a series of macros and, if explicitly requested, functions that
47 allow XS modules to be built using older versions of Perl. Currently,
48 Perl versions from 5.003 to 5.9.3 are supported.
50 This module is used by C<h2xs> to write the file F<ppport.h>.
52 =head2 Why use ppport.h?
54 You should use F<ppport.h> in modern code so that your code will work
55 with the widest range of Perl interpreters possible, without significant
58 You should attempt older code to fully use F<ppport.h>, because the
59 reduced pollution of newer Perl versions is an important thing. It's so
60 important that the old polluting ways of original Perl modules will not be
61 supported very far into the future, and your module will almost certainly
62 break! By adapting to it now, you'll gain compatibility and a sense of
63 having done the electronic ecology some good.
65 =head2 How to use ppport.h
67 Don't direct the users of your module to download C<Devel::PPPort>.
68 They are most probably no XS writers. Also, don't make F<ppport.h>
69 optional. Rather, just take the most recent copy of F<ppport.h> that
70 you can find (e.g. by generating it with the latest C<Devel::PPPort>
71 release from CPAN), copy it into your project, adjust your project to
72 use it, and distribute the header along with your module.
74 =head2 Running ppport.h
76 But F<ppport.h> is more than just a C header. It's also a Perl script
77 that can check your source code. It will suggest hints and portability
78 notes, and can even make suggestions on how to change your code. You
79 can run it like any other Perl program:
81 perl ppport.h [options] [files]
83 It also has embedded documentation, so you can use
87 to find out more about how to use it.
93 C<WriteFile> takes one optional argument. When called with one
94 argument, it expects to be passed a filename. When called with
95 no arguments, it defaults to the filename F<ppport.h>.
97 The function returns a true value if the file was written successfully.
98 Otherwise it returns a false value.
102 F<ppport.h> supports Perl versions from 5.003 to 5.9.3
103 in threaded and non-threaded configurations.
105 =head2 Provided Perl compatibility API
107 The header file written by this module, typically F<ppport.h>, provides
108 access to the following elements of the Perl API that is not available
109 in older Perl releases:
166 IN_LOCALE_COMPILETIME
170 IS_NUMBER_GREATER_THAN_UV_MAX
208 PERL_GCC_BRACE_GROUPS_FORBIDDEN
230 PERL_MAGIC_overload_elem
231 PERL_MAGIC_overload_table
236 PERL_MAGIC_regex_global
238 PERL_MAGIC_shared_scalar
246 PERL_MAGIC_tiedscalar
255 PERL_SCAN_ALLOW_UNDERSCORES
256 PERL_SCAN_DISALLOW_PREFIX
257 PERL_SCAN_GREATER_THAN_UV_MAX
258 PERL_SCAN_SILENT_ILLDIGIT
261 PERL_SIGNALS_UNSAFE_FLAG
291 PL_perl_destruct_level
329 sv_catpvf_mg_nocontext
341 sv_setpvf_mg_nocontext
390 =head2 Perl API not supported by ppport.h
392 There is still a big part of the API not supported by F<ppport.h>.
393 Either because it doesn't make sense to back-port that part of the API,
394 or simply because it hasn't been implemented yet. Patches welcome!
396 Here's a list of the currently unsupported API, and also the version of
397 Perl below which it is unsupported:
422 is_utf8_string_loclen
447 hv_clear_placeholders
524 gv_fetchmeth_autoload
573 sv_utf8_upgrade_flags
590 sv_force_normal_flags
609 utf16_to_utf8_reversed
838 gv_fetchmethod_autoload
883 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
884 system or any of its tests fail, please use the CPAN Request Tracker
885 at L<http://rt.cpan.org/> to create a ticket for the module.
893 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
897 Version 2.x was ported to the Perl core by Paul Marquess.
901 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
907 Version 3.x, Copyright (C) 2004-2006, Marcus Holland-Moritz.
909 Version 2.x, Copyright (C) 2001, Paul Marquess.
911 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
913 This program is free software; you can redistribute it and/or
914 modify it under the same terms as Perl itself.
918 See L<h2xs>, L<ppport.h>.
922 package Devel::PPPort;
926 use vars qw($VERSION @ISA $data);
928 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
930 @ISA = qw(DynaLoader);
932 bootstrap Devel::PPPort;
936 $data = do { local $/; <DATA> };
938 my $pkg = 'Devel::PPPort';
939 $data =~ s/__PERL_VERSION__/$]/g;
940 $data =~ s/__VERSION__/$VERSION/g;
941 $data =~ s/__DATE__/$now/g;
942 $data =~ s/__PKG__/$pkg/g;
948 my $file = shift || 'ppport.h';
949 defined $data or _init_data();
951 $copy =~ s/\bppport\.h\b/$file/g;
953 open F, ">$file" or return undef;
967 ----------------------------------------------------------------------
969 ppport.h -- Perl/Pollution/Portability Version __VERSION__
971 Automatically created by __PKG__ running under
972 perl __PERL_VERSION__ on __DATE__.
974 Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
975 includes in parts/inc/ instead.
977 Use 'perldoc ppport.h' to view the documentation below.
979 ----------------------------------------------------------------------
987 |>ppport.h - Perl/Pollution/Portability version __VERSION__
991 |> perl ppport.h [options] [source files]
993 |> Searches current directory for files if no [source files] are given
995 |> --help show short help
997 |> --patch=file write one patch file with changes
998 |> --copy=suffix write changed copies with suffix
999 |> --diff=program use diff program and options
1001 |> --compat-version=version provide compatibility with Perl version
1002 |> --cplusplus accept C++ comments
1004 |> --quiet don't output anything except fatal errors
1005 |> --nodiag don't show diagnostics
1006 |> --nohints don't show hints
1007 |> --nochanges don't suggest changes
1008 |> --nofilter don't filter input files
1010 |> --strip strip all script and doc functionality from
1011 |> ppport.h (this, obviously, cannot be undone)
1013 |> --list-provided list provided API
1014 |> --list-unsupported list unsupported API
1015 |> --api-info=name show Perl API portability information
1017 |>=head1 COMPATIBILITY
1019 |>This version of F<ppport.h> is designed to support operation with Perl
1020 |>installations back to 5.003, and has been tested up to 5.9.3.
1026 |>Display a brief usage summary.
1028 |>=head2 --patch=I<file>
1030 |>If this option is given, a single patch file will be created if
1031 |>any changes are suggested. This requires a working diff program
1032 |>to be installed on your system.
1034 |>=head2 --copy=I<suffix>
1036 |>If this option is given, a copy of each file will be saved with
1037 |>the given suffix that contains the suggested changes. This does
1038 |>not require any external programs.
1040 |>If neither C<--patch> or C<--copy> are given, the default is to
1041 |>simply print the diffs for each file. This requires either
1042 |>C<Text::Diff> or a C<diff> program to be installed.
1044 |>=head2 --diff=I<program>
1046 |>Manually set the diff program and options to use. The default
1047 |>is to use C<Text::Diff>, when installed, and output unified
1050 |>=head2 --compat-version=I<version>
1052 |>Tell F<ppport.h> to check for compatibility with the given
1053 |>Perl version. The default is to check for compatibility with Perl
1054 |>version 5.003. You can use this option to reduce the output
1055 |>of F<ppport.h> if you intend to be backward compatible only
1056 |>down to a certain Perl version.
1058 |>=head2 --cplusplus
1060 |>Usually, F<ppport.h> will detect C++ style comments and
1061 |>replace them with C style comments for portability reasons.
1062 |>Using this option instructs F<ppport.h> to leave C++
1063 |>comments untouched.
1067 |>Be quiet. Don't print anything except fatal errors.
1071 |>Don't output any diagnostic messages. Only portability
1072 |>alerts will be printed.
1076 |>Don't output any hints. Hints often contain useful portability
1079 |>=head2 --nochanges
1081 |>Don't suggest any changes. Only give diagnostic output and hints
1082 |>unless these are also deactivated.
1086 |>Don't filter the list of input files. By default, files not looking
1087 |>like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
1091 |>Strip all script and documentation functionality from F<ppport.h>.
1092 |>This reduces the size of F<ppport.h> dramatically and may be useful
1093 |>if you want to include F<ppport.h> in smaller modules without
1094 |>increasing their distribution size too much.
1096 |>=head2 --list-provided
1098 |>Lists the API elements for which compatibility is provided by
1099 |>F<ppport.h>. Also lists if it must be explicitly requested,
1100 |>if it has dependencies, and if there are hints for it.
1102 |>=head2 --list-unsupported
1104 |>Lists the API elements that are known not to be supported by
1105 |>F<ppport.h> and below which version of Perl they probably
1106 |>won't be available or work.
1108 |>=head2 --api-info=I<name>
1110 |>Show portability information for API elements matching I<name>.
1111 |>If I<name> is surrounded by slashes, it is interpreted as a regular
1114 |>=head1 DESCRIPTION
1116 |>In order for a Perl extension (XS) module to be as portable as possible
1117 |>across differing versions of Perl itself, certain steps need to be taken.
1123 |>Including this header is the first major one. This alone will give you
1124 |>access to a large part of the Perl API that hasn't been available in
1125 |>earlier Perl releases. Use
1127 |> perl ppport.h --list-provided
1129 |>to see which API elements are provided by ppport.h.
1133 |>You should avoid using deprecated parts of the API. For example, using
1134 |>global Perl variables without the C<PL_> prefix is deprecated. Also,
1135 |>some API functions used to have a C<perl_> prefix. Using this form is
1136 |>also deprecated. You can safely use the supported API, as F<ppport.h>
1137 |>will provide wrappers for older Perl versions.
1141 |>If you use one of a few functions or variables that were not present in
1142 |>earlier versions of Perl, and that can't be provided using a macro, you
1143 |>have to explicitly request support for these functions by adding one or
1144 |>more C<#define>s in your source code before the inclusion of F<ppport.h>.
1146 |>These functions or variables will be marked C<explicit> in the list shown
1147 |>by C<--list-provided>.
1149 |>Depending on whether you module has a single or multiple files that
1150 |>use such functions or variables, you want either C<static> or global
1153 |>For a C<static> function or variable (used only in a single source
1156 |> #define NEED_function
1157 |> #define NEED_variable
1159 |>For a global function or variable (used in multiple source files),
1162 |> #define NEED_function_GLOBAL
1163 |> #define NEED_variable_GLOBAL
1165 |>Note that you mustn't have more than one global request for the
1166 |>same function or variable in your project.
1168 |> Function / Variable Static Request Global Request
1169 |> -----------------------------------------------------------------------------------------
1170 |> PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL
1171 |> eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
1172 |> grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
1173 |> grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
1174 |> grok_number() NEED_grok_number NEED_grok_number_GLOBAL
1175 |> grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
1176 |> grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
1177 |> newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
1178 |> newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
1179 |> sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
1180 |> sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
1181 |> sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
1182 |> sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
1183 |> sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
1184 |> sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
1185 |> vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
1187 |>To avoid namespace conflicts, you can change the namespace of the
1188 |>explicitly exported functions / variables using the C<DPPP_NAMESPACE>
1189 |>macro. Just C<#define> the macro before including C<ppport.h>:
1191 |> #define DPPP_NAMESPACE MyOwnNamespace_
1192 |> #include "ppport.h"
1194 |>The default namespace is C<DPPP_>.
1198 |>The good thing is that most of the above can be checked by running
1199 |>F<ppport.h> on your source code. See the next section for
1204 |>To verify whether F<ppport.h> is needed for your module, whether you
1205 |>should make any changes to your code, and whether any special defines
1206 |>should be used, F<ppport.h> can be run as a Perl script to check your
1207 |>source code. Simply say:
1211 |>The result will usually be a list of patches suggesting changes
1212 |>that should at least be acceptable, if not necessarily the most
1213 |>efficient solution, or a fix for all possible problems.
1215 |>If you know that your XS module uses features only available in
1216 |>newer Perl releases, if you're aware that it uses C++ comments,
1217 |>and if you want all suggestions as a single patch file, you could
1218 |>use something like this:
1220 |> perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
1222 |>If you only want your code to be scanned without any suggestions
1225 |> perl ppport.h --nochanges
1227 |>You can specify a different C<diff> program or options, using
1228 |>the C<--diff> option:
1230 |> perl ppport.h --diff='diff -C 10'
1232 |>This would output context diffs with 10 lines of context.
1234 |>To display portability information for the C<newSVpvn> function,
1237 |> perl ppport.h --api-info=newSVpvn
1239 |>Since the argument to C<--api-info> can be a regular expression,
1242 |> perl ppport.h --api-info=/_nomg$/
1244 |>to display portability information for all C<_nomg> functions or
1246 |> perl ppport.h --api-info=/./
1248 |>to display information for all known API elements.
1252 |>If this version of F<ppport.h> is causing failure during
1253 |>the compilation of this module, please check if newer versions
1254 |>of either this module or C<Devel::PPPort> are available on CPAN
1255 |>before sending a bug report.
1257 |>If F<ppport.h> was generated using the latest version of
1258 |>C<Devel::PPPort> and is causing failure of this module, please
1259 |>file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
1261 |>Please include the following information:
1267 |>The complete output from running "perl -V"
1275 |>The name and version of the module you were trying to build.
1279 |>A full log of the build that failed.
1283 |>Any other information that you think could be relevant.
1287 |>For the latest version of this code, please get the C<Devel::PPPort>
1292 |>Version 3.x, Copyright (c) 2004-2006, Marcus Holland-Moritz.
1294 |>Version 2.x, Copyright (C) 2001, Paul Marquess.
1296 |>Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
1298 |>This program is free software; you can redistribute it and/or
1299 |>modify it under the same terms as Perl itself.
1303 |>See L<Devel::PPPort>.
1319 my($ppport) = $0 =~ /([\w.]+)$/;
1320 my $LF = '(?:\r\n|[\r\n])'; # line feed
1321 my $HS = "[ \t]"; # horizontal whitespace
1324 require Getopt::Long;
1325 Getopt::Long::GetOptions(\%opt, qw(
1326 help quiet diag! filter! hints! changes! cplusplus strip
1327 patch=s copy=s diff=s compat-version=s
1328 list-provided list-unsupported api-info=s
1332 if ($@ and grep /^-/, @ARGV) {
1333 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
1334 die "Getopt::Long not found. Please don't use any options.\n";
1337 usage() if $opt{help};
1338 strip() if $opt{strip};
1340 if (exists $opt{'compat-version'}) {
1341 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
1343 die "Invalid version number format: '$opt{'compat-version'}'\n";
1345 die "Only Perl 5 is supported\n" if $r != 5;
1346 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
1347 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
1350 $opt{'compat-version'} = 5;
1353 # Never use C comments in this file!!!!!
1356 my $rccs = quotemeta $ccs;
1357 my $rcce = quotemeta $cce;
1359 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
1361 ($2 ? ( base => $2 ) : ()),
1362 ($3 ? ( todo => $3 ) : ()),
1363 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
1364 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
1365 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
1367 : die "invalid spec: $_" } qw(
1373 CopFILEAV|5.006000||p
1374 CopFILEGV_set|5.006000||p
1375 CopFILEGV|5.006000||p
1376 CopFILESV|5.006000||p
1377 CopFILE_set|5.006000||p
1379 CopSTASHPV_set|5.006000||p
1380 CopSTASHPV|5.006000||p
1381 CopSTASH_eq|5.006000||p
1382 CopSTASH_set|5.006000||p
1383 CopSTASH|5.006000||p
1390 END_EXTERN_C|5.005000||p
1394 EXTERN_C|5.005000||p
1399 GROK_NUMERIC_RADIX|5.007002||p
1409 HEf_SVKEY||5.004000|
1414 HeSVKEY_force||5.004000|
1415 HeSVKEY_set||5.004000|
1420 IN_LOCALE_COMPILETIME|5.007002||p
1421 IN_LOCALE_RUNTIME|5.007002||p
1422 IN_LOCALE|5.007002||p
1423 IN_PERL_COMPILETIME|5.008001||p
1424 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
1425 IS_NUMBER_INFINITY|5.007002||p
1426 IS_NUMBER_IN_UV|5.007002||p
1427 IS_NUMBER_NAN|5.007003||p
1428 IS_NUMBER_NEG|5.007002||p
1429 IS_NUMBER_NOT_INT|5.007002||p
1436 MULTICALL||5.009003|
1437 MY_CXT_CLONE|5.009002||p
1438 MY_CXT_INIT|5.007003||p
1460 PAD_COMPNAME_FLAGS|||
1461 PAD_COMPNAME_GEN_set|||
1463 PAD_COMPNAME_OURSTASH|||
1465 PAD_COMPNAME_TYPE|||
1466 PAD_RESTORE_LOCAL|||
1468 PAD_SAVE_SETNULLPAD|||
1470 PAD_SET_CUR_NOSAVE|||
1474 PERL_BCDVERSION|5.009003||p
1475 PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
1476 PERL_INT_MAX|5.004000||p
1477 PERL_INT_MIN|5.004000||p
1478 PERL_LONG_MAX|5.004000||p
1479 PERL_LONG_MIN|5.004000||p
1480 PERL_MAGIC_arylen|5.007002||p
1481 PERL_MAGIC_backref|5.007002||p
1482 PERL_MAGIC_bm|5.007002||p
1483 PERL_MAGIC_collxfrm|5.007002||p
1484 PERL_MAGIC_dbfile|5.007002||p
1485 PERL_MAGIC_dbline|5.007002||p
1486 PERL_MAGIC_defelem|5.007002||p
1487 PERL_MAGIC_envelem|5.007002||p
1488 PERL_MAGIC_env|5.007002||p
1489 PERL_MAGIC_ext|5.007002||p
1490 PERL_MAGIC_fm|5.007002||p
1491 PERL_MAGIC_glob|5.007002||p
1492 PERL_MAGIC_isaelem|5.007002||p
1493 PERL_MAGIC_isa|5.007002||p
1494 PERL_MAGIC_mutex|5.007002||p
1495 PERL_MAGIC_nkeys|5.007002||p
1496 PERL_MAGIC_overload_elem|5.007002||p
1497 PERL_MAGIC_overload_table|5.007002||p
1498 PERL_MAGIC_overload|5.007002||p
1499 PERL_MAGIC_pos|5.007002||p
1500 PERL_MAGIC_qr|5.007002||p
1501 PERL_MAGIC_regdata|5.007002||p
1502 PERL_MAGIC_regdatum|5.007002||p
1503 PERL_MAGIC_regex_global|5.007002||p
1504 PERL_MAGIC_shared_scalar|5.007003||p
1505 PERL_MAGIC_shared|5.007003||p
1506 PERL_MAGIC_sigelem|5.007002||p
1507 PERL_MAGIC_sig|5.007002||p
1508 PERL_MAGIC_substr|5.007002||p
1509 PERL_MAGIC_sv|5.007002||p
1510 PERL_MAGIC_taint|5.007002||p
1511 PERL_MAGIC_tiedelem|5.007002||p
1512 PERL_MAGIC_tiedscalar|5.007002||p
1513 PERL_MAGIC_tied|5.007002||p
1514 PERL_MAGIC_utf8|5.008001||p
1515 PERL_MAGIC_uvar_elem|5.007003||p
1516 PERL_MAGIC_uvar|5.007002||p
1517 PERL_MAGIC_vec|5.007002||p
1518 PERL_MAGIC_vstring|5.008001||p
1519 PERL_QUAD_MAX|5.004000||p
1520 PERL_QUAD_MIN|5.004000||p
1521 PERL_REVISION|5.006000||p
1522 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
1523 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
1524 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
1525 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
1526 PERL_SHORT_MAX|5.004000||p
1527 PERL_SHORT_MIN|5.004000||p
1528 PERL_SIGNALS_UNSAFE_FLAG|5.008001||p
1529 PERL_SUBVERSION|5.006000||p
1530 PERL_UCHAR_MAX|5.004000||p
1531 PERL_UCHAR_MIN|5.004000||p
1532 PERL_UINT_MAX|5.004000||p
1533 PERL_UINT_MIN|5.004000||p
1534 PERL_ULONG_MAX|5.004000||p
1535 PERL_ULONG_MIN|5.004000||p
1536 PERL_UNUSED_DECL|5.007002||p
1537 PERL_UQUAD_MAX|5.004000||p
1538 PERL_UQUAD_MIN|5.004000||p
1539 PERL_USHORT_MAX|5.004000||p
1540 PERL_USHORT_MIN|5.004000||p
1541 PERL_VERSION|5.006000||p
1546 PL_compiling|5.004050||p
1547 PL_copline|5.005000||p
1548 PL_curcop|5.004050||p
1549 PL_curstash|5.004050||p
1550 PL_debstash|5.004050||p
1551 PL_defgv|5.004050||p
1552 PL_diehook|5.004050||p
1553 PL_dirty|5.004050||p
1555 PL_errgv|5.004050||p
1556 PL_hexdigit|5.005000||p
1557 PL_hints|5.005000||p
1559 PL_modglobal||5.005000|n
1561 PL_no_modify|5.006000||p
1563 PL_perl_destruct_level|5.004050||p
1564 PL_perldb|5.004050||p
1565 PL_ppaddr|5.006000||p
1566 PL_rsfp_filters|5.004050||p
1569 PL_signals|5.008001||p
1570 PL_stack_base|5.004050||p
1571 PL_stack_sp|5.004050||p
1572 PL_stdingv|5.004050||p
1573 PL_sv_arenaroot|5.004050||p
1574 PL_sv_no|5.004050||pn
1575 PL_sv_undef|5.004050||pn
1576 PL_sv_yes|5.004050||pn
1577 PL_tainted|5.004050||p
1578 PL_tainting|5.004050||p
1579 POP_MULTICALL||5.009003|
1583 POPpbytex||5.007001|n
1593 PUSH_MULTICALL||5.009003|
1595 PUSHmortal|5.009002||p
1601 PerlIO_clearerr||5.007003|
1602 PerlIO_close||5.007003|
1603 PerlIO_eof||5.007003|
1604 PerlIO_error||5.007003|
1605 PerlIO_fileno||5.007003|
1606 PerlIO_fill||5.007003|
1607 PerlIO_flush||5.007003|
1608 PerlIO_get_base||5.007003|
1609 PerlIO_get_bufsiz||5.007003|
1610 PerlIO_get_cnt||5.007003|
1611 PerlIO_get_ptr||5.007003|
1612 PerlIO_read||5.007003|
1613 PerlIO_seek||5.007003|
1614 PerlIO_set_cnt||5.007003|
1615 PerlIO_set_ptrcnt||5.007003|
1616 PerlIO_setlinebuf||5.007003|
1617 PerlIO_stderr||5.007003|
1618 PerlIO_stdin||5.007003|
1619 PerlIO_stdout||5.007003|
1620 PerlIO_tell||5.007003|
1621 PerlIO_unread||5.007003|
1622 PerlIO_write||5.007003|
1631 SAVE_DEFSV|5.004050||p
1634 START_EXTERN_C|5.005000||p
1635 START_MY_CXT|5.007003||p
1653 SvGETMAGIC|5.004050||p
1656 SvIOK_notUV||5.006000|
1658 SvIOK_only_UV||5.006000|
1664 SvIV_nomg|5.009001||p
1668 SvIsCOW_shared_hash||5.008003|
1673 SvMAGIC_set|5.009003||p
1689 SvPOK_only_UTF8||5.006000|
1694 SvPVX_const|5.009003||p
1695 SvPVX_mutable|5.009003||p
1697 SvPV_force_nomg|5.007002||p
1699 SvPV_nolen|5.006000||p
1700 SvPV_nomg|5.007002||p
1702 SvPVbyte_force||5.009002|
1703 SvPVbyte_nolen||5.006000|
1704 SvPVbytex_force||5.006000|
1705 SvPVbytex||5.006000|
1706 SvPVbyte|5.006000||p
1707 SvPVutf8_force||5.006000|
1708 SvPVutf8_nolen||5.006000|
1709 SvPVutf8x_force||5.006000|
1710 SvPVutf8x||5.006000|
1720 SvRV_set|5.009003||p
1724 SvSTASH_set|5.009003|5.009003|p
1726 SvSetMagicSV_nosteal||5.004000|
1727 SvSetMagicSV||5.004000|
1728 SvSetSV_nosteal||5.004000|
1730 SvTAINTED_off||5.004000|
1731 SvTAINTED_on||5.004000|
1732 SvTAINTED||5.004000|
1739 SvUTF8_off||5.006000|
1740 SvUTF8_on||5.006000|
1744 SvUV_nomg|5.009001||p
1745 SvUV_set|5.009003||p
1750 UNDERBAR|5.009002||p
1757 XCPT_CATCH|5.009002||p
1758 XCPT_RETHROW|5.009002||p
1759 XCPT_TRY_END|5.009002||p
1760 XCPT_TRY_START|5.009002||p
1762 XPUSHmortal|5.009002||p
1773 XSRETURN_UV|5.008001||p
1783 XS_VERSION_BOOTCHECK|||
1785 XSprePUSH|5.006000||p
1789 _aMY_CXT|5.007003||p
1790 _pMY_CXT|5.007003||p
1791 aMY_CXT_|5.007003||p
1798 amagic_cmp_locale|||
1807 apply_attrs_string||5.006001|
1810 atfork_lock||5.007003|n
1811 atfork_unlock||5.007003|n
1812 av_arylen_p||5.009003|
1814 av_delete||5.006000|
1815 av_exists||5.006000|
1833 block_gimme||5.004000|
1837 boot_core_UNIVERSAL|||
1838 boot_core_xsutils|||
1839 bytes_from_utf8||5.007001|
1840 bytes_to_utf8||5.006001|
1842 call_argv|5.006000||p
1843 call_atexit||5.006000|
1846 call_list||5.004000|
1847 call_method|5.006000||p
1854 cast_ulong||5.006000|
1856 check_type_and_open|||
1914 croak_nocontext|||vn
1916 csighandler||5.009003|n
1917 custom_op_desc||5.007003|
1918 custom_op_name||5.007003|
1921 cv_const_sv||5.004000|
1931 dMULTICALL||5.009003|
1932 dMY_CXT_SV|5.007003||p
1941 dUNDERBAR|5.009002||p
1951 debprofdump||5.005000|
1953 debstackptrs||5.007003|
1960 despatch_signals||5.007001|
1971 do_binmode||5.004050|
1980 do_gv_dump||5.006000|
1981 do_gvgv_dump||5.006000|
1982 do_hv_dump||5.006000|
1987 do_magic_dump||5.006000|
1991 do_op_dump||5.006000|
1996 do_pmop_dump||5.006000|
2006 do_sv_dump||5.006000|
2009 do_trans_complex_utf8|||
2011 do_trans_count_utf8|||
2013 do_trans_simple_utf8|||
2025 doing_taint||5.008001|n
2040 dump_eval||5.006000|
2042 dump_form||5.006000|
2043 dump_indent||5.006000|v
2045 dump_packsubs||5.006000|
2048 dump_vindent||5.006000|
2055 fbm_compile||5.005000|
2056 fbm_instr||5.005000|
2058 feature_is_enabled|||
2067 find_rundefsvoffset||5.009002|
2081 fprintf_nocontext|||vn
2082 free_global_struct|||
2083 free_tied_hv_pool|||
2085 gen_constant_list|||
2087 get_context||5.006000|n
2096 get_op_descs||5.005000|
2097 get_op_names||5.005000|
2099 get_ppaddr||5.006000|
2102 getcwd_sv||5.007002|
2107 grok_bin|5.007003||p
2108 grok_hex|5.007003||p
2109 grok_number|5.007002||p
2110 grok_numeric_radix|5.007002||p
2111 grok_oct|5.007003||p
2117 gv_autoload4||5.004000|
2119 gv_const_sv||5.009003|
2121 gv_efullname3||5.004000|
2122 gv_efullname4||5.006001|
2126 gv_fetchmeth_autoload||5.007003|
2127 gv_fetchmethod_autoload||5.004000|
2130 gv_fetchpvn_flags||5.009002|
2132 gv_fetchsv||5.009002|
2133 gv_fullname3||5.004000|
2134 gv_fullname4||5.006001|
2136 gv_handler||5.007001|
2139 gv_stashpvn|5.006000||p
2146 hv_assert||5.009001|
2148 hv_backreferences_p|||
2149 hv_clear_placeholders||5.009001|
2151 hv_delayfree_ent||5.004000|
2153 hv_delete_ent||5.004000|
2155 hv_eiter_p||5.009003|
2156 hv_eiter_set||5.009003|
2157 hv_exists_ent||5.004000|
2160 hv_fetch_ent||5.004000|
2162 hv_free_ent||5.004000|
2164 hv_iterkeysv||5.004000|
2166 hv_iternext_flags||5.008000|
2171 hv_ksplit||5.004000|
2174 hv_name_set||5.009003|
2176 hv_placeholders_get||5.009003|
2177 hv_placeholders_p||5.009003|
2178 hv_placeholders_set||5.009003|
2179 hv_riter_p||5.009003|
2180 hv_riter_set||5.009003|
2181 hv_scalar||5.009001|
2182 hv_store_ent||5.004000|
2183 hv_store_flags||5.008000|
2186 ibcmp_locale||5.004000|
2187 ibcmp_utf8||5.007003|
2191 incpush_if_exists|||
2194 init_argv_symbols|||
2196 init_global_struct|||
2197 init_i18nl10n||5.006000|
2198 init_i18nl14n||5.006000|
2204 init_postdump_symbols|||
2205 init_predump_symbols|||
2206 init_stacks||5.005000|
2223 is_handle_constructor|||
2224 is_list_assignment|||
2225 is_lvalue_sub||5.007001|
2226 is_uni_alnum_lc||5.006000|
2227 is_uni_alnumc_lc||5.006000|
2228 is_uni_alnumc||5.006000|
2229 is_uni_alnum||5.006000|
2230 is_uni_alpha_lc||5.006000|
2231 is_uni_alpha||5.006000|
2232 is_uni_ascii_lc||5.006000|
2233 is_uni_ascii||5.006000|
2234 is_uni_cntrl_lc||5.006000|
2235 is_uni_cntrl||5.006000|
2236 is_uni_digit_lc||5.006000|
2237 is_uni_digit||5.006000|
2238 is_uni_graph_lc||5.006000|
2239 is_uni_graph||5.006000|
2240 is_uni_idfirst_lc||5.006000|
2241 is_uni_idfirst||5.006000|
2242 is_uni_lower_lc||5.006000|
2243 is_uni_lower||5.006000|
2244 is_uni_print_lc||5.006000|
2245 is_uni_print||5.006000|
2246 is_uni_punct_lc||5.006000|
2247 is_uni_punct||5.006000|
2248 is_uni_space_lc||5.006000|
2249 is_uni_space||5.006000|
2250 is_uni_upper_lc||5.006000|
2251 is_uni_upper||5.006000|
2252 is_uni_xdigit_lc||5.006000|
2253 is_uni_xdigit||5.006000|
2254 is_utf8_alnumc||5.006000|
2255 is_utf8_alnum||5.006000|
2256 is_utf8_alpha||5.006000|
2257 is_utf8_ascii||5.006000|
2258 is_utf8_char_slow|||
2259 is_utf8_char||5.006000|
2260 is_utf8_cntrl||5.006000|
2262 is_utf8_digit||5.006000|
2263 is_utf8_graph||5.006000|
2264 is_utf8_idcont||5.008000|
2265 is_utf8_idfirst||5.006000|
2266 is_utf8_lower||5.006000|
2267 is_utf8_mark||5.006000|
2268 is_utf8_print||5.006000|
2269 is_utf8_punct||5.006000|
2270 is_utf8_space||5.006000|
2271 is_utf8_string_loclen||5.009003|
2272 is_utf8_string_loc||5.008001|
2273 is_utf8_string||5.006001|
2274 is_utf8_upper||5.006000|
2275 is_utf8_xdigit||5.006000|
2287 load_module_nocontext|||vn
2288 load_module||5.006000|v
2291 looks_like_number|||
2301 magic_clear_all_env|||
2305 magic_dump||5.006000|
2307 magic_freearylen_p|||
2322 magic_killbackrefs|||
2327 magic_regdata_cnt|||
2328 magic_regdatum_get|||
2329 magic_regdatum_set|||
2331 magic_set_all_env|||
2335 magic_setcollxfrm|||
2362 matcher_matches_sv|||
2378 mg_length||5.005000|
2383 mini_mktime||5.007002|
2385 mode_from_discipline|||
2407 my_failure_exit||5.004000|
2408 my_fflush_all||5.006000|
2431 my_memcmp||5.004000|n
2434 my_pclose||5.004000|
2435 my_popen_list||5.007001|
2438 my_socketpair||5.007003|n
2439 my_sprintf||5.009003|vn
2441 my_strftime||5.007002|
2447 newANONATTRSUB||5.006000|
2452 newATTRSUB||5.006000|
2457 newCONSTSUB|5.006000||p
2462 newGIVENOP||5.009003|
2483 newRV_inc|5.004000||p
2484 newRV_noinc|5.006000||p
2494 newSVpvf_nocontext|||vn
2495 newSVpvf||5.004000|v
2496 newSVpvn_share||5.007001|
2497 newSVpvn|5.006000||p
2504 newWHENOP||5.009003|
2505 newWHILEOP||5.009003|
2506 newXSproto||5.006000|
2508 new_collate||5.006000|
2510 new_ctype||5.006000|
2513 new_numeric||5.006000|
2514 new_stackinfo||5.005000|
2515 new_version||5.009000|
2520 no_bareword_allowed|||
2524 nothreadhook||5.008000|
2536 op_refcnt_lock||5.009002|
2537 op_refcnt_unlock||5.009002|
2539 pMY_CXT_|5.007003||p
2552 pad_compname_type|||
2555 pad_fixup_inner_anons|||
2567 parse_unicode_opts|||
2571 perl_alloc_using|||n
2573 perl_clone_using|||n
2576 perl_destruct||5.007003|n
2578 perl_parse||5.006000|n
2582 pmop_dump||5.006000|
2590 printf_nocontext|||vn
2599 pv_display||5.006000|
2600 pv_uni_display||5.007003|
2604 re_intuit_start||5.006000|
2605 re_intuit_string||5.006000|
2609 reentrant_retry|||vn
2611 ref_array_or_hash|||
2619 regclass_swash||5.007003|
2625 regexec_flags||5.005000|
2631 reginitcolors||5.006000|
2650 require_pv||5.006000|
2655 rsignal_state||5.004000|
2659 runops_debug||5.005000|
2660 runops_standard||5.005000|
2665 safesyscalloc||5.006000|n
2666 safesysfree||5.006000|n
2667 safesysmalloc||5.006000|n
2668 safesysrealloc||5.006000|n
2673 save_aelem||5.004050|
2674 save_alloc||5.006000|
2677 save_bool||5.008001|
2680 save_destructor_x||5.006000|
2681 save_destructor||5.006000|
2685 save_generic_pvref||5.006001|
2686 save_generic_svref||5.005030|
2690 save_helem||5.004050|
2691 save_hints||5.005000|
2700 save_mortalizesv||5.007001|
2703 save_padsv||5.007001|
2705 save_re_context||5.006000|
2708 save_set_svflags||5.009000|
2709 save_shared_pvref||5.007003|
2712 save_threadsv||5.005000|
2713 save_vptr||5.006000|
2716 savesharedpv||5.007003|
2717 savestack_grow_cnt||5.008001|
2741 scan_version||5.009001|
2742 scan_vstring||5.008001|
2745 screaminstr||5.005000|
2749 set_context||5.006000|n
2751 set_numeric_local||5.006000|
2752 set_numeric_radix||5.006000|
2753 set_numeric_standard||5.006000|
2757 share_hek||5.004000|
2765 sortsv_flags||5.009003|
2770 start_subparse||5.004000|
2771 stashpv_hvname_match||5.009003|
2779 str_to_version||5.006000|
2792 sv_2iuv_non_preserve|||
2793 sv_2iv_flags||5.009001|
2797 sv_2pv_flags||5.007002|
2798 sv_2pv_nolen|5.006000||p
2800 sv_2pvbyte|5.006000||p
2801 sv_2pvutf8_nolen||5.006000|
2802 sv_2pvutf8||5.006000|
2804 sv_2uv_flags||5.009001|
2810 sv_cat_decode||5.008001|
2811 sv_catpv_mg|5.006000||p
2812 sv_catpvf_mg_nocontext|||pvn
2813 sv_catpvf_mg|5.006000|5.004000|pv
2814 sv_catpvf_nocontext|||vn
2815 sv_catpvf||5.004000|v
2816 sv_catpvn_flags||5.007002|
2817 sv_catpvn_mg|5.004050||p
2818 sv_catpvn_nomg|5.007002||p
2821 sv_catsv_flags||5.007002|
2822 sv_catsv_mg|5.004050||p
2823 sv_catsv_nomg|5.007002||p
2829 sv_cmp_locale||5.004000|
2832 sv_compile_2op||5.008001|
2833 sv_copypv||5.007003|
2836 sv_derived_from||5.004000|
2841 sv_force_normal_flags||5.007001|
2842 sv_force_normal||5.006000|
2855 sv_len_utf8||5.006000|
2857 sv_magicext||5.007003|
2863 sv_nolocking||5.007003|
2864 sv_nosharing||5.007003|
2865 sv_nounlocking||5.007003|
2868 sv_pos_b2u||5.006000|
2869 sv_pos_u2b||5.006000|
2870 sv_pvbyten_force||5.006000|
2871 sv_pvbyten||5.006000|
2872 sv_pvbyte||5.006000|
2873 sv_pvn_force_flags||5.007002|
2875 sv_pvn_nomg|5.007003||p
2877 sv_pvutf8n_force||5.006000|
2878 sv_pvutf8n||5.006000|
2879 sv_pvutf8||5.006000|
2881 sv_recode_to_utf8||5.007003|
2888 sv_rvweaken||5.006000|
2889 sv_setiv_mg|5.006000||p
2891 sv_setnv_mg|5.006000||p
2893 sv_setpv_mg|5.006000||p
2894 sv_setpvf_mg_nocontext|||pvn
2895 sv_setpvf_mg|5.006000|5.004000|pv
2896 sv_setpvf_nocontext|||vn
2897 sv_setpvf||5.004000|v
2898 sv_setpviv_mg||5.008001|
2899 sv_setpviv||5.008001|
2900 sv_setpvn_mg|5.006000||p
2907 sv_setref_uv||5.007001|
2909 sv_setsv_flags||5.007002|
2910 sv_setsv_mg|5.006000||p
2911 sv_setsv_nomg|5.007002||p
2913 sv_setuv_mg|5.006000||p
2914 sv_setuv|5.006000||p
2915 sv_tainted||5.004000|
2919 sv_uni_display||5.007003|
2921 sv_unref_flags||5.007001|
2923 sv_untaint||5.004000|
2925 sv_usepvn_mg|5.006000||p
2927 sv_utf8_decode||5.006000|
2928 sv_utf8_downgrade||5.006000|
2929 sv_utf8_encode||5.006000|
2930 sv_utf8_upgrade_flags||5.007002|
2931 sv_utf8_upgrade||5.007001|
2933 sv_vcatpvf_mg|5.006000|5.004000|p
2934 sv_vcatpvfn||5.004000|
2935 sv_vcatpvf|5.006000|5.004000|p
2936 sv_vsetpvf_mg|5.006000|5.004000|p
2937 sv_vsetpvfn||5.004000|
2938 sv_vsetpvf|5.006000|5.004000|p
2941 swash_fetch||5.007002|
2943 swash_init||5.006000|
2949 tmps_grow||5.006000|
2953 to_uni_fold||5.007003|
2954 to_uni_lower_lc||5.006000|
2955 to_uni_lower||5.007003|
2956 to_uni_title_lc||5.006000|
2957 to_uni_title||5.007003|
2958 to_uni_upper_lc||5.006000|
2959 to_uni_upper||5.007003|
2960 to_utf8_case||5.007003|
2961 to_utf8_fold||5.007003|
2962 to_utf8_lower||5.007003|
2964 to_utf8_title||5.007003|
2965 to_utf8_upper||5.007003|
2969 too_few_arguments|||
2970 too_many_arguments|||
2974 unpack_str||5.007003|
2975 unpackstring||5.008001|
2976 unshare_hek_or_pvn|||
2978 unsharepvn||5.004000|
2979 unwind_handler_stack|||
2980 upg_version||5.009000|
2982 utf16_to_utf8_reversed||5.006001|
2983 utf16_to_utf8||5.006001|
2984 utf8_distance||5.006000|
2986 utf8_length||5.007001|
2989 utf8_to_bytes||5.006001|
2990 utf8_to_uvchr||5.007001|
2991 utf8_to_uvuni||5.007001|
2993 utf8n_to_uvuni||5.007001|
2995 uvchr_to_utf8_flags||5.007003|
2997 uvuni_to_utf8_flags||5.007003|
2998 uvuni_to_utf8||5.007001|
3005 vdie_croak_common|||
3011 vload_module||5.006000|
3013 vnewSVpvf|5.006000|5.004000|p
3016 vstringify||5.009000|
3022 warner_nocontext|||vn
3035 if (exists $opt{'list-unsupported'}) {
3037 for $f (sort { lc $a cmp lc $b } keys %API) {
3038 next unless $API{$f}{todo};
3039 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
3044 # Scan for possible replacement candidates
3046 my(%replace, %need, %hints, %depends);
3052 if (m{^\s*\*\s(.*?)\s*$}) {
3053 $hints{$hint} ||= ''; # suppress warning with older perls
3054 $hints{$hint} .= "$1\n";
3060 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
3062 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
3063 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
3064 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
3065 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
3067 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
3068 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
3071 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
3074 if (exists $opt{'api-info'}) {
3077 my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
3078 for $f (sort { lc $a cmp lc $b } keys %API) {
3079 next unless $f =~ /$match/;
3080 print "\n=== $f ===\n\n";
3082 if ($API{$f}{base} || $API{$f}{todo}) {
3083 my $base = format_version($API{$f}{base} || $API{$f}{todo});
3084 print "Supported at least starting from perl-$base.\n";
3087 if ($API{$f}{provided}) {
3088 my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
3089 print "Support by $ppport provided back to perl-$todo.\n";
3090 print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
3091 print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
3092 print "$hints{$f}" if exists $hints{$f};
3096 print "No portability information available.\n";
3104 print "Found no API matching '$opt{'api-info'}'.\n";
3109 if (exists $opt{'list-provided'}) {
3111 for $f (sort { lc $a cmp lc $b } keys %API) {
3112 next unless $API{$f}{provided};
3114 push @flags, 'explicit' if exists $need{$f};
3115 push @flags, 'depend' if exists $depends{$f};
3116 push @flags, 'hint' if exists $hints{$f};
3117 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
3124 my @srcext = qw( xs c h cc cpp );
3125 my $srcext = join '|', @srcext;
3129 @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
3134 File::Find::find(sub {
3135 $File::Find::name =~ /\.($srcext)$/i
3136 and push @files, $File::Find::name;
3140 @files = map { glob "*.$_" } @srcext;
3144 if (!@ARGV || $opt{filter}) {
3146 my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
3148 my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
3149 push @{ $out ? \@out : \@in }, $_;
3151 if (@ARGV && @out) {
3152 warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
3158 die "No input files given!\n";
3161 my(%files, %global, %revreplace);
3162 %revreplace = reverse %replace;
3164 my $patch_opened = 0;
3166 for $filename (@files) {
3167 unless (open IN, "<$filename") {
3168 warn "Unable to read from $filename: $!\n";
3172 info("Scanning $filename ...");
3174 my $c = do { local $/; <IN> };
3177 my %file = (orig => $c, changes => 0);
3179 # temporarily remove C comments from the code
3185 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
3187 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
3191 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
3196 defined $2 and push @ccom, $2;
3197 defined $1 ? $1 : "$ccs$#ccom$cce";
3200 $file{ccom} = \@ccom;
3202 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
3206 for $func (keys %API) {
3208 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
3209 if ($c =~ /\b(?:Perl_)?($match)\b/) {
3210 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
3211 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
3212 if (exists $API{$func}{provided}) {
3213 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
3214 $file{uses}{$func}++;
3215 my @deps = rec_depend($func);
3217 $file{uses_deps}{$func} = \@deps;
3219 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
3222 for ($func, @deps) {
3223 if (exists $need{$_}) {
3224 $file{needs}{$_} = 'static';
3229 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
3230 if ($c =~ /\b$func\b/) {
3231 $file{uses_todo}{$func}++;
3237 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
3238 if (exists $need{$2}) {
3239 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
3242 warning("Possibly wrong #define $1 in $filename");
3246 for (qw(uses needs uses_todo needed_global needed_static)) {
3247 for $func (keys %{$file{$_}}) {
3248 push @{$global{$_}{$func}}, $filename;
3252 $files{$filename} = \%file;
3255 # Globally resolve NEED_'s
3257 for $need (keys %{$global{needs}}) {
3258 if (@{$global{needs}{$need}} > 1) {
3259 my @targets = @{$global{needs}{$need}};
3260 my @t = grep $files{$_}{needed_global}{$need}, @targets;
3261 @targets = @t if @t;
3262 @t = grep /\.xs$/i, @targets;
3263 @targets = @t if @t;
3264 my $target = shift @targets;
3265 $files{$target}{needs}{$need} = 'global';
3266 for (@{$global{needs}{$need}}) {
3267 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
3272 for $filename (@files) {
3273 exists $files{$filename} or next;
3275 info("=== Analyzing $filename ===");
3277 my %file = %{$files{$filename}};
3279 my $c = $file{code};
3281 for $func (sort keys %{$file{uses_Perl}}) {
3282 if ($API{$func}{varargs}) {
3283 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
3284 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
3286 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
3287 $file{changes} += $changes;
3291 warning("Uses Perl_$func instead of $func");
3292 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
3297 for $func (sort keys %{$file{uses_replace}}) {
3298 warning("Uses $func instead of $replace{$func}");
3299 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3302 for $func (sort keys %{$file{uses}}) {
3303 next unless $file{uses}{$func}; # if it's only a dependency
3304 if (exists $file{uses_deps}{$func}) {
3305 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
3307 elsif (exists $replace{$func}) {
3308 warning("Uses $func instead of $replace{$func}");
3309 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3317 for $func (sort keys %{$file{uses_todo}}) {
3318 warning("Uses $func, which may not be portable below perl ",
3319 format_version($API{$func}{todo}));
3322 for $func (sort keys %{$file{needed_static}}) {
3324 if (not exists $file{uses}{$func}) {
3325 $message = "No need to define NEED_$func if $func is never used";
3327 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
3328 $message = "No need to define NEED_$func when already needed globally";
3332 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
3336 for $func (sort keys %{$file{needed_global}}) {
3338 if (not exists $global{uses}{$func}) {
3339 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
3341 elsif (exists $file{needs}{$func}) {
3342 if ($file{needs}{$func} eq 'extern') {
3343 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
3345 elsif ($file{needs}{$func} eq 'static') {
3346 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
3351 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
3355 $file{needs_inc_ppport} = keys %{$file{uses}};
3357 if ($file{needs_inc_ppport}) {
3360 for $func (sort keys %{$file{needs}}) {
3361 my $type = $file{needs}{$func};
3362 next if $type eq 'extern';
3363 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
3364 unless (exists $file{"needed_$type"}{$func}) {
3365 if ($type eq 'global') {
3366 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
3369 diag("File needs $func, adding static request");
3371 $pp .= "#define NEED_$func$suffix\n";
3375 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
3380 unless ($file{has_inc_ppport}) {
3381 diag("Needs to include '$ppport'");
3382 $pp .= qq(#include "$ppport"\n)
3386 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
3387 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
3388 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
3389 || ($c =~ s/^/$pp/);
3393 if ($file{has_inc_ppport}) {
3394 diag("No need to include '$ppport'");
3395 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
3399 # put back in our C comments
3402 my @ccom = @{$file{ccom}};
3403 for $ix (0 .. $#ccom) {
3404 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
3406 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
3409 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
3414 my $s = $cppc != 1 ? 's' : '';
3415 warning("Uses $cppc C++ style comment$s, which is not portable");
3418 if ($file{changes}) {
3419 if (exists $opt{copy}) {
3420 my $newfile = "$filename$opt{copy}";
3422 error("'$newfile' already exists, refusing to write copy of '$filename'");
3426 if (open F, ">$newfile") {
3427 info("Writing copy of '$filename' with changes to '$newfile'");
3432 error("Cannot open '$newfile' for writing: $!");
3436 elsif (exists $opt{patch} || $opt{changes}) {
3437 if (exists $opt{patch}) {
3438 unless ($patch_opened) {
3439 if (open PATCH, ">$opt{patch}") {
3443 error("Cannot open '$opt{patch}' for writing: $!");
3449 mydiff(\*PATCH, $filename, $c);
3453 info("Suggested changes:");
3454 mydiff(\*STDOUT, $filename, $c);
3458 my $s = $file{changes} == 1 ? '' : 's';
3459 info("$file{changes} potentially required change$s detected");
3467 close PATCH if $patch_opened;
3475 my($file, $str) = @_;
3478 if (exists $opt{diff}) {
3479 $diff = run_diff($opt{diff}, $file, $str);
3482 if (!defined $diff and can_use('Text::Diff')) {
3483 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
3484 $diff = <<HEADER . $diff;
3490 if (!defined $diff) {
3491 $diff = run_diff('diff -u', $file, $str);
3494 if (!defined $diff) {
3495 $diff = run_diff('diff', $file, $str);
3498 if (!defined $diff) {
3499 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
3509 my($prog, $file, $str) = @_;
3510 my $tmp = 'dppptemp';
3515 while (-e "$tmp.$suf") { $suf++ }
3518 if (open F, ">$tmp") {
3522 if (open F, "$prog $file $tmp |") {
3524 s/\Q$tmp\E/$file.patched/;
3535 error("Cannot open '$tmp' for writing: $!");
3551 return () unless exists $depends{$func};
3552 grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
3559 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
3560 return ($1, $2, $3);
3562 elsif ($ver !~ /^\d+\.[\d_]+$/) {
3563 die "cannot parse version '$ver'\n";
3567 $ver =~ s/$/000000/;
3569 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3574 if ($r < 5 || ($r == 5 && $v < 6)) {
3576 die "cannot parse version '$ver'\n";
3580 return ($r, $v, $s);
3587 $ver =~ s/$/000000/;
3588 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3593 if ($r < 5 || ($r == 5 && $v < 6)) {
3595 die "invalid version '$ver'\n";
3599 $ver = sprintf "%d.%03d", $r, $v;
3600 $s > 0 and $ver .= sprintf "_%02d", $s;
3605 return sprintf "%d.%d.%d", $r, $v, $s;
3610 $opt{quiet} and return;
3616 $opt{quiet} and return;
3617 $opt{diag} and print @_, "\n";
3622 $opt{quiet} and return;
3623 print "*** ", @_, "\n";
3628 print "*** ERROR: ", @_, "\n";
3634 $opt{quiet} and return;
3635 $opt{hints} or return;
3637 exists $hints{$func} or return;
3638 $given_hints{$func}++ and return;
3639 my $hint = $hints{$func};
3641 print " --- hint for $func ---\n", $hint;
3646 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
3647 my %M = ( 'I' => '*' );
3648 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
3649 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
3655 See perldoc $0 for details.
3664 my $self = do { local(@ARGV,$/)=($0); <> };
3665 $self =~ s/^$HS+Do NOT edit.*?(?=^-)//ms;
3666 $self =~ s/^SKIP.*(?=^__DATA__)/SKIP
3667 if (\@ARGV && \$ARGV[0] eq '--unstrip') {
3668 eval { require Devel::PPPort };
3669 \$@ and die "Cannot require Devel::PPPort, please install.\\n";
3670 Devel::PPPort::WriteFile(\$0);
3675 Sorry, but this is a stripped version of \$0.
3677 To be able to use its original script and doc functionality,
3678 please try to regenerate this file using:
3685 open OUT, ">$0" or die "cannot strip $0: $!\n";
3694 #ifndef _P_P_PORTABILITY_H_
3695 #define _P_P_PORTABILITY_H_
3697 #ifndef DPPP_NAMESPACE
3698 # define DPPP_NAMESPACE DPPP_
3701 #define DPPP_CAT2(x,y) CAT2(x,y)
3702 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
3704 #ifndef PERL_REVISION
3705 # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
3706 # define PERL_PATCHLEVEL_H_IMPLICIT
3707 # include <patchlevel.h>
3709 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
3710 # include <could_not_find_Perl_patchlevel.h>
3712 # ifndef PERL_REVISION
3713 # define PERL_REVISION (5)
3715 # define PERL_VERSION PATCHLEVEL
3716 # define PERL_SUBVERSION SUBVERSION
3717 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
3722 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
3724 /* It is very unlikely that anyone will try to use this with Perl 6
3725 (or greater), but who knows.
3727 #if PERL_REVISION != 5
3728 # error ppport.h only works with Perl version 5
3729 #endif /* PERL_REVISION != 5 */
3732 # include <limits.h>
3735 #ifndef PERL_UCHAR_MIN
3736 # define PERL_UCHAR_MIN ((unsigned char)0)
3739 #ifndef PERL_UCHAR_MAX
3741 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
3744 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
3746 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
3751 #ifndef PERL_USHORT_MIN
3752 # define PERL_USHORT_MIN ((unsigned short)0)
3755 #ifndef PERL_USHORT_MAX
3757 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
3760 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
3763 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
3765 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
3771 #ifndef PERL_SHORT_MAX
3773 # define PERL_SHORT_MAX ((short)SHORT_MAX)
3775 # ifdef MAXSHORT /* Often used in <values.h> */
3776 # define PERL_SHORT_MAX ((short)MAXSHORT)
3779 # define PERL_SHORT_MAX ((short)SHRT_MAX)
3781 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
3787 #ifndef PERL_SHORT_MIN
3789 # define PERL_SHORT_MIN ((short)SHORT_MIN)
3792 # define PERL_SHORT_MIN ((short)MINSHORT)
3795 # define PERL_SHORT_MIN ((short)SHRT_MIN)
3797 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
3803 #ifndef PERL_UINT_MAX
3805 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
3808 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
3810 # define PERL_UINT_MAX (~(unsigned int)0)
3815 #ifndef PERL_UINT_MIN
3816 # define PERL_UINT_MIN ((unsigned int)0)
3819 #ifndef PERL_INT_MAX
3821 # define PERL_INT_MAX ((int)INT_MAX)
3823 # ifdef MAXINT /* Often used in <values.h> */
3824 # define PERL_INT_MAX ((int)MAXINT)
3826 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
3831 #ifndef PERL_INT_MIN
3833 # define PERL_INT_MIN ((int)INT_MIN)
3836 # define PERL_INT_MIN ((int)MININT)
3838 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
3843 #ifndef PERL_ULONG_MAX
3845 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
3848 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
3850 # define PERL_ULONG_MAX (~(unsigned long)0)
3855 #ifndef PERL_ULONG_MIN
3856 # define PERL_ULONG_MIN ((unsigned long)0L)
3859 #ifndef PERL_LONG_MAX
3861 # define PERL_LONG_MAX ((long)LONG_MAX)
3864 # define PERL_LONG_MAX ((long)MAXLONG)
3866 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
3871 #ifndef PERL_LONG_MIN
3873 # define PERL_LONG_MIN ((long)LONG_MIN)
3876 # define PERL_LONG_MIN ((long)MINLONG)
3878 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
3883 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
3884 # ifndef PERL_UQUAD_MAX
3885 # ifdef ULONGLONG_MAX
3886 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
3888 # ifdef MAXULONGLONG
3889 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
3891 # define PERL_UQUAD_MAX (~(unsigned long long)0)
3896 # ifndef PERL_UQUAD_MIN
3897 # define PERL_UQUAD_MIN ((unsigned long long)0L)
3900 # ifndef PERL_QUAD_MAX
3901 # ifdef LONGLONG_MAX
3902 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
3905 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
3907 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
3912 # ifndef PERL_QUAD_MIN
3913 # ifdef LONGLONG_MIN
3914 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
3917 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
3919 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
3925 /* This is based on code from 5.003 perl.h */
3933 # define IV_MIN PERL_INT_MIN
3937 # define IV_MAX PERL_INT_MAX
3941 # define UV_MIN PERL_UINT_MIN
3945 # define UV_MAX PERL_UINT_MAX
3950 # define IVSIZE INTSIZE
3955 # if defined(convex) || defined(uts)
3957 # define IVTYPE long long
3961 # define IV_MIN PERL_QUAD_MIN
3965 # define IV_MAX PERL_QUAD_MAX
3969 # define UV_MIN PERL_UQUAD_MIN
3973 # define UV_MAX PERL_UQUAD_MAX
3976 # ifdef LONGLONGSIZE
3978 # define IVSIZE LONGLONGSIZE
3984 # define IVTYPE long
3988 # define IV_MIN PERL_LONG_MIN
3992 # define IV_MAX PERL_LONG_MAX
3996 # define UV_MIN PERL_ULONG_MIN
4000 # define UV_MAX PERL_ULONG_MAX
4005 # define IVSIZE LONGSIZE
4015 #ifndef PERL_QUAD_MIN
4016 # define PERL_QUAD_MIN IV_MIN
4019 #ifndef PERL_QUAD_MAX
4020 # define PERL_QUAD_MAX IV_MAX
4023 #ifndef PERL_UQUAD_MIN
4024 # define PERL_UQUAD_MIN UV_MIN
4027 #ifndef PERL_UQUAD_MAX
4028 # define PERL_UQUAD_MAX UV_MAX
4033 # define IVTYPE long
4037 # define IV_MIN PERL_LONG_MIN
4041 # define IV_MAX PERL_LONG_MAX
4045 # define UV_MIN PERL_ULONG_MIN
4049 # define UV_MAX PERL_ULONG_MAX
4056 # define IVSIZE LONGSIZE
4058 # define IVSIZE 4 /* A bold guess, but the best we can make. */
4062 # define UVTYPE unsigned IVTYPE
4066 # define UVSIZE IVSIZE
4069 # define sv_setuv(sv, uv) \
4072 if (TeMpUv <= IV_MAX) \
4073 sv_setiv(sv, TeMpUv); \
4075 sv_setnv(sv, (double)TeMpUv); \
4079 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
4082 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
4086 # define SvUVX(sv) ((UV)SvIVX(sv))
4090 # define SvUVXx(sv) SvUVX(sv)
4094 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
4098 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
4102 * Always use the SvUVx() macro instead of sv_uv().
4105 # define sv_uv(sv) SvUVx(sv)
4108 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
4112 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
4115 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
4119 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
4124 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
4128 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
4133 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
4137 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
4142 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
4146 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
4151 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
4156 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d)
4161 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
4164 # define Newx(v,n,t) New(0,v,n,t)
4168 # define Newxc(v,n,t,c) Newc(0,v,n,t,c)
4172 # define Newxz(v,n,t) Newz(0,v,n,t)
4175 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5)))
4177 # define PL_DBsingle DBsingle
4178 # define PL_DBsub DBsub
4180 # define PL_compiling compiling
4181 # define PL_copline copline
4182 # define PL_curcop curcop
4183 # define PL_curstash curstash
4184 # define PL_debstash debstash
4185 # define PL_defgv defgv
4186 # define PL_diehook diehook
4187 # define PL_dirty dirty
4188 # define PL_dowarn dowarn
4189 # define PL_errgv errgv
4190 # define PL_hexdigit hexdigit
4191 # define PL_hints hints
4193 # define PL_no_modify no_modify
4194 # define PL_perl_destruct_level perl_destruct_level
4195 # define PL_perldb perldb
4196 # define PL_ppaddr ppaddr
4197 # define PL_rsfp_filters rsfp_filters
4198 # define PL_rsfp rsfp
4199 # define PL_stack_base stack_base
4200 # define PL_stack_sp stack_sp
4201 # define PL_stdingv stdingv
4202 # define PL_sv_arenaroot sv_arenaroot
4203 # define PL_sv_no sv_no
4204 # define PL_sv_undef sv_undef
4205 # define PL_sv_yes sv_yes
4206 # define PL_tainted tainted
4207 # define PL_tainting tainting
4211 #ifndef PERL_UNUSED_DECL
4212 # ifdef HASATTRIBUTE
4213 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
4214 # define PERL_UNUSED_DECL
4216 # define PERL_UNUSED_DECL __attribute__((unused))
4219 # define PERL_UNUSED_DECL
4223 # define NOOP (void)0
4227 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
4231 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
4232 # define NVTYPE long double
4234 # define NVTYPE double
4241 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
4243 # define INT2PTR(any,d) (any)(d)
4245 # if PTRSIZE == LONGSIZE
4246 # define PTRV unsigned long
4248 # define PTRV unsigned
4250 # define INT2PTR(any,d) (any)(PTRV)(d)
4253 # define NUM2PTR(any,d) (any)(PTRV)(d)
4254 # define PTR2IV(p) INT2PTR(IV,p)
4255 # define PTR2UV(p) INT2PTR(UV,p)
4256 # define PTR2NV(p) NUM2PTR(NV,p)
4258 # if PTRSIZE == LONGSIZE
4259 # define PTR2ul(p) (unsigned long)(p)
4261 # define PTR2ul(p) INT2PTR(unsigned long,p)
4264 #endif /* !INT2PTR */
4266 #undef START_EXTERN_C
4270 # define START_EXTERN_C extern "C" {
4271 # define END_EXTERN_C }
4272 # define EXTERN_C extern "C"
4274 # define START_EXTERN_C
4275 # define END_EXTERN_C
4276 # define EXTERN_C extern
4279 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
4280 # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
4281 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
4287 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
4288 # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
4291 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
4292 # define STMT_START if (1)
4293 # define STMT_END else (void)0
4295 # define STMT_START do
4296 # define STMT_END while (0)
4300 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
4303 /* DEFSV appears first in 5.004_56 */
4305 # define DEFSV GvSV(PL_defgv)
4309 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
4312 /* Older perls (<=5.003) lack AvFILLp */
4314 # define AvFILLp AvFILL
4317 # define ERRSV get_sv("@",FALSE)
4320 # define newSVpvn(data,len) ((data) \
4321 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
4325 /* Hint: gv_stashpvn
4326 * This function's backport doesn't support the length parameter, but
4327 * rather ignores it. Portability can only be ensured if the length
4328 * parameter is used for speed reasons, but the length can always be
4329 * correctly computed from the string argument.
4332 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
4337 # define get_cv perl_get_cv
4341 # define get_sv perl_get_sv
4345 # define get_av perl_get_av
4349 # define get_hv perl_get_hv
4354 # define dUNDERBAR dNOOP
4358 # define UNDERBAR DEFSV
4361 # define dAX I32 ax = MARK - PL_stack_base + 1
4365 # define dITEMS I32 items = SP - MARK
4368 # define dXSTARG SV * targ = sv_newmortal()
4371 # define dAXMARK I32 ax = POPMARK; \
4372 register SV ** const mark = PL_stack_base + ax++
4375 # define XSprePUSH (sp = PL_stack_base + ax - 1)
4378 #if ((PERL_VERSION < 5) || ((PERL_VERSION == 5) && (PERL_SUBVERSION < 0)))
4380 # define XSRETURN(off) \
4382 PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
4387 #ifndef PERL_SIGNALS_UNSAFE_FLAG
4389 #define PERL_SIGNALS_UNSAFE_FLAG 0x0001
4391 #if defined(NEED_PL_signals)
4392 static U32 DPPP_(my_PL_signals) = PERL_SIGNALS_UNSAFE_FLAG;
4393 #elif defined(NEED_PL_signals_GLOBAL)
4394 U32 DPPP_(my_PL_signals) = PERL_SIGNALS_UNSAFE_FLAG;
4396 extern U32 DPPP_(my_PL_signals);
4398 #define PL_signals DPPP_(my_PL_signals)
4409 # define dTHXa(x) dNOOP
4427 # define dTHXoa(x) dTHXa(x)
4430 # define PUSHmortal PUSHs(sv_newmortal())
4434 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
4438 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
4442 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
4446 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
4449 # define XPUSHmortal XPUSHs(sv_newmortal())
4453 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
4457 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
4461 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
4465 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
4470 # define call_sv perl_call_sv
4474 # define call_pv perl_call_pv
4478 # define call_argv perl_call_argv
4482 # define call_method perl_call_method
4485 # define eval_sv perl_eval_sv
4490 /* Replace perl_eval_pv with eval_pv */
4491 /* eval_pv depends on eval_sv */
4494 #if defined(NEED_eval_pv)
4495 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4498 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4504 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
4505 #define Perl_eval_pv DPPP_(my_eval_pv)
4507 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
4510 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
4513 SV* sv = newSVpv(p, 0);
4516 eval_sv(sv, G_SCALAR);
4523 if (croak_on_error && SvTRUE(GvSV(errgv)))
4524 croak(SvPVx(GvSV(errgv), na));
4532 # define newRV_inc(sv) newRV(sv) /* Replace */
4536 #if defined(NEED_newRV_noinc)
4537 static SV * DPPP_(my_newRV_noinc)(SV *sv);
4540 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
4546 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
4547 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
4549 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
4551 DPPP_(my_newRV_noinc)(SV *sv)
4553 SV *rv = (SV *)newRV(sv);
4560 /* Hint: newCONSTSUB
4561 * Returns a CV* as of perl-5.7.1. This return value is not supported
4565 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
4566 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
4567 #if defined(NEED_newCONSTSUB)
4568 static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4571 extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4577 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
4578 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
4580 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
4583 DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
4585 U32 oldhints = PL_hints;
4586 HV *old_cop_stash = PL_curcop->cop_stash;
4587 HV *old_curstash = PL_curstash;
4588 line_t oldline = PL_curcop->cop_line;
4589 PL_curcop->cop_line = PL_copline;
4591 PL_hints &= ~HINT_BLOCK_SCOPE;
4593 PL_curstash = PL_curcop->cop_stash = stash;
4597 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
4599 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
4601 #else /* 5.003_23 onwards */
4602 start_subparse(FALSE, 0),
4605 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4606 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4607 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4610 PL_hints = oldhints;
4611 PL_curcop->cop_stash = old_cop_stash;
4612 PL_curstash = old_curstash;
4613 PL_curcop->cop_line = oldline;
4619 * Boilerplate macros for initializing and accessing interpreter-local
4620 * data from C. All statics in extensions should be reworked to use
4621 * this, if you want to make the extension thread-safe. See ext/re/re.xs
4622 * for an example of the use of these macros.
4624 * Code that uses these macros is responsible for the following:
4625 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
4626 * 2. Declare a typedef named my_cxt_t that is a structure that contains
4627 * all the data that needs to be interpreter-local.
4628 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
4629 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
4630 * (typically put in the BOOT: section).
4631 * 5. Use the members of the my_cxt_t structure everywhere as
4633 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
4637 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
4638 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
4640 #ifndef START_MY_CXT
4642 /* This must appear in all extensions that define a my_cxt_t structure,
4643 * right after the definition (i.e. at file scope). The non-threads
4644 * case below uses it to declare the data as static. */
4645 #define START_MY_CXT
4647 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 68)))
4648 /* Fetches the SV that keeps the per-interpreter data. */
4649 #define dMY_CXT_SV \
4650 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
4651 #else /* >= perl5.004_68 */
4652 #define dMY_CXT_SV \
4653 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
4654 sizeof(MY_CXT_KEY)-1, TRUE)
4655 #endif /* < perl5.004_68 */
4657 /* This declaration should be used within all functions that use the
4658 * interpreter-local data. */
4661 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
4663 /* Creates and zeroes the per-interpreter data.
4664 * (We allocate my_cxtp in a Perl SV so that it will be released when
4665 * the interpreter goes away.) */
4666 #define MY_CXT_INIT \
4668 /* newSV() allocates one more than needed */ \
4669 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4670 Zero(my_cxtp, 1, my_cxt_t); \
4671 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4673 /* This macro must be used to access members of the my_cxt_t structure.
4674 * e.g. MYCXT.some_data */
4675 #define MY_CXT (*my_cxtp)
4677 /* Judicious use of these macros can reduce the number of times dMY_CXT
4678 * is used. Use is similar to pTHX, aTHX etc. */
4679 #define pMY_CXT my_cxt_t *my_cxtp
4680 #define pMY_CXT_ pMY_CXT,
4681 #define _pMY_CXT ,pMY_CXT
4682 #define aMY_CXT my_cxtp
4683 #define aMY_CXT_ aMY_CXT,
4684 #define _aMY_CXT ,aMY_CXT
4686 #endif /* START_MY_CXT */
4688 #ifndef MY_CXT_CLONE
4689 /* Clones the per-interpreter data. */
4690 #define MY_CXT_CLONE \
4692 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4693 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
4694 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4697 #else /* single interpreter */
4699 #ifndef START_MY_CXT
4701 #define START_MY_CXT static my_cxt_t my_cxt;
4702 #define dMY_CXT_SV dNOOP
4703 #define dMY_CXT dNOOP
4704 #define MY_CXT_INIT NOOP
4705 #define MY_CXT my_cxt
4707 #define pMY_CXT void
4714 #endif /* START_MY_CXT */
4716 #ifndef MY_CXT_CLONE
4717 #define MY_CXT_CLONE NOOP
4723 # if IVSIZE == LONGSIZE
4730 # if IVSIZE == INTSIZE
4741 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
4742 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
4743 # define NVef PERL_PRIeldbl
4744 # define NVff PERL_PRIfldbl
4745 # define NVgf PERL_PRIgldbl
4755 #if defined(NEED_sv_2pv_nolen)
4756 static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4759 extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4763 # undef sv_2pv_nolen
4765 #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
4766 #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
4768 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
4771 DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
4774 return sv_2pv(sv, &n_a);
4779 /* Hint: sv_2pv_nolen
4780 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
4783 /* SvPV_nolen depends on sv_2pv_nolen */
4784 #define SvPV_nolen(sv) \
4785 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
4786 ? SvPVX(sv) : sv_2pv_nolen(sv))
4793 * Does not work in perl-5.6.1, ppport.h implements a version
4794 * borrowed from perl-5.7.3.
4797 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
4799 #if defined(NEED_sv_2pvbyte)
4800 static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4803 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4809 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
4810 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
4812 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
4815 DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
4817 sv_utf8_downgrade(sv,0);
4818 return SvPV(sv,*lp);
4824 * Use the SvPVbyte() macro instead of sv_2pvbyte().
4829 /* SvPVbyte depends on sv_2pvbyte */
4830 #define SvPVbyte(sv, lp) \
4831 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
4832 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
4838 # define SvPVbyte SvPV
4839 # define sv_2pvbyte sv_2pv
4843 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
4844 #ifndef sv_2pvbyte_nolen
4845 # define sv_2pvbyte_nolen sv_2pv_nolen
4849 * Always use the SvPV() macro instead of sv_pvn().
4852 # define sv_pvn(sv, len) SvPV(sv, len)
4855 /* Hint: sv_pvn_force
4856 * Always use the SvPV_force() macro instead of sv_pvn_force().
4858 #ifndef sv_pvn_force
4859 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
4862 # define SvMAGIC_set(sv, val) \
4863 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
4864 (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END
4867 #if ((PERL_VERSION < 9) || ((PERL_VERSION == 9) && (PERL_SUBVERSION < 3)))
4869 # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv)))
4872 #ifndef SvPVX_mutable
4873 # define SvPVX_mutable(sv) (0 + SvPVX(sv))
4876 # define SvRV_set(sv, val) \
4877 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
4878 (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END
4883 # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv))
4886 #ifndef SvPVX_mutable
4887 # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv)
4890 # define SvRV_set(sv, val) \
4891 STMT_START { assert(SvTYPE(sv) >= SVt_RV); \
4892 ((sv)->sv_u.svu_rv = (val)); } STMT_END
4897 # define SvSTASH_set(sv, val) \
4898 STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \
4899 (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END
4902 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 0)))
4904 # define SvUV_set(sv, val) \
4905 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
4906 (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END
4911 # define SvUV_set(sv, val) \
4912 STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \
4913 (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END
4918 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
4919 #if defined(NEED_vnewSVpvf)
4920 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4923 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4929 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
4930 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
4932 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
4935 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
4937 register SV *sv = newSV(0);
4938 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4945 /* sv_vcatpvf depends on sv_vcatpvfn */
4946 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
4947 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4950 /* sv_vsetpvf depends on sv_vsetpvfn */
4951 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
4952 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4955 /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
4956 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
4957 #if defined(NEED_sv_catpvf_mg)
4958 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4961 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4964 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
4966 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
4969 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4972 va_start(args, pat);
4973 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4981 /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
4982 #ifdef PERL_IMPLICIT_CONTEXT
4983 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
4984 #if defined(NEED_sv_catpvf_mg_nocontext)
4985 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4988 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4991 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4992 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4994 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
4997 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
5001 va_start(args, pat);
5002 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
5011 #ifndef sv_catpvf_mg
5012 # ifdef PERL_IMPLICIT_CONTEXT
5013 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
5015 # define sv_catpvf_mg Perl_sv_catpvf_mg
5019 /* sv_vcatpvf_mg depends on sv_vcatpvfn */
5020 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
5021 # define sv_vcatpvf_mg(sv, pat, args) \
5023 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
5028 /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
5029 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
5030 #if defined(NEED_sv_setpvf_mg)
5031 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
5034 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
5037 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
5039 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
5042 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
5045 va_start(args, pat);
5046 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
5054 /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
5055 #ifdef PERL_IMPLICIT_CONTEXT
5056 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
5057 #if defined(NEED_sv_setpvf_mg_nocontext)
5058 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
5061 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
5064 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
5065 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
5067 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
5070 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
5074 va_start(args, pat);
5075 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
5084 #ifndef sv_setpvf_mg
5085 # ifdef PERL_IMPLICIT_CONTEXT
5086 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
5088 # define sv_setpvf_mg Perl_sv_setpvf_mg
5092 /* sv_vsetpvf_mg depends on sv_vsetpvfn */
5093 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
5094 # define sv_vsetpvf_mg(sv, pat, args) \
5096 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
5101 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
5103 #ifndef PERL_MAGIC_sv
5104 # define PERL_MAGIC_sv '\0'
5107 #ifndef PERL_MAGIC_overload
5108 # define PERL_MAGIC_overload 'A'
5111 #ifndef PERL_MAGIC_overload_elem
5112 # define PERL_MAGIC_overload_elem 'a'
5115 #ifndef PERL_MAGIC_overload_table
5116 # define PERL_MAGIC_overload_table 'c'
5119 #ifndef PERL_MAGIC_bm
5120 # define PERL_MAGIC_bm 'B'
5123 #ifndef PERL_MAGIC_regdata
5124 # define PERL_MAGIC_regdata 'D'
5127 #ifndef PERL_MAGIC_regdatum
5128 # define PERL_MAGIC_regdatum 'd'
5131 #ifndef PERL_MAGIC_env
5132 # define PERL_MAGIC_env 'E'
5135 #ifndef PERL_MAGIC_envelem
5136 # define PERL_MAGIC_envelem 'e'
5139 #ifndef PERL_MAGIC_fm
5140 # define PERL_MAGIC_fm 'f'
5143 #ifndef PERL_MAGIC_regex_global
5144 # define PERL_MAGIC_regex_global 'g'
5147 #ifndef PERL_MAGIC_isa
5148 # define PERL_MAGIC_isa 'I'
5151 #ifndef PERL_MAGIC_isaelem
5152 # define PERL_MAGIC_isaelem 'i'
5155 #ifndef PERL_MAGIC_nkeys
5156 # define PERL_MAGIC_nkeys 'k'
5159 #ifndef PERL_MAGIC_dbfile
5160 # define PERL_MAGIC_dbfile 'L'
5163 #ifndef PERL_MAGIC_dbline
5164 # define PERL_MAGIC_dbline 'l'
5167 #ifndef PERL_MAGIC_mutex
5168 # define PERL_MAGIC_mutex 'm'
5171 #ifndef PERL_MAGIC_shared
5172 # define PERL_MAGIC_shared 'N'
5175 #ifndef PERL_MAGIC_shared_scalar
5176 # define PERL_MAGIC_shared_scalar 'n'
5179 #ifndef PERL_MAGIC_collxfrm
5180 # define PERL_MAGIC_collxfrm 'o'
5183 #ifndef PERL_MAGIC_tied
5184 # define PERL_MAGIC_tied 'P'
5187 #ifndef PERL_MAGIC_tiedelem
5188 # define PERL_MAGIC_tiedelem 'p'
5191 #ifndef PERL_MAGIC_tiedscalar
5192 # define PERL_MAGIC_tiedscalar 'q'
5195 #ifndef PERL_MAGIC_qr
5196 # define PERL_MAGIC_qr 'r'
5199 #ifndef PERL_MAGIC_sig
5200 # define PERL_MAGIC_sig 'S'
5203 #ifndef PERL_MAGIC_sigelem
5204 # define PERL_MAGIC_sigelem 's'
5207 #ifndef PERL_MAGIC_taint
5208 # define PERL_MAGIC_taint 't'
5211 #ifndef PERL_MAGIC_uvar
5212 # define PERL_MAGIC_uvar 'U'
5215 #ifndef PERL_MAGIC_uvar_elem
5216 # define PERL_MAGIC_uvar_elem 'u'
5219 #ifndef PERL_MAGIC_vstring
5220 # define PERL_MAGIC_vstring 'V'
5223 #ifndef PERL_MAGIC_vec
5224 # define PERL_MAGIC_vec 'v'
5227 #ifndef PERL_MAGIC_utf8
5228 # define PERL_MAGIC_utf8 'w'
5231 #ifndef PERL_MAGIC_substr
5232 # define PERL_MAGIC_substr 'x'
5235 #ifndef PERL_MAGIC_defelem
5236 # define PERL_MAGIC_defelem 'y'
5239 #ifndef PERL_MAGIC_glob
5240 # define PERL_MAGIC_glob '*'
5243 #ifndef PERL_MAGIC_arylen
5244 # define PERL_MAGIC_arylen '#'
5247 #ifndef PERL_MAGIC_pos
5248 # define PERL_MAGIC_pos '.'
5251 #ifndef PERL_MAGIC_backref
5252 # define PERL_MAGIC_backref '<'
5255 #ifndef PERL_MAGIC_ext
5256 # define PERL_MAGIC_ext '~'
5259 /* That's the best we can do... */
5260 #ifndef SvPV_force_nomg
5261 # define SvPV_force_nomg SvPV_force
5265 # define SvPV_nomg SvPV
5268 #ifndef sv_catpvn_nomg
5269 # define sv_catpvn_nomg sv_catpvn
5272 #ifndef sv_catsv_nomg
5273 # define sv_catsv_nomg sv_catsv
5276 #ifndef sv_setsv_nomg
5277 # define sv_setsv_nomg sv_setsv
5281 # define sv_pvn_nomg sv_pvn
5285 # define SvIV_nomg SvIV
5289 # define SvUV_nomg SvUV
5293 # define sv_catpv_mg(sv, ptr) \
5296 sv_catpv(TeMpSv,ptr); \
5297 SvSETMAGIC(TeMpSv); \
5301 #ifndef sv_catpvn_mg
5302 # define sv_catpvn_mg(sv, ptr, len) \
5305 sv_catpvn(TeMpSv,ptr,len); \
5306 SvSETMAGIC(TeMpSv); \
5311 # define sv_catsv_mg(dsv, ssv) \
5314 sv_catsv(TeMpSv,ssv); \
5315 SvSETMAGIC(TeMpSv); \
5320 # define sv_setiv_mg(sv, i) \
5323 sv_setiv(TeMpSv,i); \
5324 SvSETMAGIC(TeMpSv); \
5329 # define sv_setnv_mg(sv, num) \
5332 sv_setnv(TeMpSv,num); \
5333 SvSETMAGIC(TeMpSv); \
5338 # define sv_setpv_mg(sv, ptr) \
5341 sv_setpv(TeMpSv,ptr); \
5342 SvSETMAGIC(TeMpSv); \
5346 #ifndef sv_setpvn_mg
5347 # define sv_setpvn_mg(sv, ptr, len) \
5350 sv_setpvn(TeMpSv,ptr,len); \
5351 SvSETMAGIC(TeMpSv); \
5356 # define sv_setsv_mg(dsv, ssv) \
5359 sv_setsv(TeMpSv,ssv); \
5360 SvSETMAGIC(TeMpSv); \
5365 # define sv_setuv_mg(sv, i) \
5368 sv_setuv(TeMpSv,i); \
5369 SvSETMAGIC(TeMpSv); \
5373 #ifndef sv_usepvn_mg
5374 # define sv_usepvn_mg(sv, ptr, len) \
5377 sv_usepvn(TeMpSv,ptr,len); \
5378 SvSETMAGIC(TeMpSv); \
5384 # define CopFILE(c) ((c)->cop_file)
5388 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
5392 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
5396 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
5400 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
5404 # define CopSTASHPV(c) ((c)->cop_stashpv)
5407 #ifndef CopSTASHPV_set
5408 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
5412 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
5415 #ifndef CopSTASH_set
5416 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
5420 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
5421 || (CopSTASHPV(c) && HvNAME(hv) \
5422 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
5427 # define CopFILEGV(c) ((c)->cop_filegv)
5430 #ifndef CopFILEGV_set
5431 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
5435 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
5439 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
5443 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
5447 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
5451 # define CopSTASH(c) ((c)->cop_stash)
5454 #ifndef CopSTASH_set
5455 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
5459 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
5462 #ifndef CopSTASHPV_set
5463 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
5467 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
5470 #endif /* USE_ITHREADS */
5471 #ifndef IN_PERL_COMPILETIME
5472 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
5475 #ifndef IN_LOCALE_RUNTIME
5476 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
5479 #ifndef IN_LOCALE_COMPILETIME
5480 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
5484 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
5486 #ifndef IS_NUMBER_IN_UV
5487 # define IS_NUMBER_IN_UV 0x01
5490 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
5491 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
5494 #ifndef IS_NUMBER_NOT_INT
5495 # define IS_NUMBER_NOT_INT 0x04
5498 #ifndef IS_NUMBER_NEG
5499 # define IS_NUMBER_NEG 0x08
5502 #ifndef IS_NUMBER_INFINITY
5503 # define IS_NUMBER_INFINITY 0x10
5506 #ifndef IS_NUMBER_NAN
5507 # define IS_NUMBER_NAN 0x20
5510 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
5511 #ifndef GROK_NUMERIC_RADIX
5512 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
5514 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
5515 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
5518 #ifndef PERL_SCAN_SILENT_ILLDIGIT
5519 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
5522 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
5523 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
5526 #ifndef PERL_SCAN_DISALLOW_PREFIX
5527 # define PERL_SCAN_DISALLOW_PREFIX 0x02
5530 #ifndef grok_numeric_radix
5531 #if defined(NEED_grok_numeric_radix)
5532 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5535 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5538 #ifdef grok_numeric_radix
5539 # undef grok_numeric_radix
5541 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
5542 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
5544 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
5546 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
5548 #ifdef USE_LOCALE_NUMERIC
5549 #ifdef PL_numeric_radix_sv
5550 if (PL_numeric_radix_sv && IN_LOCALE) {
5552 char* radix = SvPV(PL_numeric_radix_sv, len);
5553 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5559 /* older perls don't have PL_numeric_radix_sv so the radix
5560 * must manually be requested from locale.h
5563 dTHR; /* needed for older threaded perls */
5564 struct lconv *lc = localeconv();
5565 char *radix = lc->decimal_point;
5566 if (radix && IN_LOCALE) {
5567 STRLEN len = strlen(radix);
5568 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5574 #endif /* USE_LOCALE_NUMERIC */
5575 /* always try "." if numeric radix didn't match because
5576 * we may have data from different locales mixed */
5577 if (*sp < send && **sp == '.') {
5586 /* grok_number depends on grok_numeric_radix */
5589 #if defined(NEED_grok_number)
5590 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5593 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5599 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
5600 #define Perl_grok_number DPPP_(my_grok_number)
5602 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
5604 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
5607 const char *send = pv + len;
5608 const UV max_div_10 = UV_MAX / 10;
5609 const char max_mod_10 = UV_MAX % 10;
5614 while (s < send && isSPACE(*s))
5618 } else if (*s == '-') {
5620 numtype = IS_NUMBER_NEG;
5628 /* next must be digit or the radix separator or beginning of infinity */
5630 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
5632 UV value = *s - '0';
5633 /* This construction seems to be more optimiser friendly.
5634 (without it gcc does the isDIGIT test and the *s - '0' separately)
5635 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
5636 In theory the optimiser could deduce how far to unroll the loop
5637 before checking for overflow. */
5639 int digit = *s - '0';
5640 if (digit >= 0 && digit <= 9) {
5641 value = value * 10 + digit;
5644 if (digit >= 0 && digit <= 9) {
5645 value = value * 10 + digit;
5648 if (digit >= 0 && digit <= 9) {
5649 value = value * 10 + digit;
5652 if (digit >= 0 && digit <= 9) {
5653 value = value * 10 + digit;
5656 if (digit >= 0 && digit <= 9) {
5657 value = value * 10 + digit;
5660 if (digit >= 0 && digit <= 9) {
5661 value = value * 10 + digit;
5664 if (digit >= 0 && digit <= 9) {
5665 value = value * 10 + digit;
5668 if (digit >= 0 && digit <= 9) {
5669 value = value * 10 + digit;
5671 /* Now got 9 digits, so need to check
5672 each time for overflow. */
5674 while (digit >= 0 && digit <= 9
5675 && (value < max_div_10
5676 || (value == max_div_10
5677 && digit <= max_mod_10))) {
5678 value = value * 10 + digit;
5684 if (digit >= 0 && digit <= 9
5686 /* value overflowed.
5687 skip the remaining digits, don't
5688 worry about setting *valuep. */
5691 } while (s < send && isDIGIT(*s));
5693 IS_NUMBER_GREATER_THAN_UV_MAX;
5713 numtype |= IS_NUMBER_IN_UV;
5718 if (GROK_NUMERIC_RADIX(&s, send)) {
5719 numtype |= IS_NUMBER_NOT_INT;
5720 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
5724 else if (GROK_NUMERIC_RADIX(&s, send)) {
5725 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
5726 /* no digits before the radix means we need digits after it */
5727 if (s < send && isDIGIT(*s)) {
5730 } while (s < send && isDIGIT(*s));
5732 /* integer approximation is valid - it's 0. */
5738 } else if (*s == 'I' || *s == 'i') {
5739 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5740 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
5741 s++; if (s < send && (*s == 'I' || *s == 'i')) {
5742 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5743 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
5744 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
5745 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
5749 } else if (*s == 'N' || *s == 'n') {
5750 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
5751 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
5752 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5759 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5760 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
5761 } else if (sawnan) {
5762 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5763 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
5764 } else if (s < send) {
5765 /* we can have an optional exponent part */
5766 if (*s == 'e' || *s == 'E') {
5767 /* The only flag we keep is sign. Blow away any "it's UV" */
5768 numtype &= IS_NUMBER_NEG;
5769 numtype |= IS_NUMBER_NOT_INT;
5771 if (s < send && (*s == '-' || *s == '+'))
5773 if (s < send && isDIGIT(*s)) {
5776 } while (s < send && isDIGIT(*s));
5782 while (s < send && isSPACE(*s))
5786 if (len == 10 && memEQ(pv, "0 but true", 10)) {
5789 return IS_NUMBER_IN_UV;
5797 * The grok_* routines have been modified to use warn() instead of
5798 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
5799 * which is why the stack variable has been renamed to 'xdigit'.
5803 #if defined(NEED_grok_bin)
5804 static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5807 extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5813 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
5814 #define Perl_grok_bin DPPP_(my_grok_bin)
5816 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
5818 DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5820 const char *s = start;
5821 STRLEN len = *len_p;
5825 const UV max_div_2 = UV_MAX / 2;
5826 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5827 bool overflowed = FALSE;
5829 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5830 /* strip off leading b or 0b.
5831 for compatibility silently suffer "b" and "0b" as valid binary
5838 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
5845 for (; len-- && *s; s++) {
5847 if (bit == '0' || bit == '1') {
5848 /* Write it in this wonky order with a goto to attempt to get the
5849 compiler to make the common case integer-only loop pretty tight.
5850 With gcc seems to be much straighter code than old scan_bin. */
5853 if (value <= max_div_2) {
5854 value = (value << 1) | (bit - '0');
5857 /* Bah. We're just overflowed. */
5858 warn("Integer overflow in binary number");
5860 value_nv = (NV) value;
5863 /* If an NV has not enough bits in its mantissa to
5864 * represent a UV this summing of small low-order numbers
5865 * is a waste of time (because the NV cannot preserve
5866 * the low-order bits anyway): we could just remember when
5867 * did we overflow and in the end just multiply value_nv by the
5869 value_nv += (NV)(bit - '0');
5872 if (bit == '_' && len && allow_underscores && (bit = s[1])
5873 && (bit == '0' || bit == '1'))
5879 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5880 warn("Illegal binary digit '%c' ignored", *s);
5884 if ( ( overflowed && value_nv > 4294967295.0)
5886 || (!overflowed && value > 0xffffffff )
5889 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
5896 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5905 #if defined(NEED_grok_hex)
5906 static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5909 extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5915 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
5916 #define Perl_grok_hex DPPP_(my_grok_hex)
5918 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
5920 DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5922 const char *s = start;
5923 STRLEN len = *len_p;
5927 const UV max_div_16 = UV_MAX / 16;
5928 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5929 bool overflowed = FALSE;
5932 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5933 /* strip off leading x or 0x.
5934 for compatibility silently suffer "x" and "0x" as valid hex numbers.
5941 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
5948 for (; len-- && *s; s++) {
5949 xdigit = strchr((char *) PL_hexdigit, *s);
5951 /* Write it in this wonky order with a goto to attempt to get the
5952 compiler to make the common case integer-only loop pretty tight.
5953 With gcc seems to be much straighter code than old scan_hex. */
5956 if (value <= max_div_16) {
5957 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
5960 warn("Integer overflow in hexadecimal number");
5962 value_nv = (NV) value;
5965 /* If an NV has not enough bits in its mantissa to
5966 * represent a UV this summing of small low-order numbers
5967 * is a waste of time (because the NV cannot preserve
5968 * the low-order bits anyway): we could just remember when
5969 * did we overflow and in the end just multiply value_nv by the
5970 * right amount of 16-tuples. */
5971 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
5974 if (*s == '_' && len && allow_underscores && s[1]
5975 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
5981 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5982 warn("Illegal hexadecimal digit '%c' ignored", *s);
5986 if ( ( overflowed && value_nv > 4294967295.0)
5988 || (!overflowed && value > 0xffffffff )
5991 warn("Hexadecimal number > 0xffffffff non-portable");
5998 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
6007 #if defined(NEED_grok_oct)
6008 static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
6011 extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
6017 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
6018 #define Perl_grok_oct DPPP_(my_grok_oct)
6020 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
6022 DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
6024 const char *s = start;
6025 STRLEN len = *len_p;
6029 const UV max_div_8 = UV_MAX / 8;
6030 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
6031 bool overflowed = FALSE;
6033 for (; len-- && *s; s++) {
6034 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
6035 out front allows slicker code. */
6036 int digit = *s - '0';
6037 if (digit >= 0 && digit <= 7) {
6038 /* Write it in this wonky order with a goto to attempt to get the
6039 compiler to make the common case integer-only loop pretty tight.
6043 if (value <= max_div_8) {
6044 value = (value << 3) | digit;
6047 /* Bah. We're just overflowed. */
6048 warn("Integer overflow in octal number");
6050 value_nv = (NV) value;
6053 /* If an NV has not enough bits in its mantissa to
6054 * represent a UV this summing of small low-order numbers
6055 * is a waste of time (because the NV cannot preserve
6056 * the low-order bits anyway): we could just remember when
6057 * did we overflow and in the end just multiply value_nv by the
6058 * right amount of 8-tuples. */
6059 value_nv += (NV)digit;
6062 if (digit == ('_' - '0') && len && allow_underscores
6063 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
6069 /* Allow \octal to work the DWIM way (that is, stop scanning
6070 * as soon as non-octal characters are seen, complain only iff
6071 * someone seems to want to use the digits eight and nine). */
6072 if (digit == 8 || digit == 9) {
6073 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
6074 warn("Illegal octal digit '%c' ignored", *s);
6079 if ( ( overflowed && value_nv > 4294967295.0)
6081 || (!overflowed && value > 0xffffffff )
6084 warn("Octal number > 037777777777 non-portable");
6091 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
6101 # define dXCPT dJMPENV; int rEtV = 0
6102 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
6103 # define XCPT_TRY_END JMPENV_POP;
6104 # define XCPT_CATCH if (rEtV != 0)
6105 # define XCPT_RETHROW JMPENV_JUMP(rEtV)
6107 # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
6108 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
6109 # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
6110 # define XCPT_CATCH if (rEtV != 0)
6111 # define XCPT_RETHROW Siglongjmp(top_env, rEtV)
6115 #endif /* _P_P_PORTABILITY_H_ */
6117 /* End of File ppport.h */
projects / p5sagit/p5-mst-13.2.git / blob