1 ################################################################################
3 # !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
5 ################################################################################
7 # Perl/Pollution/Portability
9 ################################################################################
13 # $Date: 2005/06/25 17:56:28 +0200 $
15 ################################################################################
17 # Version 3.x, Copyright (C) 2004-2005, 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:
165 IN_LOCALE_COMPILETIME
169 IS_NUMBER_GREATER_THAN_UV_MAX
204 PERL_GCC_BRACE_GROUPS_FORBIDDEN
226 PERL_MAGIC_overload_elem
227 PERL_MAGIC_overload_table
232 PERL_MAGIC_regex_global
234 PERL_MAGIC_shared_scalar
242 PERL_MAGIC_tiedscalar
251 PERL_SCAN_ALLOW_UNDERSCORES
252 PERL_SCAN_DISALLOW_PREFIX
253 PERL_SCAN_GREATER_THAN_UV_MAX
254 PERL_SCAN_SILENT_ILLDIGIT
286 PL_perl_destruct_level
323 sv_catpvf_mg_nocontext
335 sv_setpvf_mg_nocontext
376 =head2 Perl API not supported by ppport.h
378 There is still a big part of the API not supported by F<ppport.h>.
379 Either because it doesn't make sense to back-port that part of the API,
380 or simply because it hasn't been implemented yet. Patches welcome!
382 Here's a list of the currently unsupported API, and also the version of
383 Perl below which it is unsupported:
403 is_utf8_string_loclen
422 hv_clear_placeholders
498 gv_fetchmeth_autoload
547 sv_utf8_upgrade_flags
565 sv_force_normal_flags
586 utf16_to_utf8_reversed
815 gv_fetchmethod_autoload
859 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
860 system or any of its tests fail, please use the CPAN Request Tracker
861 at L<http://rt.cpan.org/> to create a ticket for the module.
869 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
873 Version 2.x was ported to the Perl core by Paul Marquess.
877 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
883 Version 3.x, Copyright (C) 2004-2005, Marcus Holland-Moritz.
885 Version 2.x, Copyright (C) 2001, Paul Marquess.
887 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
889 This program is free software; you can redistribute it and/or
890 modify it under the same terms as Perl itself.
894 See L<h2xs>, L<ppport.h>.
898 package Devel::PPPort;
902 use vars qw($VERSION @ISA $data);
904 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.06_01 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
906 @ISA = qw(DynaLoader);
908 bootstrap Devel::PPPort;
912 $data = do { local $/; <DATA> };
914 my $pkg = 'Devel::PPPort';
915 $data =~ s/__PERL_VERSION__/$]/g;
916 $data =~ s/__VERSION__/$VERSION/g;
917 $data =~ s/__DATE__/$now/g;
918 $data =~ s/__PKG__/$pkg/g;
924 my $file = shift || 'ppport.h';
925 defined $data or _init_data();
927 $copy =~ s/\bppport\.h\b/$file/g;
929 open F, ">$file" or return undef;
943 ----------------------------------------------------------------------
945 ppport.h -- Perl/Pollution/Portability Version __VERSION__
947 Automatically created by __PKG__ running under
948 perl __PERL_VERSION__ on __DATE__.
950 Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
951 includes in parts/inc/ instead.
953 Use 'perldoc ppport.h' to view the documentation below.
955 ----------------------------------------------------------------------
963 |>ppport.h - Perl/Pollution/Portability version __VERSION__
967 |> perl ppport.h [options] [source files]
969 |> Searches current directory for files if no [source files] are given
971 |> --help show short help
973 |> --patch=file write one patch file with changes
974 |> --copy=suffix write changed copies with suffix
975 |> --diff=program use diff program and options
977 |> --compat-version=version provide compatibility with Perl version
978 |> --cplusplus accept C++ comments
980 |> --quiet don't output anything except fatal errors
981 |> --nodiag don't show diagnostics
982 |> --nohints don't show hints
983 |> --nochanges don't suggest changes
984 |> --nofilter don't filter input files
986 |> --list-provided list provided API
987 |> --list-unsupported list unsupported API
988 |> --api-info=name show Perl API portability information
990 |>=head1 COMPATIBILITY
992 |>This version of F<ppport.h> is designed to support operation with Perl
993 |>installations back to 5.003, and has been tested up to 5.9.3.
999 |>Display a brief usage summary.
1001 |>=head2 --patch=I<file>
1003 |>If this option is given, a single patch file will be created if
1004 |>any changes are suggested. This requires a working diff program
1005 |>to be installed on your system.
1007 |>=head2 --copy=I<suffix>
1009 |>If this option is given, a copy of each file will be saved with
1010 |>the given suffix that contains the suggested changes. This does
1011 |>not require any external programs.
1013 |>If neither C<--patch> or C<--copy> are given, the default is to
1014 |>simply print the diffs for each file. This requires either
1015 |>C<Text::Diff> or a C<diff> program to be installed.
1017 |>=head2 --diff=I<program>
1019 |>Manually set the diff program and options to use. The default
1020 |>is to use C<Text::Diff>, when installed, and output unified
1023 |>=head2 --compat-version=I<version>
1025 |>Tell F<ppport.h> to check for compatibility with the given
1026 |>Perl version. The default is to check for compatibility with Perl
1027 |>version 5.003. You can use this option to reduce the output
1028 |>of F<ppport.h> if you intend to be backward compatible only
1029 |>up to a certain Perl version.
1031 |>=head2 --cplusplus
1033 |>Usually, F<ppport.h> will detect C++ style comments and
1034 |>replace them with C style comments for portability reasons.
1035 |>Using this option instructs F<ppport.h> to leave C++
1036 |>comments untouched.
1040 |>Be quiet. Don't print anything except fatal errors.
1044 |>Don't output any diagnostic messages. Only portability
1045 |>alerts will be printed.
1049 |>Don't output any hints. Hints often contain useful portability
1052 |>=head2 --nochanges
1054 |>Don't suggest any changes. Only give diagnostic output and hints
1055 |>unless these are also deactivated.
1059 |>Don't filter the list of input files. By default, files not looking
1060 |>like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
1062 |>=head2 --list-provided
1064 |>Lists the API elements for which compatibility is provided by
1065 |>F<ppport.h>. Also lists if it must be explicitly requested,
1066 |>if it has dependencies, and if there are hints for it.
1068 |>=head2 --list-unsupported
1070 |>Lists the API elements that are known not to be supported by
1071 |>F<ppport.h> and below which version of Perl they probably
1072 |>won't be available or work.
1074 |>=head2 --api-info=I<name>
1076 |>Show portability information for API elements matching I<name>.
1077 |>If I<name> is surrounded by slashes, it is interpreted as a regular
1080 |>=head1 DESCRIPTION
1082 |>In order for a Perl extension (XS) module to be as portable as possible
1083 |>across differing versions of Perl itself, certain steps need to be taken.
1089 |>Including this header is the first major one. This alone will give you
1090 |>access to a large part of the Perl API that hasn't been available in
1091 |>earlier Perl releases. Use
1093 |> perl ppport.h --list-provided
1095 |>to see which API elements are provided by ppport.h.
1099 |>You should avoid using deprecated parts of the API. For example, using
1100 |>global Perl variables without the C<PL_> prefix is deprecated. Also,
1101 |>some API functions used to have a C<perl_> prefix. Using this form is
1102 |>also deprecated. You can safely use the supported API, as F<ppport.h>
1103 |>will provide wrappers for older Perl versions.
1107 |>If you use one of a few functions that were not present in earlier
1108 |>versions of Perl, and that can't be provided using a macro, you have
1109 |>to explicitly request support for these functions by adding one or
1110 |>more C<#define>s in your source code before the inclusion of F<ppport.h>.
1112 |>These functions will be marked C<explicit> in the list shown by
1113 |>C<--list-provided>.
1115 |>Depending on whether you module has a single or multiple files that
1116 |>use such functions, you want either C<static> or global variants.
1118 |>For a C<static> function, use:
1120 |> #define NEED_function
1122 |>For a global function, use:
1124 |> #define NEED_function_GLOBAL
1126 |>Note that you mustn't have more than one global request for one
1127 |>function in your project.
1129 |> Function Static Request Global Request
1130 |> -----------------------------------------------------------------------------------------
1131 |> eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
1132 |> grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
1133 |> grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
1134 |> grok_number() NEED_grok_number NEED_grok_number_GLOBAL
1135 |> grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
1136 |> grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
1137 |> newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
1138 |> newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
1139 |> sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
1140 |> sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
1141 |> sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
1142 |> sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
1143 |> sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
1144 |> sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
1145 |> vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
1147 |>To avoid namespace conflicts, you can change the namespace of the
1148 |>explicitly exported functions using the C<DPPP_NAMESPACE> macro.
1149 |>Just C<#define> the macro before including C<ppport.h>:
1151 |> #define DPPP_NAMESPACE MyOwnNamespace_
1152 |> #include "ppport.h"
1154 |>The default namespace is C<DPPP_>.
1158 |>The good thing is that most of the above can be checked by running
1159 |>F<ppport.h> on your source code. See the next section for
1164 |>To verify whether F<ppport.h> is needed for your module, whether you
1165 |>should make any changes to your code, and whether any special defines
1166 |>should be used, F<ppport.h> can be run as a Perl script to check your
1167 |>source code. Simply say:
1171 |>The result will usually be a list of patches suggesting changes
1172 |>that should at least be acceptable, if not necessarily the most
1173 |>efficient solution, or a fix for all possible problems.
1175 |>If you know that your XS module uses features only available in
1176 |>newer Perl releases, if you're aware that it uses C++ comments,
1177 |>and if you want all suggestions as a single patch file, you could
1178 |>use something like this:
1180 |> perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
1182 |>If you only want your code to be scanned without any suggestions
1185 |> perl ppport.h --nochanges
1187 |>You can specify a different C<diff> program or options, using
1188 |>the C<--diff> option:
1190 |> perl ppport.h --diff='diff -C 10'
1192 |>This would output context diffs with 10 lines of context.
1194 |>To display portability information for the C<newSVpvn> function,
1197 |> perl ppport.h --api-info=newSVpvn
1199 |>Since the argument to C<--api-info> can be a regular expression,
1202 |> perl ppport.h --api-info=/_nomg$/
1204 |>to display portability information for all C<_nomg> functions or
1206 |> perl ppport.h --api-info=/./
1208 |>to display information for all known API elements.
1212 |>If this version of F<ppport.h> is causing failure during
1213 |>the compilation of this module, please check if newer versions
1214 |>of either this module or C<Devel::PPPort> are available on CPAN
1215 |>before sending a bug report.
1217 |>If F<ppport.h> was generated using the latest version of
1218 |>C<Devel::PPPort> and is causing failure of this module, please
1219 |>file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
1221 |>Please include the following information:
1227 |>The complete output from running "perl -V"
1235 |>The name and version of the module you were trying to build.
1239 |>A full log of the build that failed.
1243 |>Any other information that you think could be relevant.
1247 |>For the latest version of this code, please get the C<Devel::PPPort>
1252 |>Version 3.x, Copyright (c) 2004-2005, Marcus Holland-Moritz.
1254 |>Version 2.x, Copyright (C) 2001, Paul Marquess.
1256 |>Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
1258 |>This program is free software; you can redistribute it and/or
1259 |>modify it under the same terms as Perl itself.
1263 |>See L<Devel::PPPort>.
1278 my($ppport) = $0 =~ /([\w.]+)$/;
1279 my $LF = '(?:\r\n|[\r\n])'; # line feed
1280 my $HS = "[ \t]"; # horizontal whitespace
1283 require Getopt::Long;
1284 Getopt::Long::GetOptions(\%opt, qw(
1285 help quiet diag! filter! hints! changes! cplusplus
1286 patch=s copy=s diff=s compat-version=s
1287 list-provided list-unsupported api-info=s
1291 if ($@ and grep /^-/, @ARGV) {
1292 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
1293 die "Getopt::Long not found. Please don't use any options.\n";
1296 usage() if $opt{help};
1298 if (exists $opt{'compat-version'}) {
1299 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
1301 die "Invalid version number format: '$opt{'compat-version'}'\n";
1303 die "Only Perl 5 is supported\n" if $r != 5;
1304 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
1305 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
1308 $opt{'compat-version'} = 5;
1311 # Never use C comments in this file!!!!!
1314 my $rccs = quotemeta $ccs;
1315 my $rcce = quotemeta $cce;
1317 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
1319 ($2 ? ( base => $2 ) : ()),
1320 ($3 ? ( todo => $3 ) : ()),
1321 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
1322 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
1323 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
1325 : die "invalid spec: $_" } qw(
1331 CopFILEAV|5.006000||p
1332 CopFILEGV_set|5.006000||p
1333 CopFILEGV|5.006000||p
1334 CopFILESV|5.006000||p
1335 CopFILE_set|5.006000||p
1337 CopSTASHPV_set|5.006000||p
1338 CopSTASHPV|5.006000||p
1339 CopSTASH_eq|5.006000||p
1340 CopSTASH_set|5.006000||p
1341 CopSTASH|5.006000||p
1348 END_EXTERN_C|5.005000||p
1352 EXTERN_C|5.005000||p
1356 GROK_NUMERIC_RADIX|5.007002||p
1366 HEf_SVKEY||5.004000|
1371 HeSVKEY_force||5.004000|
1372 HeSVKEY_set||5.004000|
1377 IN_LOCALE_COMPILETIME|5.007002||p
1378 IN_LOCALE_RUNTIME|5.007002||p
1379 IN_LOCALE|5.007002||p
1380 IN_PERL_COMPILETIME|5.008001||p
1381 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
1382 IS_NUMBER_INFINITY|5.007002||p
1383 IS_NUMBER_IN_UV|5.007002||p
1384 IS_NUMBER_NAN|5.007003||p
1385 IS_NUMBER_NEG|5.007002||p
1386 IS_NUMBER_NOT_INT|5.007002||p
1393 MY_CXT_CLONE|5.009002||p
1394 MY_CXT_INIT|5.007003||p
1416 PAD_COMPNAME_FLAGS|||
1417 PAD_COMPNAME_GEN_set|||
1419 PAD_COMPNAME_OURSTASH|||
1421 PAD_COMPNAME_TYPE|||
1422 PAD_RESTORE_LOCAL|||
1424 PAD_SAVE_SETNULLPAD|||
1426 PAD_SET_CUR_NOSAVE|||
1430 PERL_BCDVERSION|5.009003||p
1431 PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
1432 PERL_INT_MAX|5.004000||p
1433 PERL_INT_MIN|5.004000||p
1434 PERL_LONG_MAX|5.004000||p
1435 PERL_LONG_MIN|5.004000||p
1436 PERL_MAGIC_arylen|5.007002||p
1437 PERL_MAGIC_backref|5.007002||p
1438 PERL_MAGIC_bm|5.007002||p
1439 PERL_MAGIC_collxfrm|5.007002||p
1440 PERL_MAGIC_dbfile|5.007002||p
1441 PERL_MAGIC_dbline|5.007002||p
1442 PERL_MAGIC_defelem|5.007002||p
1443 PERL_MAGIC_envelem|5.007002||p
1444 PERL_MAGIC_env|5.007002||p
1445 PERL_MAGIC_ext|5.007002||p
1446 PERL_MAGIC_fm|5.007002||p
1447 PERL_MAGIC_glob|5.007002||p
1448 PERL_MAGIC_isaelem|5.007002||p
1449 PERL_MAGIC_isa|5.007002||p
1450 PERL_MAGIC_mutex|5.007002||p
1451 PERL_MAGIC_nkeys|5.007002||p
1452 PERL_MAGIC_overload_elem|5.007002||p
1453 PERL_MAGIC_overload_table|5.007002||p
1454 PERL_MAGIC_overload|5.007002||p
1455 PERL_MAGIC_pos|5.007002||p
1456 PERL_MAGIC_qr|5.007002||p
1457 PERL_MAGIC_regdata|5.007002||p
1458 PERL_MAGIC_regdatum|5.007002||p
1459 PERL_MAGIC_regex_global|5.007002||p
1460 PERL_MAGIC_shared_scalar|5.007003||p
1461 PERL_MAGIC_shared|5.007003||p
1462 PERL_MAGIC_sigelem|5.007002||p
1463 PERL_MAGIC_sig|5.007002||p
1464 PERL_MAGIC_substr|5.007002||p
1465 PERL_MAGIC_sv|5.007002||p
1466 PERL_MAGIC_taint|5.007002||p
1467 PERL_MAGIC_tiedelem|5.007002||p
1468 PERL_MAGIC_tiedscalar|5.007002||p
1469 PERL_MAGIC_tied|5.007002||p
1470 PERL_MAGIC_utf8|5.008001||p
1471 PERL_MAGIC_uvar_elem|5.007003||p
1472 PERL_MAGIC_uvar|5.007002||p
1473 PERL_MAGIC_vec|5.007002||p
1474 PERL_MAGIC_vstring|5.008001||p
1475 PERL_QUAD_MAX|5.004000||p
1476 PERL_QUAD_MIN|5.004000||p
1477 PERL_REVISION|5.006000||p
1478 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
1479 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
1480 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
1481 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
1482 PERL_SHORT_MAX|5.004000||p
1483 PERL_SHORT_MIN|5.004000||p
1484 PERL_SUBVERSION|5.006000||p
1485 PERL_UCHAR_MAX|5.004000||p
1486 PERL_UCHAR_MIN|5.004000||p
1487 PERL_UINT_MAX|5.004000||p
1488 PERL_UINT_MIN|5.004000||p
1489 PERL_ULONG_MAX|5.004000||p
1490 PERL_ULONG_MIN|5.004000||p
1491 PERL_UNUSED_DECL|5.007002||p
1492 PERL_UQUAD_MAX|5.004000||p
1493 PERL_UQUAD_MIN|5.004000||p
1494 PERL_USHORT_MAX|5.004000||p
1495 PERL_USHORT_MIN|5.004000||p
1496 PERL_VERSION|5.006000||p
1501 PL_compiling|5.004050||p
1502 PL_copline|5.005000||p
1503 PL_curcop|5.004050||p
1504 PL_curstash|5.004050||p
1505 PL_debstash|5.004050||p
1506 PL_defgv|5.004050||p
1507 PL_diehook|5.004050||p
1508 PL_dirty|5.004050||p
1510 PL_errgv|5.004050||p
1511 PL_hexdigit|5.005000||p
1512 PL_hints|5.005000||p
1514 PL_modglobal||5.005000|n
1516 PL_no_modify|5.006000||p
1518 PL_perl_destruct_level|5.004050||p
1519 PL_perldb|5.004050||p
1520 PL_ppaddr|5.006000||p
1521 PL_rsfp_filters|5.004050||p
1524 PL_stack_base|5.004050||p
1525 PL_stack_sp|5.004050||p
1526 PL_stdingv|5.004050||p
1527 PL_sv_arenaroot|5.004050||p
1528 PL_sv_no|5.004050||pn
1529 PL_sv_undef|5.004050||pn
1530 PL_sv_yes|5.004050||pn
1531 PL_tainted|5.004050||p
1532 PL_tainting|5.004050||p
1536 POPpbytex||5.007001|n
1547 PUSHmortal|5.009002||p
1553 PerlIO_clearerr||5.007003|
1554 PerlIO_close||5.007003|
1555 PerlIO_eof||5.007003|
1556 PerlIO_error||5.007003|
1557 PerlIO_fileno||5.007003|
1558 PerlIO_fill||5.007003|
1559 PerlIO_flush||5.007003|
1560 PerlIO_get_base||5.007003|
1561 PerlIO_get_bufsiz||5.007003|
1562 PerlIO_get_cnt||5.007003|
1563 PerlIO_get_ptr||5.007003|
1564 PerlIO_read||5.007003|
1565 PerlIO_seek||5.007003|
1566 PerlIO_set_cnt||5.007003|
1567 PerlIO_set_ptrcnt||5.007003|
1568 PerlIO_setlinebuf||5.007003|
1569 PerlIO_stderr||5.007003|
1570 PerlIO_stdin||5.007003|
1571 PerlIO_stdout||5.007003|
1572 PerlIO_tell||5.007003|
1573 PerlIO_unread||5.007003|
1574 PerlIO_write||5.007003|
1583 SAVE_DEFSV|5.004050||p
1586 START_EXTERN_C|5.005000||p
1587 START_MY_CXT|5.007003||p
1605 SvGETMAGIC|5.004050||p
1608 SvIOK_notUV||5.006000|
1610 SvIOK_only_UV||5.006000|
1616 SvIV_nomg|5.009001||p
1620 SvIsCOW_shared_hash||5.008003|
1625 SvMAGIC_set||5.009003|
1641 SvPOK_only_UTF8||5.006000|
1647 SvPV_force_nomg|5.007002||p
1649 SvPV_nolen|5.006000||p
1650 SvPV_nomg|5.007002||p
1652 SvPVbyte_force||5.009002|
1653 SvPVbyte_nolen||5.006000|
1654 SvPVbytex_force||5.006000|
1655 SvPVbytex||5.006000|
1656 SvPVbyte|5.006000||p
1657 SvPVutf8_force||5.006000|
1658 SvPVutf8_nolen||5.006000|
1659 SvPVutf8x_force||5.006000|
1660 SvPVutf8x||5.006000|
1674 SvSTASH_set||5.009003|
1676 SvSetMagicSV_nosteal||5.004000|
1677 SvSetMagicSV||5.004000|
1678 SvSetSV_nosteal||5.004000|
1680 SvTAINTED_off||5.004000|
1681 SvTAINTED_on||5.004000|
1682 SvTAINTED||5.004000|
1689 SvUTF8_off||5.006000|
1690 SvUTF8_on||5.006000|
1694 SvUV_nomg|5.009001||p
1700 UNDERBAR|5.009002||p
1707 XCPT_CATCH|5.009002||p
1708 XCPT_RETHROW|5.009002||p
1709 XCPT_TRY_END|5.009002||p
1710 XCPT_TRY_START|5.009002||p
1712 XPUSHmortal|5.009002||p
1723 XSRETURN_UV|5.008001||p
1733 XS_VERSION_BOOTCHECK|||
1738 _aMY_CXT|5.007003||p
1739 _pMY_CXT|5.007003||p
1740 aMY_CXT_|5.007003||p
1752 apply_attrs_string||5.006001|
1757 atfork_lock||5.007003|n
1758 atfork_unlock||5.007003|n
1759 av_arylen_p||5.009003|
1761 av_delete||5.006000|
1762 av_exists||5.006000|
1780 block_gimme||5.004000|
1784 boot_core_UNIVERSAL|||
1785 boot_core_xsutils|||
1786 bytes_from_utf8||5.007001|
1787 bytes_to_utf8||5.006001|
1789 call_argv|5.006000||p
1790 call_atexit||5.006000|
1793 call_list||5.004000|
1794 call_method|5.006000||p
1801 cast_ulong||5.006000|
1857 croak_nocontext|||vn
1859 csighandler||5.007001|n
1860 custom_op_desc||5.007003|
1861 custom_op_name||5.007003|
1864 cv_const_sv||5.004000|
1874 dMY_CXT_SV|5.007003||p
1883 dUNDERBAR|5.009002||p
1893 debprofdump||5.005000|
1895 debstackptrs||5.007003|
1904 despatch_signals||5.007001|
1914 do_binmode||5.004050|
1923 do_gv_dump||5.006000|
1924 do_gvgv_dump||5.006000|
1925 do_hv_dump||5.006000|
1930 do_magic_dump||5.006000|
1934 do_op_dump||5.006000|
1939 do_pmop_dump||5.006000|
1948 do_sv_dump||5.006000|
1951 do_trans_complex_utf8|||
1953 do_trans_count_utf8|||
1955 do_trans_simple_utf8|||
1967 doing_taint||5.008001|n
1979 dump_eval||5.006000|
1981 dump_form||5.006000|
1982 dump_indent||5.006000|v
1984 dump_packsubs||5.006000|
1986 dump_vindent||5.006000|
1993 fbm_compile||5.005000|
1994 fbm_instr||5.005000|
2004 find_rundefsvoffset||5.009002|
2017 fprintf_nocontext|||vn
2018 free_global_struct|||
2019 free_tied_hv_pool|||
2021 gen_constant_list|||
2023 get_context||5.006000|n
2032 get_op_descs||5.005000|
2033 get_op_names||5.005000|
2035 get_ppaddr||5.006000|
2038 getcwd_sv||5.007002|
2043 grok_bin|5.007003||p
2044 grok_hex|5.007003||p
2045 grok_number|5.007002||p
2046 grok_numeric_radix|5.007002||p
2047 grok_oct|5.007003||p
2052 gv_autoload4||5.004000|
2055 gv_efullname3||5.004000|
2056 gv_efullname4||5.006001|
2060 gv_fetchmeth_autoload||5.007003|
2061 gv_fetchmethod_autoload||5.004000|
2064 gv_fetchpvn_flags||5.009002|
2066 gv_fetchsv||5.009002|
2067 gv_fullname3||5.004000|
2068 gv_fullname4||5.006001|
2070 gv_handler||5.007001|
2074 gv_stashpvn|5.006000||p
2081 hv_assert||5.009001|
2083 hv_clear_placeholders||5.009001|
2085 hv_delayfree_ent||5.004000|
2087 hv_delete_ent||5.004000|
2089 hv_eiter_p||5.009003|
2090 hv_eiter_set||5.009003|
2091 hv_exists_ent||5.004000|
2094 hv_fetch_ent||5.004000|
2096 hv_free_ent||5.004000|
2098 hv_iterkeysv||5.004000|
2100 hv_iternext_flags||5.008000|
2104 hv_ksplit||5.004000|
2107 hv_name_set||5.009003|
2109 hv_placeholders_get||5.009003|
2110 hv_placeholders_p||5.009003|
2111 hv_placeholders_set||5.009003|
2112 hv_riter_p||5.009003|
2113 hv_riter_set||5.009003|
2114 hv_scalar||5.009001|
2115 hv_store_ent||5.004000|
2116 hv_store_flags||5.008000|
2119 ibcmp_locale||5.004000|
2120 ibcmp_utf8||5.007003|
2126 init_argv_symbols|||
2128 init_global_struct|||
2129 init_i18nl10n||5.006000|
2130 init_i18nl14n||5.006000|
2136 init_postdump_symbols|||
2137 init_predump_symbols|||
2138 init_stacks||5.005000|
2155 is_handle_constructor|||
2156 is_list_assignment|||
2157 is_lvalue_sub||5.007001|
2158 is_uni_alnum_lc||5.006000|
2159 is_uni_alnumc_lc||5.006000|
2160 is_uni_alnumc||5.006000|
2161 is_uni_alnum||5.006000|
2162 is_uni_alpha_lc||5.006000|
2163 is_uni_alpha||5.006000|
2164 is_uni_ascii_lc||5.006000|
2165 is_uni_ascii||5.006000|
2166 is_uni_cntrl_lc||5.006000|
2167 is_uni_cntrl||5.006000|
2168 is_uni_digit_lc||5.006000|
2169 is_uni_digit||5.006000|
2170 is_uni_graph_lc||5.006000|
2171 is_uni_graph||5.006000|
2172 is_uni_idfirst_lc||5.006000|
2173 is_uni_idfirst||5.006000|
2174 is_uni_lower_lc||5.006000|
2175 is_uni_lower||5.006000|
2176 is_uni_print_lc||5.006000|
2177 is_uni_print||5.006000|
2178 is_uni_punct_lc||5.006000|
2179 is_uni_punct||5.006000|
2180 is_uni_space_lc||5.006000|
2181 is_uni_space||5.006000|
2182 is_uni_upper_lc||5.006000|
2183 is_uni_upper||5.006000|
2184 is_uni_xdigit_lc||5.006000|
2185 is_uni_xdigit||5.006000|
2186 is_utf8_alnumc||5.006000|
2187 is_utf8_alnum||5.006000|
2188 is_utf8_alpha||5.006000|
2189 is_utf8_ascii||5.006000|
2190 is_utf8_char_slow|||
2191 is_utf8_char||5.006000|
2192 is_utf8_cntrl||5.006000|
2193 is_utf8_digit||5.006000|
2194 is_utf8_graph||5.006000|
2195 is_utf8_idcont||5.008000|
2196 is_utf8_idfirst||5.006000|
2197 is_utf8_lower||5.006000|
2198 is_utf8_mark||5.006000|
2199 is_utf8_print||5.006000|
2200 is_utf8_punct||5.006000|
2201 is_utf8_space||5.006000|
2202 is_utf8_string_loclen||5.009003|
2203 is_utf8_string_loc||5.008001|
2204 is_utf8_string||5.006001|
2205 is_utf8_upper||5.006000|
2206 is_utf8_xdigit||5.006000|
2218 load_module_nocontext|||vn
2219 load_module||5.006000|v
2221 looks_like_number|||
2231 magic_clear_all_env|||
2235 magic_dump||5.006000|
2237 magic_freearylen_p|||
2252 magic_killbackrefs|||
2257 magic_regdata_cnt|||
2258 magic_regdatum_get|||
2259 magic_regdatum_set|||
2261 magic_set_all_env|||
2265 magic_setcollxfrm|||
2306 mg_length||5.005000|
2311 mini_mktime||5.007002|
2313 mode_from_discipline|||
2333 my_failure_exit||5.004000|
2334 my_fflush_all||5.006000|
2357 my_memcmp||5.004000|n
2360 my_pclose||5.004000|
2361 my_popen_list||5.007001|
2364 my_socketpair||5.007003|n
2366 my_strftime||5.007002|
2371 newANONATTRSUB||5.006000|
2376 newATTRSUB||5.006000|
2381 newCONSTSUB|5.006000||p
2405 newRV_inc|5.004000||p
2406 newRV_noinc|5.006000||p
2416 newSVpvf_nocontext|||vn
2417 newSVpvf||5.004000|v
2418 newSVpvn_share||5.007001|
2419 newSVpvn|5.006000||p
2426 newWHILEOP||5.009003|
2427 newXSproto||5.006000|
2429 new_collate||5.006000|
2431 new_ctype||5.006000|
2434 new_numeric||5.006000|
2435 new_stackinfo||5.005000|
2436 new_version||5.009000|
2441 no_bareword_allowed|||
2445 nothreadhook||5.008000|
2456 op_refcnt_lock||5.009002|
2457 op_refcnt_unlock||5.009002|
2459 pMY_CXT_|5.007003||p
2472 pad_compname_type|||
2475 pad_fixup_inner_anons|||
2487 parse_unicode_opts|||
2491 perl_alloc_using|||n
2493 perl_clone_using|||n
2496 perl_destruct||5.007003|n
2498 perl_parse||5.006000|n
2502 pmop_dump||5.006000|
2510 printf_nocontext|||vn
2519 pv_display||5.006000|
2520 pv_uni_display||5.007003|
2524 re_intuit_start||5.006000|
2525 re_intuit_string||5.006000|
2529 reentrant_retry|||vn
2538 regclass_swash||5.007003|
2545 regexec_flags||5.005000|
2551 reginitcolors||5.006000|
2570 require_pv||5.006000|
2574 rsignal_state||5.004000|
2577 runops_debug||5.005000|
2578 runops_standard||5.005000|
2583 safesyscalloc||5.006000|n
2584 safesysfree||5.006000|n
2585 safesysmalloc||5.006000|n
2586 safesysrealloc||5.006000|n
2591 save_aelem||5.004050|
2592 save_alloc||5.006000|
2595 save_bool||5.008001|
2598 save_destructor_x||5.006000|
2599 save_destructor||5.006000|
2603 save_generic_pvref||5.006001|
2604 save_generic_svref||5.005030|
2608 save_helem||5.004050|
2609 save_hints||5.005000|
2618 save_mortalizesv||5.007001|
2621 save_padsv||5.007001|
2623 save_re_context||5.006000|
2626 save_set_svflags||5.009000|
2627 save_shared_pvref||5.007003|
2630 save_threadsv||5.005000|
2631 save_vptr||5.006000|
2634 savesharedpv||5.007003|
2635 savestack_grow_cnt||5.008001|
2659 scan_version||5.009001|
2660 scan_vstring||5.008001|
2663 screaminstr||5.005000|
2665 set_context||5.006000|n
2667 set_numeric_local||5.006000|
2668 set_numeric_radix||5.006000|
2669 set_numeric_standard||5.006000|
2682 start_subparse||5.004000|
2683 stashpv_hvname_match||5.009003|
2691 str_to_version||5.006000|
2702 sv_2iuv_non_preserve|||
2703 sv_2iv_flags||5.009001|
2707 sv_2pv_flags||5.007002|
2708 sv_2pv_nolen|5.006000||p
2710 sv_2pvbyte|5.006000||p
2711 sv_2pvutf8_nolen||5.006000|
2712 sv_2pvutf8||5.006000|
2714 sv_2uv_flags||5.009001|
2720 sv_cat_decode||5.008001|
2721 sv_catpv_mg|5.006000||p
2722 sv_catpvf_mg_nocontext|||pvn
2723 sv_catpvf_mg|5.006000|5.004000|pv
2724 sv_catpvf_nocontext|||vn
2725 sv_catpvf||5.004000|v
2726 sv_catpvn_flags||5.007002|
2727 sv_catpvn_mg|5.006000||p
2728 sv_catpvn_nomg|5.007002||p
2731 sv_catsv_flags||5.007002|
2732 sv_catsv_mg|5.006000||p
2733 sv_catsv_nomg|5.007002||p
2739 sv_cmp_locale||5.004000|
2742 sv_compile_2op||5.008001|
2743 sv_copypv||5.007003|
2746 sv_derived_from||5.004000|
2750 sv_force_normal_flags||5.007001|
2751 sv_force_normal||5.006000|
2762 sv_len_utf8||5.006000|
2764 sv_magicext||5.007003|
2769 sv_nolocking||5.007003|
2770 sv_nosharing||5.007003|
2771 sv_nounlocking||5.007003|
2774 sv_pos_b2u||5.006000|
2775 sv_pos_u2b||5.006000|
2776 sv_pvbyten_force||5.006000|
2777 sv_pvbyten||5.006000|
2778 sv_pvbyte||5.006000|
2779 sv_pvn_force_flags||5.007002|
2781 sv_pvn_nomg|5.007003||p
2783 sv_pvutf8n_force||5.006000|
2784 sv_pvutf8n||5.006000|
2785 sv_pvutf8||5.006000|
2787 sv_recode_to_utf8||5.007003|
2794 sv_rvweaken||5.006000|
2795 sv_setiv_mg|5.006000||p
2797 sv_setnv_mg|5.006000||p
2799 sv_setpv_mg|5.006000||p
2800 sv_setpvf_mg_nocontext|||pvn
2801 sv_setpvf_mg|5.006000|5.004000|pv
2802 sv_setpvf_nocontext|||vn
2803 sv_setpvf||5.004000|v
2804 sv_setpviv_mg||5.008001|
2805 sv_setpviv||5.008001|
2806 sv_setpvn_mg|5.006000||p
2813 sv_setref_uv||5.007001|
2815 sv_setsv_flags||5.007002|
2816 sv_setsv_mg|5.006000||p
2817 sv_setsv_nomg|5.007002||p
2819 sv_setuv_mg|5.006000||p
2820 sv_setuv|5.006000||p
2821 sv_tainted||5.004000|
2825 sv_uni_display||5.007003|
2827 sv_unref_flags||5.007001|
2829 sv_untaint||5.004000|
2831 sv_usepvn_mg|5.006000||p
2833 sv_utf8_decode||5.006000|
2834 sv_utf8_downgrade||5.006000|
2835 sv_utf8_encode||5.006000|
2836 sv_utf8_upgrade_flags||5.007002|
2837 sv_utf8_upgrade||5.007001|
2839 sv_vcatpvf_mg|5.006000|5.004000|p
2840 sv_vcatpvfn||5.004000|
2841 sv_vcatpvf|5.006000|5.004000|p
2842 sv_vsetpvf_mg|5.006000|5.004000|p
2843 sv_vsetpvfn||5.004000|
2844 sv_vsetpvf|5.006000|5.004000|p
2847 swash_fetch||5.007002|
2848 swash_init||5.006000|
2854 tmps_grow||5.006000|
2858 to_uni_fold||5.007003|
2859 to_uni_lower_lc||5.006000|
2860 to_uni_lower||5.007003|
2861 to_uni_title_lc||5.006000|
2862 to_uni_title||5.007003|
2863 to_uni_upper_lc||5.006000|
2864 to_uni_upper||5.007003|
2865 to_utf8_case||5.007003|
2866 to_utf8_fold||5.007003|
2867 to_utf8_lower||5.007003|
2869 to_utf8_title||5.007003|
2870 to_utf8_upper||5.007003|
2873 too_few_arguments|||
2874 too_many_arguments|||
2877 unpack_str||5.007003|
2878 unpackstring||5.008001|
2879 unshare_hek_or_pvn|||
2881 unsharepvn||5.004000|
2882 upg_version||5.009000|
2885 utf16_to_utf8_reversed||5.006001|
2886 utf16_to_utf8||5.006001|
2887 utf16rev_textfilter|||
2888 utf8_distance||5.006000|
2890 utf8_length||5.007001|
2893 utf8_to_bytes||5.006001|
2894 utf8_to_uvchr||5.007001|
2895 utf8_to_uvuni||5.007001|
2896 utf8n_to_uvchr||5.007001|
2897 utf8n_to_uvuni||5.007001|
2899 uvchr_to_utf8_flags||5.007003|
2900 uvchr_to_utf8||5.007001|
2901 uvuni_to_utf8_flags||5.007003|
2902 uvuni_to_utf8||5.007001|
2913 vload_module||5.006000|
2915 vnewSVpvf|5.006000|5.004000|p
2918 vstringify||5.009000|
2923 warner_nocontext|||vn
2935 if (exists $opt{'list-unsupported'}) {
2937 for $f (sort { lc $a cmp lc $b } keys %API) {
2938 next unless $API{$f}{todo};
2939 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
2944 # Scan for possible replacement candidates
2946 my(%replace, %need, %hints, %depends);
2952 if (m{^\s*\*\s(.*?)\s*$}) {
2953 $hints{$hint} ||= ''; # suppress warning with older perls
2954 $hints{$hint} .= "$1\n";
2960 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
2962 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
2963 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
2964 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
2965 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
2967 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
2968 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
2971 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
2974 if (exists $opt{'api-info'}) {
2977 my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
2978 for $f (sort { lc $a cmp lc $b } keys %API) {
2979 next unless $f =~ /$match/;
2980 print "\n=== $f ===\n\n";
2982 if ($API{$f}{base} || $API{$f}{todo}) {
2983 my $base = format_version($API{$f}{base} || $API{$f}{todo});
2984 print "Supported at least starting from perl-$base.\n";
2987 if ($API{$f}{provided}) {
2988 my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
2989 print "Support by $ppport provided back to perl-$todo.\n";
2990 print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
2991 print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
2992 print "$hints{$f}" if exists $hints{$f};
2996 print "No portability information available.\n";
3004 print "Found no API matching '$opt{'api-info'}'.\n";
3009 if (exists $opt{'list-provided'}) {
3011 for $f (sort { lc $a cmp lc $b } keys %API) {
3012 next unless $API{$f}{provided};
3014 push @flags, 'explicit' if exists $need{$f};
3015 push @flags, 'depend' if exists $depends{$f};
3016 push @flags, 'hint' if exists $hints{$f};
3017 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
3024 my @srcext = qw( xs c h cc cpp );
3025 my $srcext = join '|', @srcext;
3029 @files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
3034 File::Find::find(sub {
3035 $File::Find::name =~ /\.($srcext)$/i
3036 and push @files, $File::Find::name;
3040 @files = map { glob "*.$_" } @srcext;
3044 if (!@ARGV || $opt{filter}) {
3046 my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
3048 my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
3049 push @{ $out ? \@out : \@in }, $_;
3051 if (@ARGV && @out) {
3052 warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
3058 die "No input files given!\n";
3061 my(%files, %global, %revreplace);
3062 %revreplace = reverse %replace;
3064 my $patch_opened = 0;
3066 for $filename (@files) {
3067 unless (open IN, "<$filename") {
3068 warn "Unable to read from $filename: $!\n";
3072 info("Scanning $filename ...");
3074 my $c = do { local $/; <IN> };
3077 my %file = (orig => $c, changes => 0);
3079 # temporarily remove C comments from the code
3085 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
3087 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
3091 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
3096 defined $2 and push @ccom, $2;
3097 defined $1 ? $1 : "$ccs$#ccom$cce";
3100 $file{ccom} = \@ccom;
3102 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
3106 for $func (keys %API) {
3108 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
3109 if ($c =~ /\b(?:Perl_)?($match)\b/) {
3110 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
3111 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
3112 if (exists $API{$func}{provided}) {
3113 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
3114 $file{uses}{$func}++;
3115 my @deps = rec_depend($func);
3117 $file{uses_deps}{$func} = \@deps;
3119 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
3122 for ($func, @deps) {
3123 if (exists $need{$_}) {
3124 $file{needs}{$_} = 'static';
3129 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
3130 if ($c =~ /\b$func\b/) {
3131 $file{uses_todo}{$func}++;
3137 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
3138 if (exists $need{$2}) {
3139 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
3142 warning("Possibly wrong #define $1 in $filename");
3146 for (qw(uses needs uses_todo needed_global needed_static)) {
3147 for $func (keys %{$file{$_}}) {
3148 push @{$global{$_}{$func}}, $filename;
3152 $files{$filename} = \%file;
3155 # Globally resolve NEED_'s
3157 for $need (keys %{$global{needs}}) {
3158 if (@{$global{needs}{$need}} > 1) {
3159 my @targets = @{$global{needs}{$need}};
3160 my @t = grep $files{$_}{needed_global}{$need}, @targets;
3161 @targets = @t if @t;
3162 @t = grep /\.xs$/i, @targets;
3163 @targets = @t if @t;
3164 my $target = shift @targets;
3165 $files{$target}{needs}{$need} = 'global';
3166 for (@{$global{needs}{$need}}) {
3167 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
3172 for $filename (@files) {
3173 exists $files{$filename} or next;
3175 info("=== Analyzing $filename ===");
3177 my %file = %{$files{$filename}};
3179 my $c = $file{code};
3181 for $func (sort keys %{$file{uses_Perl}}) {
3182 if ($API{$func}{varargs}) {
3183 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
3184 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
3186 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
3187 $file{changes} += $changes;
3191 warning("Uses Perl_$func instead of $func");
3192 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
3197 for $func (sort keys %{$file{uses_replace}}) {
3198 warning("Uses $func instead of $replace{$func}");
3199 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3202 for $func (sort keys %{$file{uses}}) {
3203 next unless $file{uses}{$func}; # if it's only a dependency
3204 if (exists $file{uses_deps}{$func}) {
3205 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
3207 elsif (exists $replace{$func}) {
3208 warning("Uses $func instead of $replace{$func}");
3209 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3217 for $func (sort keys %{$file{uses_todo}}) {
3218 warning("Uses $func, which may not be portable below perl ",
3219 format_version($API{$func}{todo}));
3222 for $func (sort keys %{$file{needed_static}}) {
3224 if (not exists $file{uses}{$func}) {
3225 $message = "No need to define NEED_$func if $func is never used";
3227 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
3228 $message = "No need to define NEED_$func when already needed globally";
3232 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
3236 for $func (sort keys %{$file{needed_global}}) {
3238 if (not exists $global{uses}{$func}) {
3239 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
3241 elsif (exists $file{needs}{$func}) {
3242 if ($file{needs}{$func} eq 'extern') {
3243 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
3245 elsif ($file{needs}{$func} eq 'static') {
3246 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
3251 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
3255 $file{needs_inc_ppport} = keys %{$file{uses}};
3257 if ($file{needs_inc_ppport}) {
3260 for $func (sort keys %{$file{needs}}) {
3261 my $type = $file{needs}{$func};
3262 next if $type eq 'extern';
3263 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
3264 unless (exists $file{"needed_$type"}{$func}) {
3265 if ($type eq 'global') {
3266 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
3269 diag("File needs $func, adding static request");
3271 $pp .= "#define NEED_$func$suffix\n";
3275 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
3280 unless ($file{has_inc_ppport}) {
3281 diag("Needs to include '$ppport'");
3282 $pp .= qq(#include "$ppport"\n)
3286 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
3287 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
3288 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
3289 || ($c =~ s/^/$pp/);
3293 if ($file{has_inc_ppport}) {
3294 diag("No need to include '$ppport'");
3295 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
3299 # put back in our C comments
3302 my @ccom = @{$file{ccom}};
3303 for $ix (0 .. $#ccom) {
3304 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
3306 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
3309 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
3314 my $s = $cppc != 1 ? 's' : '';
3315 warning("Uses $cppc C++ style comment$s, which is not portable");
3318 if ($file{changes}) {
3319 if (exists $opt{copy}) {
3320 my $newfile = "$filename$opt{copy}";
3322 error("'$newfile' already exists, refusing to write copy of '$filename'");
3326 if (open F, ">$newfile") {
3327 info("Writing copy of '$filename' with changes to '$newfile'");
3332 error("Cannot open '$newfile' for writing: $!");
3336 elsif (exists $opt{patch} || $opt{changes}) {
3337 if (exists $opt{patch}) {
3338 unless ($patch_opened) {
3339 if (open PATCH, ">$opt{patch}") {
3343 error("Cannot open '$opt{patch}' for writing: $!");
3349 mydiff(\*PATCH, $filename, $c);
3353 info("Suggested changes:");
3354 mydiff(\*STDOUT, $filename, $c);
3358 my $s = $file{changes} == 1 ? '' : 's';
3359 info("$file{changes} potentially required change$s detected");
3367 close PATCH if $patch_opened;
3375 my($file, $str) = @_;
3378 if (exists $opt{diff}) {
3379 $diff = run_diff($opt{diff}, $file, $str);
3382 if (!defined $diff and can_use('Text::Diff')) {
3383 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
3384 $diff = <<HEADER . $diff;
3390 if (!defined $diff) {
3391 $diff = run_diff('diff -u', $file, $str);
3394 if (!defined $diff) {
3395 $diff = run_diff('diff', $file, $str);
3398 if (!defined $diff) {
3399 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
3409 my($prog, $file, $str) = @_;
3410 my $tmp = 'dppptemp';
3415 while (-e "$tmp.$suf") { $suf++ }
3418 if (open F, ">$tmp") {
3422 if (open F, "$prog $file $tmp |") {
3424 s/\Q$tmp\E/$file.patched/;
3435 error("Cannot open '$tmp' for writing: $!");
3451 return () unless exists $depends{$func};
3452 grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
3459 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
3460 return ($1, $2, $3);
3462 elsif ($ver !~ /^\d+\.[\d_]+$/) {
3463 die "cannot parse version '$ver'\n";
3467 $ver =~ s/$/000000/;
3469 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3474 if ($r < 5 || ($r == 5 && $v < 6)) {
3476 die "cannot parse version '$ver'\n";
3480 return ($r, $v, $s);
3487 $ver =~ s/$/000000/;
3488 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3493 if ($r < 5 || ($r == 5 && $v < 6)) {
3495 die "invalid version '$ver'\n";
3499 $ver = sprintf "%d.%03d", $r, $v;
3500 $s > 0 and $ver .= sprintf "_%02d", $s;
3505 return sprintf "%d.%d.%d", $r, $v, $s;
3510 $opt{quiet} and return;
3516 $opt{quiet} and return;
3517 $opt{diag} and print @_, "\n";
3522 $opt{quiet} and return;
3523 print "*** ", @_, "\n";
3528 print "*** ERROR: ", @_, "\n";
3534 $opt{quiet} and return;
3535 $opt{hints} or return;
3537 exists $hints{$func} or return;
3538 $given_hints{$func}++ and return;
3539 my $hint = $hints{$func};
3541 print " --- hint for $func ---\n", $hint;
3546 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
3547 my %M = ( 'I' => '*' );
3548 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
3549 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
3555 See perldoc $0 for details.
3565 #ifndef _P_P_PORTABILITY_H_
3566 #define _P_P_PORTABILITY_H_
3568 #ifndef DPPP_NAMESPACE
3569 # define DPPP_NAMESPACE DPPP_
3572 #define DPPP_CAT2(x,y) CAT2(x,y)
3573 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
3575 #ifndef PERL_REVISION
3576 # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
3577 # define PERL_PATCHLEVEL_H_IMPLICIT
3578 # include <patchlevel.h>
3580 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
3581 # include <could_not_find_Perl_patchlevel.h>
3583 # ifndef PERL_REVISION
3584 # define PERL_REVISION (5)
3586 # define PERL_VERSION PATCHLEVEL
3587 # define PERL_SUBVERSION SUBVERSION
3588 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
3593 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
3595 /* It is very unlikely that anyone will try to use this with Perl 6
3596 (or greater), but who knows.
3598 #if PERL_REVISION != 5
3599 # error ppport.h only works with Perl version 5
3600 #endif /* PERL_REVISION != 5 */
3603 # include <limits.h>
3606 #ifndef PERL_UCHAR_MIN
3607 # define PERL_UCHAR_MIN ((unsigned char)0)
3610 #ifndef PERL_UCHAR_MAX
3612 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
3615 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
3617 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
3622 #ifndef PERL_USHORT_MIN
3623 # define PERL_USHORT_MIN ((unsigned short)0)
3626 #ifndef PERL_USHORT_MAX
3628 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
3631 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
3634 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
3636 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
3642 #ifndef PERL_SHORT_MAX
3644 # define PERL_SHORT_MAX ((short)SHORT_MAX)
3646 # ifdef MAXSHORT /* Often used in <values.h> */
3647 # define PERL_SHORT_MAX ((short)MAXSHORT)
3650 # define PERL_SHORT_MAX ((short)SHRT_MAX)
3652 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
3658 #ifndef PERL_SHORT_MIN
3660 # define PERL_SHORT_MIN ((short)SHORT_MIN)
3663 # define PERL_SHORT_MIN ((short)MINSHORT)
3666 # define PERL_SHORT_MIN ((short)SHRT_MIN)
3668 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
3674 #ifndef PERL_UINT_MAX
3676 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
3679 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
3681 # define PERL_UINT_MAX (~(unsigned int)0)
3686 #ifndef PERL_UINT_MIN
3687 # define PERL_UINT_MIN ((unsigned int)0)
3690 #ifndef PERL_INT_MAX
3692 # define PERL_INT_MAX ((int)INT_MAX)
3694 # ifdef MAXINT /* Often used in <values.h> */
3695 # define PERL_INT_MAX ((int)MAXINT)
3697 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
3702 #ifndef PERL_INT_MIN
3704 # define PERL_INT_MIN ((int)INT_MIN)
3707 # define PERL_INT_MIN ((int)MININT)
3709 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
3714 #ifndef PERL_ULONG_MAX
3716 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
3719 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
3721 # define PERL_ULONG_MAX (~(unsigned long)0)
3726 #ifndef PERL_ULONG_MIN
3727 # define PERL_ULONG_MIN ((unsigned long)0L)
3730 #ifndef PERL_LONG_MAX
3732 # define PERL_LONG_MAX ((long)LONG_MAX)
3735 # define PERL_LONG_MAX ((long)MAXLONG)
3737 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
3742 #ifndef PERL_LONG_MIN
3744 # define PERL_LONG_MIN ((long)LONG_MIN)
3747 # define PERL_LONG_MIN ((long)MINLONG)
3749 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
3754 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
3755 # ifndef PERL_UQUAD_MAX
3756 # ifdef ULONGLONG_MAX
3757 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
3759 # ifdef MAXULONGLONG
3760 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
3762 # define PERL_UQUAD_MAX (~(unsigned long long)0)
3767 # ifndef PERL_UQUAD_MIN
3768 # define PERL_UQUAD_MIN ((unsigned long long)0L)
3771 # ifndef PERL_QUAD_MAX
3772 # ifdef LONGLONG_MAX
3773 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
3776 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
3778 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
3783 # ifndef PERL_QUAD_MIN
3784 # ifdef LONGLONG_MIN
3785 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
3788 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
3790 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
3796 /* This is based on code from 5.003 perl.h */
3804 # define IV_MIN PERL_INT_MIN
3808 # define IV_MAX PERL_INT_MAX
3812 # define UV_MIN PERL_UINT_MIN
3816 # define UV_MAX PERL_UINT_MAX
3821 # define IVSIZE INTSIZE
3826 # if defined(convex) || defined(uts)
3828 # define IVTYPE long long
3832 # define IV_MIN PERL_QUAD_MIN
3836 # define IV_MAX PERL_QUAD_MAX
3840 # define UV_MIN PERL_UQUAD_MIN
3844 # define UV_MAX PERL_UQUAD_MAX
3847 # ifdef LONGLONGSIZE
3849 # define IVSIZE LONGLONGSIZE
3855 # define IVTYPE long
3859 # define IV_MIN PERL_LONG_MIN
3863 # define IV_MAX PERL_LONG_MAX
3867 # define UV_MIN PERL_ULONG_MIN
3871 # define UV_MAX PERL_ULONG_MAX
3876 # define IVSIZE LONGSIZE
3886 #ifndef PERL_QUAD_MIN
3887 # define PERL_QUAD_MIN IV_MIN
3890 #ifndef PERL_QUAD_MAX
3891 # define PERL_QUAD_MAX IV_MAX
3894 #ifndef PERL_UQUAD_MIN
3895 # define PERL_UQUAD_MIN UV_MIN
3898 #ifndef PERL_UQUAD_MAX
3899 # define PERL_UQUAD_MAX UV_MAX
3904 # define IVTYPE long
3908 # define IV_MIN PERL_LONG_MIN
3912 # define IV_MAX PERL_LONG_MAX
3916 # define UV_MIN PERL_ULONG_MIN
3920 # define UV_MAX PERL_ULONG_MAX
3927 # define IVSIZE LONGSIZE
3929 # define IVSIZE 4 /* A bold guess, but the best we can make. */
3933 # define UVTYPE unsigned IVTYPE
3937 # define UVSIZE IVSIZE
3941 # define sv_setuv(sv, uv) \
3944 if (TeMpUv <= IV_MAX) \
3945 sv_setiv(sv, TeMpUv); \
3947 sv_setnv(sv, (double)TeMpUv); \
3952 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
3955 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
3959 # define SvUVX(sv) ((UV)SvIVX(sv))
3963 # define SvUVXx(sv) SvUVX(sv)
3967 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
3971 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
3975 * Always use the SvUVx() macro instead of sv_uv().
3978 # define sv_uv(sv) SvUVx(sv)
3981 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
3985 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
3988 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
3992 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
3995 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
3997 # define PL_DBsingle DBsingle
3998 # define PL_DBsub DBsub
4000 # define PL_compiling compiling
4001 # define PL_copline copline
4002 # define PL_curcop curcop
4003 # define PL_curstash curstash
4004 # define PL_debstash debstash
4005 # define PL_defgv defgv
4006 # define PL_diehook diehook
4007 # define PL_dirty dirty
4008 # define PL_dowarn dowarn
4009 # define PL_errgv errgv
4010 # define PL_hexdigit hexdigit
4011 # define PL_hints hints
4013 # define PL_no_modify no_modify
4014 # define PL_perl_destruct_level perl_destruct_level
4015 # define PL_perldb perldb
4016 # define PL_ppaddr ppaddr
4017 # define PL_rsfp_filters rsfp_filters
4018 # define PL_rsfp rsfp
4019 # define PL_stack_base stack_base
4020 # define PL_stack_sp stack_sp
4021 # define PL_stdingv stdingv
4022 # define PL_sv_arenaroot sv_arenaroot
4023 # define PL_sv_no sv_no
4024 # define PL_sv_undef sv_undef
4025 # define PL_sv_yes sv_yes
4026 # define PL_tainted tainted
4027 # define PL_tainting tainting
4031 #ifndef PERL_UNUSED_DECL
4032 # ifdef HASATTRIBUTE
4033 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
4034 # define PERL_UNUSED_DECL
4036 # define PERL_UNUSED_DECL __attribute__((unused))
4039 # define PERL_UNUSED_DECL
4043 # define NOOP (void)0
4047 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
4051 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
4052 # define NVTYPE long double
4054 # define NVTYPE double
4061 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
4063 # define INT2PTR(any,d) (any)(d)
4065 # if PTRSIZE == LONGSIZE
4066 # define PTRV unsigned long
4068 # define PTRV unsigned
4070 # define INT2PTR(any,d) (any)(PTRV)(d)
4073 # define NUM2PTR(any,d) (any)(PTRV)(d)
4074 # define PTR2IV(p) INT2PTR(IV,p)
4075 # define PTR2UV(p) INT2PTR(UV,p)
4076 # define PTR2NV(p) NUM2PTR(NV,p)
4078 # if PTRSIZE == LONGSIZE
4079 # define PTR2ul(p) (unsigned long)(p)
4081 # define PTR2ul(p) INT2PTR(unsigned long,p)
4084 #endif /* !INT2PTR */
4086 #undef START_EXTERN_C
4090 # define START_EXTERN_C extern "C" {
4091 # define END_EXTERN_C }
4092 # define EXTERN_C extern "C"
4094 # define START_EXTERN_C
4095 # define END_EXTERN_C
4096 # define EXTERN_C extern
4099 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
4100 # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
4101 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
4107 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
4108 # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
4111 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
4112 # define STMT_START if (1)
4113 # define STMT_END else (void)0
4115 # define STMT_START do
4116 # define STMT_END while (0)
4120 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
4123 /* DEFSV appears first in 5.004_56 */
4125 # define DEFSV GvSV(PL_defgv)
4129 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
4132 /* Older perls (<=5.003) lack AvFILLp */
4134 # define AvFILLp AvFILL
4137 # define ERRSV get_sv("@",FALSE)
4140 # define newSVpvn(data,len) ((data) \
4141 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
4145 /* Hint: gv_stashpvn
4146 * This function's backport doesn't support the length parameter, but
4147 * rather ignores it. Portability can only be ensured if the length
4148 * parameter is used for speed reasons, but the length can always be
4149 * correctly computed from the string argument.
4152 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
4157 # define get_cv perl_get_cv
4161 # define get_sv perl_get_sv
4165 # define get_av perl_get_av
4169 # define get_hv perl_get_hv
4176 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
4180 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
4185 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
4189 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
4194 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
4198 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
4203 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
4208 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
4213 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
4216 # define dUNDERBAR dNOOP
4220 # define UNDERBAR DEFSV
4223 # define dAX I32 ax = MARK - PL_stack_base + 1
4227 # define dITEMS I32 items = SP - MARK
4230 # define dXSTARG SV * targ = sv_newmortal()
4240 # define dTHXa(x) dNOOP
4258 # define dTHXoa(x) dTHXa(x)
4261 # define PUSHmortal PUSHs(sv_newmortal())
4265 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
4269 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
4273 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
4277 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
4280 # define XPUSHmortal XPUSHs(sv_newmortal())
4284 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
4288 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
4292 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
4296 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
4301 # define call_sv perl_call_sv
4305 # define call_pv perl_call_pv
4309 # define call_argv perl_call_argv
4313 # define call_method perl_call_method
4316 # define eval_sv perl_eval_sv
4321 /* Replace perl_eval_pv with eval_pv */
4322 /* eval_pv depends on eval_sv */
4325 #if defined(NEED_eval_pv)
4326 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4329 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4335 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
4336 #define Perl_eval_pv DPPP_(my_eval_pv)
4338 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
4341 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
4344 SV* sv = newSVpv(p, 0);
4347 eval_sv(sv, G_SCALAR);
4354 if (croak_on_error && SvTRUE(GvSV(errgv)))
4355 croak(SvPVx(GvSV(errgv), na));
4363 # define newRV_inc(sv) newRV(sv) /* Replace */
4367 #if defined(NEED_newRV_noinc)
4368 static SV * DPPP_(my_newRV_noinc)(SV *sv);
4371 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
4377 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
4378 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
4380 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
4382 DPPP_(my_newRV_noinc)(SV *sv)
4384 SV *rv = (SV *)newRV(sv);
4391 /* Hint: newCONSTSUB
4392 * Returns a CV* as of perl-5.7.1. This return value is not supported
4396 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
4397 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
4398 #if defined(NEED_newCONSTSUB)
4399 static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4402 extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4408 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
4409 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
4411 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
4414 DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
4416 U32 oldhints = PL_hints;
4417 HV *old_cop_stash = PL_curcop->cop_stash;
4418 HV *old_curstash = PL_curstash;
4419 line_t oldline = PL_curcop->cop_line;
4420 PL_curcop->cop_line = PL_copline;
4422 PL_hints &= ~HINT_BLOCK_SCOPE;
4424 PL_curstash = PL_curcop->cop_stash = stash;
4428 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
4430 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
4432 #else /* 5.003_23 onwards */
4433 start_subparse(FALSE, 0),
4436 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4437 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4438 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4441 PL_hints = oldhints;
4442 PL_curcop->cop_stash = old_cop_stash;
4443 PL_curstash = old_curstash;
4444 PL_curcop->cop_line = oldline;
4450 * Boilerplate macros for initializing and accessing interpreter-local
4451 * data from C. All statics in extensions should be reworked to use
4452 * this, if you want to make the extension thread-safe. See ext/re/re.xs
4453 * for an example of the use of these macros.
4455 * Code that uses these macros is responsible for the following:
4456 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
4457 * 2. Declare a typedef named my_cxt_t that is a structure that contains
4458 * all the data that needs to be interpreter-local.
4459 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
4460 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
4461 * (typically put in the BOOT: section).
4462 * 5. Use the members of the my_cxt_t structure everywhere as
4464 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
4468 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
4469 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
4471 #ifndef START_MY_CXT
4473 /* This must appear in all extensions that define a my_cxt_t structure,
4474 * right after the definition (i.e. at file scope). The non-threads
4475 * case below uses it to declare the data as static. */
4476 #define START_MY_CXT
4478 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
4479 /* Fetches the SV that keeps the per-interpreter data. */
4480 #define dMY_CXT_SV \
4481 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
4482 #else /* >= perl5.004_68 */
4483 #define dMY_CXT_SV \
4484 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
4485 sizeof(MY_CXT_KEY)-1, TRUE)
4486 #endif /* < perl5.004_68 */
4488 /* This declaration should be used within all functions that use the
4489 * interpreter-local data. */
4492 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
4494 /* Creates and zeroes the per-interpreter data.
4495 * (We allocate my_cxtp in a Perl SV so that it will be released when
4496 * the interpreter goes away.) */
4497 #define MY_CXT_INIT \
4499 /* newSV() allocates one more than needed */ \
4500 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4501 Zero(my_cxtp, 1, my_cxt_t); \
4502 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4504 /* This macro must be used to access members of the my_cxt_t structure.
4505 * e.g. MYCXT.some_data */
4506 #define MY_CXT (*my_cxtp)
4508 /* Judicious use of these macros can reduce the number of times dMY_CXT
4509 * is used. Use is similar to pTHX, aTHX etc. */
4510 #define pMY_CXT my_cxt_t *my_cxtp
4511 #define pMY_CXT_ pMY_CXT,
4512 #define _pMY_CXT ,pMY_CXT
4513 #define aMY_CXT my_cxtp
4514 #define aMY_CXT_ aMY_CXT,
4515 #define _aMY_CXT ,aMY_CXT
4517 #endif /* START_MY_CXT */
4519 #ifndef MY_CXT_CLONE
4520 /* Clones the per-interpreter data. */
4521 #define MY_CXT_CLONE \
4523 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4524 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
4525 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4528 #else /* single interpreter */
4530 #ifndef START_MY_CXT
4532 #define START_MY_CXT static my_cxt_t my_cxt;
4533 #define dMY_CXT_SV dNOOP
4534 #define dMY_CXT dNOOP
4535 #define MY_CXT_INIT NOOP
4536 #define MY_CXT my_cxt
4538 #define pMY_CXT void
4545 #endif /* START_MY_CXT */
4547 #ifndef MY_CXT_CLONE
4548 #define MY_CXT_CLONE NOOP
4554 # if IVSIZE == LONGSIZE
4561 # if IVSIZE == INTSIZE
4572 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
4573 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
4574 # define NVef PERL_PRIeldbl
4575 # define NVff PERL_PRIfldbl
4576 # define NVgf PERL_PRIgldbl
4586 #if defined(NEED_sv_2pv_nolen)
4587 static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4590 extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4594 # undef sv_2pv_nolen
4596 #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
4597 #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
4599 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
4602 DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
4605 return sv_2pv(sv, &n_a);
4610 /* Hint: sv_2pv_nolen
4611 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
4614 /* SvPV_nolen depends on sv_2pv_nolen */
4615 #define SvPV_nolen(sv) \
4616 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
4617 ? SvPVX(sv) : sv_2pv_nolen(sv))
4624 * Does not work in perl-5.6.1, ppport.h implements a version
4625 * borrowed from perl-5.7.3.
4628 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
4630 #if defined(NEED_sv_2pvbyte)
4631 static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4634 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4640 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
4641 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
4643 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
4646 DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
4648 sv_utf8_downgrade(sv,0);
4649 return SvPV(sv,*lp);
4655 * Use the SvPVbyte() macro instead of sv_2pvbyte().
4660 /* SvPVbyte depends on sv_2pvbyte */
4661 #define SvPVbyte(sv, lp) \
4662 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
4663 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
4669 # define SvPVbyte SvPV
4670 # define sv_2pvbyte sv_2pv
4674 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
4675 #ifndef sv_2pvbyte_nolen
4676 # define sv_2pvbyte_nolen sv_2pv_nolen
4680 * Always use the SvPV() macro instead of sv_pvn().
4683 # define sv_pvn(sv, len) SvPV(sv, len)
4686 /* Hint: sv_pvn_force
4687 * Always use the SvPV_force() macro instead of sv_pvn_force().
4689 #ifndef sv_pvn_force
4690 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
4693 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
4694 #if defined(NEED_vnewSVpvf)
4695 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4698 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4704 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
4705 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
4707 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
4710 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
4712 register SV *sv = newSV(0);
4713 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4720 /* sv_vcatpvf depends on sv_vcatpvfn */
4721 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
4722 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4725 /* sv_vsetpvf depends on sv_vsetpvfn */
4726 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
4727 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4730 /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
4731 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
4732 #if defined(NEED_sv_catpvf_mg)
4733 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4736 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4739 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
4741 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
4744 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4747 va_start(args, pat);
4748 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4756 /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
4757 #ifdef PERL_IMPLICIT_CONTEXT
4758 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
4759 #if defined(NEED_sv_catpvf_mg_nocontext)
4760 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4763 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4766 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4767 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4769 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
4772 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4776 va_start(args, pat);
4777 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4786 #ifndef sv_catpvf_mg
4787 # ifdef PERL_IMPLICIT_CONTEXT
4788 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
4790 # define sv_catpvf_mg Perl_sv_catpvf_mg
4794 /* sv_vcatpvf_mg depends on sv_vcatpvfn */
4795 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
4796 # define sv_vcatpvf_mg(sv, pat, args) \
4798 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4803 /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
4804 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
4805 #if defined(NEED_sv_setpvf_mg)
4806 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4809 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4812 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
4814 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
4817 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4820 va_start(args, pat);
4821 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4829 /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
4830 #ifdef PERL_IMPLICIT_CONTEXT
4831 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
4832 #if defined(NEED_sv_setpvf_mg_nocontext)
4833 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4836 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4839 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4840 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4842 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
4845 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4849 va_start(args, pat);
4850 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4859 #ifndef sv_setpvf_mg
4860 # ifdef PERL_IMPLICIT_CONTEXT
4861 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
4863 # define sv_setpvf_mg Perl_sv_setpvf_mg
4867 /* sv_vsetpvf_mg depends on sv_vsetpvfn */
4868 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
4869 # define sv_vsetpvf_mg(sv, pat, args) \
4871 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4876 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
4878 #ifndef PERL_MAGIC_sv
4879 # define PERL_MAGIC_sv '\0'
4882 #ifndef PERL_MAGIC_overload
4883 # define PERL_MAGIC_overload 'A'
4886 #ifndef PERL_MAGIC_overload_elem
4887 # define PERL_MAGIC_overload_elem 'a'
4890 #ifndef PERL_MAGIC_overload_table
4891 # define PERL_MAGIC_overload_table 'c'
4894 #ifndef PERL_MAGIC_bm
4895 # define PERL_MAGIC_bm 'B'
4898 #ifndef PERL_MAGIC_regdata
4899 # define PERL_MAGIC_regdata 'D'
4902 #ifndef PERL_MAGIC_regdatum
4903 # define PERL_MAGIC_regdatum 'd'
4906 #ifndef PERL_MAGIC_env
4907 # define PERL_MAGIC_env 'E'
4910 #ifndef PERL_MAGIC_envelem
4911 # define PERL_MAGIC_envelem 'e'
4914 #ifndef PERL_MAGIC_fm
4915 # define PERL_MAGIC_fm 'f'
4918 #ifndef PERL_MAGIC_regex_global
4919 # define PERL_MAGIC_regex_global 'g'
4922 #ifndef PERL_MAGIC_isa
4923 # define PERL_MAGIC_isa 'I'
4926 #ifndef PERL_MAGIC_isaelem
4927 # define PERL_MAGIC_isaelem 'i'
4930 #ifndef PERL_MAGIC_nkeys
4931 # define PERL_MAGIC_nkeys 'k'
4934 #ifndef PERL_MAGIC_dbfile
4935 # define PERL_MAGIC_dbfile 'L'
4938 #ifndef PERL_MAGIC_dbline
4939 # define PERL_MAGIC_dbline 'l'
4942 #ifndef PERL_MAGIC_mutex
4943 # define PERL_MAGIC_mutex 'm'
4946 #ifndef PERL_MAGIC_shared
4947 # define PERL_MAGIC_shared 'N'
4950 #ifndef PERL_MAGIC_shared_scalar
4951 # define PERL_MAGIC_shared_scalar 'n'
4954 #ifndef PERL_MAGIC_collxfrm
4955 # define PERL_MAGIC_collxfrm 'o'
4958 #ifndef PERL_MAGIC_tied
4959 # define PERL_MAGIC_tied 'P'
4962 #ifndef PERL_MAGIC_tiedelem
4963 # define PERL_MAGIC_tiedelem 'p'
4966 #ifndef PERL_MAGIC_tiedscalar
4967 # define PERL_MAGIC_tiedscalar 'q'
4970 #ifndef PERL_MAGIC_qr
4971 # define PERL_MAGIC_qr 'r'
4974 #ifndef PERL_MAGIC_sig
4975 # define PERL_MAGIC_sig 'S'
4978 #ifndef PERL_MAGIC_sigelem
4979 # define PERL_MAGIC_sigelem 's'
4982 #ifndef PERL_MAGIC_taint
4983 # define PERL_MAGIC_taint 't'
4986 #ifndef PERL_MAGIC_uvar
4987 # define PERL_MAGIC_uvar 'U'
4990 #ifndef PERL_MAGIC_uvar_elem
4991 # define PERL_MAGIC_uvar_elem 'u'
4994 #ifndef PERL_MAGIC_vstring
4995 # define PERL_MAGIC_vstring 'V'
4998 #ifndef PERL_MAGIC_vec
4999 # define PERL_MAGIC_vec 'v'
5002 #ifndef PERL_MAGIC_utf8
5003 # define PERL_MAGIC_utf8 'w'
5006 #ifndef PERL_MAGIC_substr
5007 # define PERL_MAGIC_substr 'x'
5010 #ifndef PERL_MAGIC_defelem
5011 # define PERL_MAGIC_defelem 'y'
5014 #ifndef PERL_MAGIC_glob
5015 # define PERL_MAGIC_glob '*'
5018 #ifndef PERL_MAGIC_arylen
5019 # define PERL_MAGIC_arylen '#'
5022 #ifndef PERL_MAGIC_pos
5023 # define PERL_MAGIC_pos '.'
5026 #ifndef PERL_MAGIC_backref
5027 # define PERL_MAGIC_backref '<'
5030 #ifndef PERL_MAGIC_ext
5031 # define PERL_MAGIC_ext '~'
5034 /* That's the best we can do... */
5035 #ifndef SvPV_force_nomg
5036 # define SvPV_force_nomg SvPV_force
5040 # define SvPV_nomg SvPV
5043 #ifndef sv_catpvn_nomg
5044 # define sv_catpvn_nomg sv_catpvn
5047 #ifndef sv_catsv_nomg
5048 # define sv_catsv_nomg sv_catsv
5051 #ifndef sv_setsv_nomg
5052 # define sv_setsv_nomg sv_setsv
5056 # define sv_pvn_nomg sv_pvn
5060 # define SvIV_nomg SvIV
5064 # define SvUV_nomg SvUV
5068 # define sv_catpv_mg(sv, ptr) \
5071 sv_catpv(TeMpSv,ptr); \
5072 SvSETMAGIC(TeMpSv); \
5076 #ifndef sv_catpvn_mg
5077 # define sv_catpvn_mg(sv, ptr, len) \
5080 sv_catpvn(TeMpSv,ptr,len); \
5081 SvSETMAGIC(TeMpSv); \
5086 # define sv_catsv_mg(dsv, ssv) \
5089 sv_catsv(TeMpSv,ssv); \
5090 SvSETMAGIC(TeMpSv); \
5095 # define sv_setiv_mg(sv, i) \
5098 sv_setiv(TeMpSv,i); \
5099 SvSETMAGIC(TeMpSv); \
5104 # define sv_setnv_mg(sv, num) \
5107 sv_setnv(TeMpSv,num); \
5108 SvSETMAGIC(TeMpSv); \
5113 # define sv_setpv_mg(sv, ptr) \
5116 sv_setpv(TeMpSv,ptr); \
5117 SvSETMAGIC(TeMpSv); \
5121 #ifndef sv_setpvn_mg
5122 # define sv_setpvn_mg(sv, ptr, len) \
5125 sv_setpvn(TeMpSv,ptr,len); \
5126 SvSETMAGIC(TeMpSv); \
5131 # define sv_setsv_mg(dsv, ssv) \
5134 sv_setsv(TeMpSv,ssv); \
5135 SvSETMAGIC(TeMpSv); \
5140 # define sv_setuv_mg(sv, i) \
5143 sv_setuv(TeMpSv,i); \
5144 SvSETMAGIC(TeMpSv); \
5148 #ifndef sv_usepvn_mg
5149 # define sv_usepvn_mg(sv, ptr, len) \
5152 sv_usepvn(TeMpSv,ptr,len); \
5153 SvSETMAGIC(TeMpSv); \
5159 # define CopFILE(c) ((c)->cop_file)
5163 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
5167 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
5171 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
5175 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
5179 # define CopSTASHPV(c) ((c)->cop_stashpv)
5182 #ifndef CopSTASHPV_set
5183 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
5187 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
5190 #ifndef CopSTASH_set
5191 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
5195 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
5196 || (CopSTASHPV(c) && HvNAME(hv) \
5197 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
5202 # define CopFILEGV(c) ((c)->cop_filegv)
5205 #ifndef CopFILEGV_set
5206 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
5210 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
5214 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
5218 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
5222 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
5226 # define CopSTASH(c) ((c)->cop_stash)
5229 #ifndef CopSTASH_set
5230 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
5234 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
5237 #ifndef CopSTASHPV_set
5238 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
5242 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
5245 #endif /* USE_ITHREADS */
5246 #ifndef IN_PERL_COMPILETIME
5247 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
5250 #ifndef IN_LOCALE_RUNTIME
5251 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
5254 #ifndef IN_LOCALE_COMPILETIME
5255 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
5259 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
5261 #ifndef IS_NUMBER_IN_UV
5262 # define IS_NUMBER_IN_UV 0x01
5265 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
5266 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
5269 #ifndef IS_NUMBER_NOT_INT
5270 # define IS_NUMBER_NOT_INT 0x04
5273 #ifndef IS_NUMBER_NEG
5274 # define IS_NUMBER_NEG 0x08
5277 #ifndef IS_NUMBER_INFINITY
5278 # define IS_NUMBER_INFINITY 0x10
5281 #ifndef IS_NUMBER_NAN
5282 # define IS_NUMBER_NAN 0x20
5285 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
5286 #ifndef GROK_NUMERIC_RADIX
5287 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
5289 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
5290 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
5293 #ifndef PERL_SCAN_SILENT_ILLDIGIT
5294 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
5297 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
5298 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
5301 #ifndef PERL_SCAN_DISALLOW_PREFIX
5302 # define PERL_SCAN_DISALLOW_PREFIX 0x02
5305 #ifndef grok_numeric_radix
5306 #if defined(NEED_grok_numeric_radix)
5307 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5310 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5313 #ifdef grok_numeric_radix
5314 # undef grok_numeric_radix
5316 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
5317 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
5319 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
5321 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
5323 #ifdef USE_LOCALE_NUMERIC
5324 #ifdef PL_numeric_radix_sv
5325 if (PL_numeric_radix_sv && IN_LOCALE) {
5327 char* radix = SvPV(PL_numeric_radix_sv, len);
5328 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5334 /* older perls don't have PL_numeric_radix_sv so the radix
5335 * must manually be requested from locale.h
5338 dTHR; /* needed for older threaded perls */
5339 struct lconv *lc = localeconv();
5340 char *radix = lc->decimal_point;
5341 if (radix && IN_LOCALE) {
5342 STRLEN len = strlen(radix);
5343 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5348 #endif /* PERL_VERSION */
5349 #endif /* USE_LOCALE_NUMERIC */
5350 /* always try "." if numeric radix didn't match because
5351 * we may have data from different locales mixed */
5352 if (*sp < send && **sp == '.') {
5361 /* grok_number depends on grok_numeric_radix */
5364 #if defined(NEED_grok_number)
5365 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5368 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5374 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
5375 #define Perl_grok_number DPPP_(my_grok_number)
5377 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
5379 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
5382 const char *send = pv + len;
5383 const UV max_div_10 = UV_MAX / 10;
5384 const char max_mod_10 = UV_MAX % 10;
5389 while (s < send && isSPACE(*s))
5393 } else if (*s == '-') {
5395 numtype = IS_NUMBER_NEG;
5403 /* next must be digit or the radix separator or beginning of infinity */
5405 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
5407 UV value = *s - '0';
5408 /* This construction seems to be more optimiser friendly.
5409 (without it gcc does the isDIGIT test and the *s - '0' separately)
5410 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
5411 In theory the optimiser could deduce how far to unroll the loop
5412 before checking for overflow. */
5414 int digit = *s - '0';
5415 if (digit >= 0 && digit <= 9) {
5416 value = value * 10 + digit;
5419 if (digit >= 0 && digit <= 9) {
5420 value = value * 10 + digit;
5423 if (digit >= 0 && digit <= 9) {
5424 value = value * 10 + digit;
5427 if (digit >= 0 && digit <= 9) {
5428 value = value * 10 + digit;
5431 if (digit >= 0 && digit <= 9) {
5432 value = value * 10 + digit;
5435 if (digit >= 0 && digit <= 9) {
5436 value = value * 10 + digit;
5439 if (digit >= 0 && digit <= 9) {
5440 value = value * 10 + digit;
5443 if (digit >= 0 && digit <= 9) {
5444 value = value * 10 + digit;
5446 /* Now got 9 digits, so need to check
5447 each time for overflow. */
5449 while (digit >= 0 && digit <= 9
5450 && (value < max_div_10
5451 || (value == max_div_10
5452 && digit <= max_mod_10))) {
5453 value = value * 10 + digit;
5459 if (digit >= 0 && digit <= 9
5461 /* value overflowed.
5462 skip the remaining digits, don't
5463 worry about setting *valuep. */
5466 } while (s < send && isDIGIT(*s));
5468 IS_NUMBER_GREATER_THAN_UV_MAX;
5488 numtype |= IS_NUMBER_IN_UV;
5493 if (GROK_NUMERIC_RADIX(&s, send)) {
5494 numtype |= IS_NUMBER_NOT_INT;
5495 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
5499 else if (GROK_NUMERIC_RADIX(&s, send)) {
5500 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
5501 /* no digits before the radix means we need digits after it */
5502 if (s < send && isDIGIT(*s)) {
5505 } while (s < send && isDIGIT(*s));
5507 /* integer approximation is valid - it's 0. */
5513 } else if (*s == 'I' || *s == 'i') {
5514 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5515 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
5516 s++; if (s < send && (*s == 'I' || *s == 'i')) {
5517 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5518 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
5519 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
5520 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
5524 } else if (*s == 'N' || *s == 'n') {
5525 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
5526 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
5527 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5534 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5535 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
5536 } else if (sawnan) {
5537 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5538 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
5539 } else if (s < send) {
5540 /* we can have an optional exponent part */
5541 if (*s == 'e' || *s == 'E') {
5542 /* The only flag we keep is sign. Blow away any "it's UV" */
5543 numtype &= IS_NUMBER_NEG;
5544 numtype |= IS_NUMBER_NOT_INT;
5546 if (s < send && (*s == '-' || *s == '+'))
5548 if (s < send && isDIGIT(*s)) {
5551 } while (s < send && isDIGIT(*s));
5557 while (s < send && isSPACE(*s))
5561 if (len == 10 && memEQ(pv, "0 but true", 10)) {
5564 return IS_NUMBER_IN_UV;
5572 * The grok_* routines have been modified to use warn() instead of
5573 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
5574 * which is why the stack variable has been renamed to 'xdigit'.
5578 #if defined(NEED_grok_bin)
5579 static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5582 extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5588 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
5589 #define Perl_grok_bin DPPP_(my_grok_bin)
5591 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
5593 DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5595 const char *s = start;
5596 STRLEN len = *len_p;
5600 const UV max_div_2 = UV_MAX / 2;
5601 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5602 bool overflowed = FALSE;
5604 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5605 /* strip off leading b or 0b.
5606 for compatibility silently suffer "b" and "0b" as valid binary
5613 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
5620 for (; len-- && *s; s++) {
5622 if (bit == '0' || bit == '1') {
5623 /* Write it in this wonky order with a goto to attempt to get the
5624 compiler to make the common case integer-only loop pretty tight.
5625 With gcc seems to be much straighter code than old scan_bin. */
5628 if (value <= max_div_2) {
5629 value = (value << 1) | (bit - '0');
5632 /* Bah. We're just overflowed. */
5633 warn("Integer overflow in binary number");
5635 value_nv = (NV) value;
5638 /* If an NV has not enough bits in its mantissa to
5639 * represent a UV this summing of small low-order numbers
5640 * is a waste of time (because the NV cannot preserve
5641 * the low-order bits anyway): we could just remember when
5642 * did we overflow and in the end just multiply value_nv by the
5644 value_nv += (NV)(bit - '0');
5647 if (bit == '_' && len && allow_underscores && (bit = s[1])
5648 && (bit == '0' || bit == '1'))
5654 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5655 warn("Illegal binary digit '%c' ignored", *s);
5659 if ( ( overflowed && value_nv > 4294967295.0)
5661 || (!overflowed && value > 0xffffffff )
5664 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
5671 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5680 #if defined(NEED_grok_hex)
5681 static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5684 extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5690 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
5691 #define Perl_grok_hex DPPP_(my_grok_hex)
5693 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
5695 DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5697 const char *s = start;
5698 STRLEN len = *len_p;
5702 const UV max_div_16 = UV_MAX / 16;
5703 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5704 bool overflowed = FALSE;
5707 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5708 /* strip off leading x or 0x.
5709 for compatibility silently suffer "x" and "0x" as valid hex numbers.
5716 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
5723 for (; len-- && *s; s++) {
5724 xdigit = strchr((char *) PL_hexdigit, *s);
5726 /* Write it in this wonky order with a goto to attempt to get the
5727 compiler to make the common case integer-only loop pretty tight.
5728 With gcc seems to be much straighter code than old scan_hex. */
5731 if (value <= max_div_16) {
5732 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
5735 warn("Integer overflow in hexadecimal number");
5737 value_nv = (NV) value;
5740 /* If an NV has not enough bits in its mantissa to
5741 * represent a UV this summing of small low-order numbers
5742 * is a waste of time (because the NV cannot preserve
5743 * the low-order bits anyway): we could just remember when
5744 * did we overflow and in the end just multiply value_nv by the
5745 * right amount of 16-tuples. */
5746 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
5749 if (*s == '_' && len && allow_underscores && s[1]
5750 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
5756 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5757 warn("Illegal hexadecimal digit '%c' ignored", *s);
5761 if ( ( overflowed && value_nv > 4294967295.0)
5763 || (!overflowed && value > 0xffffffff )
5766 warn("Hexadecimal number > 0xffffffff non-portable");
5773 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5782 #if defined(NEED_grok_oct)
5783 static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5786 extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5792 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
5793 #define Perl_grok_oct DPPP_(my_grok_oct)
5795 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
5797 DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5799 const char *s = start;
5800 STRLEN len = *len_p;
5804 const UV max_div_8 = UV_MAX / 8;
5805 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5806 bool overflowed = FALSE;
5808 for (; len-- && *s; s++) {
5809 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
5810 out front allows slicker code. */
5811 int digit = *s - '0';
5812 if (digit >= 0 && digit <= 7) {
5813 /* Write it in this wonky order with a goto to attempt to get the
5814 compiler to make the common case integer-only loop pretty tight.
5818 if (value <= max_div_8) {
5819 value = (value << 3) | digit;
5822 /* Bah. We're just overflowed. */
5823 warn("Integer overflow in octal number");
5825 value_nv = (NV) value;
5828 /* If an NV has not enough bits in its mantissa to
5829 * represent a UV this summing of small low-order numbers
5830 * is a waste of time (because the NV cannot preserve
5831 * the low-order bits anyway): we could just remember when
5832 * did we overflow and in the end just multiply value_nv by the
5833 * right amount of 8-tuples. */
5834 value_nv += (NV)digit;
5837 if (digit == ('_' - '0') && len && allow_underscores
5838 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
5844 /* Allow \octal to work the DWIM way (that is, stop scanning
5845 * as soon as non-octal characters are seen, complain only iff
5846 * someone seems to want to use the digits eight and nine). */
5847 if (digit == 8 || digit == 9) {
5848 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5849 warn("Illegal octal digit '%c' ignored", *s);
5854 if ( ( overflowed && value_nv > 4294967295.0)
5856 || (!overflowed && value > 0xffffffff )
5859 warn("Octal number > 037777777777 non-portable");
5866 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5876 # define dXCPT dJMPENV; int rEtV = 0
5877 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
5878 # define XCPT_TRY_END JMPENV_POP;
5879 # define XCPT_CATCH if (rEtV != 0)
5880 # define XCPT_RETHROW JMPENV_JUMP(rEtV)
5882 # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
5883 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
5884 # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
5885 # define XCPT_CATCH if (rEtV != 0)
5886 # define XCPT_RETHROW Siglongjmp(top_env, rEtV)
5890 #endif /* _P_P_PORTABILITY_H_ */
5892 /* End of File ppport.h */
projects / p5sagit/p5-mst-13.2.git / blob