1 ################################################################################
3 # !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
5 ################################################################################
7 # Perl/Pollution/Portability
9 ################################################################################
13 # $Date: 2004/08/17 20:01:49 +0200 $
15 ################################################################################
17 # Version 3.x, Copyright (C) 2004, 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.2 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:
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.2
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:
163 IN_LOCALE_COMPILETIME
167 IS_NUMBER_GREATER_THAN_UV_MAX
202 PERL_GCC_BRACE_GROUPS_FORBIDDEN
224 PERL_MAGIC_overload_elem
225 PERL_MAGIC_overload_table
230 PERL_MAGIC_regex_global
232 PERL_MAGIC_shared_scalar
240 PERL_MAGIC_tiedscalar
249 PERL_SCAN_ALLOW_UNDERSCORES
250 PERL_SCAN_DISALLOW_PREFIX
251 PERL_SCAN_GREATER_THAN_UV_MAX
252 PERL_SCAN_SILENT_ILLDIGIT
284 PL_perl_destruct_level
321 sv_catpvf_mg_nocontext
333 sv_setpvf_mg_nocontext
370 =head2 Perl API not supported by ppport.h
372 There is still a big part of the API not supported by F<ppport.h>.
373 Either because it doesn't make sense to back-port that part of the API,
374 or simply because it hasn't been implemented yet. Patches welcome!
376 Here's a list of the currently unsupported API, and also the version of
377 Perl below which it is unsupported:
390 hv_clear_placeholders
466 gv_fetchmeth_autoload
515 sv_utf8_upgrade_flags
533 sv_force_normal_flags
554 utf16_to_utf8_reversed
787 gv_fetchmethod_autoload
831 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
832 system or any of its tests fail, please use the CPAN Request Tracker
833 at L<http://rt.cpan.org/> to create a ticket for the module.
841 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
845 Version 2.x was ported to the Perl core by Paul Marquess.
849 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
855 Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz.
857 Version 2.x, Copyright (C) 2001, Paul Marquess.
859 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
861 This program is free software; you can redistribute it and/or
862 modify it under the same terms as Perl itself.
866 See L<h2xs>, L<ppport.h>.
870 package Devel::PPPort;
874 use vars qw($VERSION @ISA $data);
876 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.04 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
878 @ISA = qw(DynaLoader);
880 bootstrap Devel::PPPort;
883 $data = do { local $/; <DATA> };
885 my $pkg = 'Devel::PPPort';
886 $data =~ s/__PERL_VERSION__/$]/g;
887 $data =~ s/__VERSION__/$VERSION/g;
888 $data =~ s/__DATE__/$now/g;
889 $data =~ s/__PKG__/$pkg/g;
890 $data =~ s/^POD\s//gm;
895 my $file = shift || 'ppport.h';
897 $copy =~ s/\bppport\.h\b/$file/g;
899 open F, ">$file" or return undef;
913 ----------------------------------------------------------------------
915 ppport.h -- Perl/Pollution/Portability Version __VERSION__
917 Automatically created by __PKG__ running under
918 perl __PERL_VERSION__ on __DATE__.
920 Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
921 includes in parts/inc/ instead.
923 Use 'perldoc ppport.h' to view the documentation below.
925 ----------------------------------------------------------------------
933 POD ppport.h - Perl/Pollution/Portability version __VERSION__
937 POD perl ppport.h [options] [files]
939 POD --help show short help
941 POD --patch=file write one patch file with changes
942 POD --copy=suffix write changed copies with suffix
943 POD --diff=program use diff program and options
945 POD --compat-version=version provide compatibility with Perl version
946 POD --cplusplus accept C++ comments
948 POD --quiet don't output anything except fatal errors
949 POD --nodiag don't show diagnostics
950 POD --nohints don't show hints
951 POD --nochanges don't suggest changes
953 POD --list-provided list provided API
954 POD --list-unsupported list unsupported API
955 POD --api-info=name show Perl API portability information
957 POD =head1 COMPATIBILITY
959 POD This version of F<ppport.h> is designed to support operation with Perl
960 POD installations back to 5.003, and has been tested up to 5.9.2.
966 POD Display a brief usage summary.
968 POD =head2 --patch=I<file>
970 POD If this option is given, a single patch file will be created if
971 POD any changes are suggested. This requires a working diff program
972 POD to be installed on your system.
974 POD =head2 --copy=I<suffix>
976 POD If this option is given, a copy of each file will be saved with
977 POD the given suffix that contains the suggested changes. This does
978 POD not require any external programs.
980 POD If neither C<--patch> or C<--copy> are given, the default is to
981 POD simply print the diffs for each file. This requires either
982 POD C<Text::Diff> or a C<diff> program to be installed.
984 POD =head2 --diff=I<program>
986 POD Manually set the diff program and options to use. The default
987 POD is to use C<Text::Diff>, when installed, and output unified
990 POD =head2 --compat-version=I<version>
992 POD Tell F<ppport.h> to check for compatibility with the given
993 POD Perl version. The default is to check for compatibility with Perl
994 POD version 5.003. You can use this option to reduce the output
995 POD of F<ppport.h> if you intend to be backward compatible only
996 POD up to a certain Perl version.
998 POD =head2 --cplusplus
1000 POD Usually, F<ppport.h> will detect C++ style comments and
1001 POD replace them with C style comments for portability reasons.
1002 POD Using this option instructs F<ppport.h> to leave C++
1003 POD comments untouched.
1007 POD Be quiet. Don't print anything except fatal errors.
1011 POD Don't output any diagnostic messages. Only portability
1012 POD alerts will be printed.
1014 POD =head2 --nohints
1016 POD Don't output any hints. Hints often contain useful portability
1019 POD =head2 --nochanges
1021 POD Don't suggest any changes. Only give diagnostic output and hints
1022 POD unless these are also deactivated.
1024 POD =head2 --list-provided
1026 POD Lists the API elements for which compatibility is provided by
1027 POD F<ppport.h>. Also lists if it must be explicitly requested,
1028 POD if it has dependencies, and if there are hints for it.
1030 POD =head2 --list-unsupported
1032 POD Lists the API elements that are known not to be supported by
1033 POD F<ppport.h> and below which version of Perl they probably
1034 POD won't be available or work.
1036 POD =head2 --api-info=I<name>
1038 POD Show portability information for API elements matching I<name>.
1039 POD I<name> is treated as a Perl regular expression.
1041 POD =head1 DESCRIPTION
1043 POD In order for a Perl extension (XS) module to be as portable as possible
1044 POD across differing versions of Perl itself, certain steps need to be taken.
1050 POD Including this header is the first major one. This alone will give you
1051 POD access to a large part of the Perl API that hasn't been available in
1052 POD earlier Perl releases. Use
1054 POD perl ppport.h --list-provided
1056 POD to see which API elements are provided by ppport.h.
1060 POD You should avoid using deprecated parts of the API. For example, using
1061 POD global Perl variables without the C<PL_> prefix is deprecated. Also,
1062 POD some API functions used to have a C<perl_> prefix. Using this form is
1063 POD also deprecated. You can safely use the supported API, as F<ppport.h>
1064 POD will provide wrappers for older Perl versions.
1068 POD If you use one of a few functions that were not present in earlier
1069 POD versions of Perl, and that can't be provided using a macro, you have
1070 POD to explicitly request support for these functions by adding one or
1071 POD more C<#define>s in your source code before the inclusion of F<ppport.h>.
1073 POD These functions will be marked C<explicit> in the list shown by
1074 POD C<--list-provided>.
1076 POD Depending on whether you module has a single or multiple files that
1077 POD use such functions, you want either C<static> or global variants.
1079 POD For a C<static> function, use:
1081 POD #define NEED_function
1083 POD For a global function, use:
1085 POD #define NEED_function_GLOBAL
1087 POD Note that you mustn't have more than one global request for one
1088 POD function in your project.
1090 POD Function Static Request Global Request
1091 POD -----------------------------------------------------------------------------------------
1092 POD eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
1093 POD grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
1094 POD grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
1095 POD grok_number() NEED_grok_number NEED_grok_number_GLOBAL
1096 POD grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
1097 POD grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
1098 POD newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
1099 POD newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
1100 POD sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
1101 POD sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
1102 POD sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
1103 POD sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
1104 POD sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
1105 POD sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
1106 POD vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
1108 POD To avoid namespace conflicts, you can change the namespace of the
1109 POD explicitly exported functions using the C<DPPP_NAMESPACE> macro.
1110 POD Just C<#define> the macro before including C<ppport.h>:
1112 POD #define DPPP_NAMESPACE MyOwnNamespace_
1113 POD #include "ppport.h"
1115 POD The default namespace is C<DPPP_>.
1119 POD The good thing is that most of the above can be checked by running
1120 POD F<ppport.h> on your source code. See the next section for
1125 POD To verify whether F<ppport.h> is needed for your module, whether you
1126 POD should make any changes to your code, and whether any special defines
1127 POD should be used, F<ppport.h> can be run as a Perl script to check your
1128 POD source code. Simply say:
1132 POD The result will usually be a list of patches suggesting changes
1133 POD that should at least be acceptable, if not necessarily the most
1134 POD efficient solution, or a fix for all possible problems.
1136 POD If you know that your XS module uses features only available in
1137 POD newer Perl releases, if you're aware that it uses C++ comments,
1138 POD and if you want all suggestions as a single patch file, you could
1139 POD use something like this:
1141 POD perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
1143 POD If you only want your code to be scanned without any suggestions
1144 POD for changes, use:
1146 POD perl ppport.h --nochanges
1148 POD You can specify a different C<diff> program or options, using
1149 POD the C<--diff> option:
1151 POD perl ppport.h --diff='diff -C 10'
1153 POD This would output context diffs with 10 lines of context.
1157 POD If this version of F<ppport.h> is causing failure during
1158 POD the compilation of this module, please check if newer versions
1159 POD of either this module or C<Devel::PPPort> are available on CPAN
1160 POD before sending a bug report.
1162 POD If F<ppport.h> was generated using the latest version of
1163 POD C<Devel::PPPort> and is causing failure of this module, please
1164 POD file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
1166 POD Please include the following information:
1172 POD The complete output from running "perl -V"
1180 POD The name and version of the module you were trying to build.
1184 POD A full log of the build that failed.
1188 POD Any other information that you think could be relevant.
1192 POD For the latest version of this code, please get the C<Devel::PPPort>
1193 POD module from CPAN.
1195 POD =head1 COPYRIGHT
1197 POD Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz.
1199 POD Version 2.x, Copyright (C) 2001, Paul Marquess.
1201 POD Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
1203 POD This program is free software; you can redistribute it and/or
1204 POD modify it under the same terms as Perl itself.
1208 POD See L<Devel::PPPort>.
1222 my($ppport) = $0 =~ /([\w.]+)$/;
1223 my $LF = '(?:\r\n|[\r\n])'; # line feed
1224 my $HS = "[ \t]"; # horizontal whitespace
1227 require Getopt::Long;
1228 Getopt::Long::GetOptions(\%opt, qw(
1229 help quiet diag! hints! changes! cplusplus
1230 patch=s copy=s diff=s compat-version=s
1231 list-provided list-unsupported api-info=s
1235 if ($@ and grep /^-/, @ARGV) {
1236 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
1237 die "Getopt::Long not found. Please don't use any options.\n";
1240 usage() if $opt{help};
1242 if (exists $opt{'compat-version'}) {
1243 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
1245 die "Invalid version number format: '$opt{'compat-version'}'\n";
1247 die "Only Perl 5 is supported\n" if $r != 5;
1248 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000;
1249 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
1252 $opt{'compat-version'} = 5;
1255 # Never use C comments in this file!!!!!
1258 my $rccs = quotemeta $ccs;
1259 my $rcce = quotemeta $cce;
1264 @files = map { glob $_ } @ARGV;
1269 File::Find::find(sub {
1270 $File::Find::name =~ /\.(xs|c|h|cc)$/i
1271 and push @files, $File::Find::name;
1275 @files = map { glob $_ } qw(*.xs *.c *.h *.cc);
1277 my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files;
1278 @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files;
1282 die "No input files given!\n";
1285 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
1287 ($2 ? ( base => $2 ) : ()),
1288 ($3 ? ( todo => $3 ) : ()),
1289 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
1290 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
1291 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
1293 : die "invalid spec: $_" } qw(
1299 CopFILEAV|5.006000||p
1300 CopFILEGV_set|5.006000||p
1301 CopFILEGV|5.006000||p
1302 CopFILESV|5.006000||p
1303 CopFILE_set|5.006000||p
1305 CopSTASHPV_set|5.006000||p
1306 CopSTASHPV|5.006000||p
1307 CopSTASH_eq|5.006000||p
1308 CopSTASH_set|5.006000||p
1309 CopSTASH|5.006000||p
1316 END_EXTERN_C|5.005000||p
1320 EXTERN_C|5.005000||p
1324 GROK_NUMERIC_RADIX|5.007002||p
1334 HEf_SVKEY||5.004000|
1339 HeSVKEY_force||5.004000|
1340 HeSVKEY_set||5.004000|
1345 IN_LOCALE_COMPILETIME|5.007002||p
1346 IN_LOCALE_RUNTIME|5.007002||p
1347 IN_LOCALE|5.007002||p
1348 IN_PERL_COMPILETIME|5.008001||p
1349 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
1350 IS_NUMBER_INFINITY|5.007002||p
1351 IS_NUMBER_IN_UV|5.007002||p
1352 IS_NUMBER_NAN|5.007003||p
1353 IS_NUMBER_NEG|5.007002||p
1354 IS_NUMBER_NOT_INT|5.007002||p
1361 MY_CXT_CLONE|5.009002||p
1362 MY_CXT_INIT|5.007003||p
1384 PAD_COMPNAME_FLAGS|||
1386 PAD_COMPNAME_OURSTASH|||
1388 PAD_COMPNAME_TYPE|||
1389 PAD_RESTORE_LOCAL|||
1391 PAD_SAVE_SETNULLPAD|||
1393 PAD_SET_CUR_NOSAVE|||
1397 PERL_BCDVERSION|5.009002||p
1398 PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
1399 PERL_INT_MAX|5.004000||p
1400 PERL_INT_MIN|5.004000||p
1401 PERL_LONG_MAX|5.004000||p
1402 PERL_LONG_MIN|5.004000||p
1403 PERL_MAGIC_arylen|5.007002||p
1404 PERL_MAGIC_backref|5.007002||p
1405 PERL_MAGIC_bm|5.007002||p
1406 PERL_MAGIC_collxfrm|5.007002||p
1407 PERL_MAGIC_dbfile|5.007002||p
1408 PERL_MAGIC_dbline|5.007002||p
1409 PERL_MAGIC_defelem|5.007002||p
1410 PERL_MAGIC_envelem|5.007002||p
1411 PERL_MAGIC_env|5.007002||p
1412 PERL_MAGIC_ext|5.007002||p
1413 PERL_MAGIC_fm|5.007002||p
1414 PERL_MAGIC_glob|5.007002||p
1415 PERL_MAGIC_isaelem|5.007002||p
1416 PERL_MAGIC_isa|5.007002||p
1417 PERL_MAGIC_mutex|5.007002||p
1418 PERL_MAGIC_nkeys|5.007002||p
1419 PERL_MAGIC_overload_elem|5.007002||p
1420 PERL_MAGIC_overload_table|5.007002||p
1421 PERL_MAGIC_overload|5.007002||p
1422 PERL_MAGIC_pos|5.007002||p
1423 PERL_MAGIC_qr|5.007002||p
1424 PERL_MAGIC_regdata|5.007002||p
1425 PERL_MAGIC_regdatum|5.007002||p
1426 PERL_MAGIC_regex_global|5.007002||p
1427 PERL_MAGIC_shared_scalar|5.007003||p
1428 PERL_MAGIC_shared|5.007003||p
1429 PERL_MAGIC_sigelem|5.007002||p
1430 PERL_MAGIC_sig|5.007002||p
1431 PERL_MAGIC_substr|5.007002||p
1432 PERL_MAGIC_sv|5.007002||p
1433 PERL_MAGIC_taint|5.007002||p
1434 PERL_MAGIC_tiedelem|5.007002||p
1435 PERL_MAGIC_tiedscalar|5.007002||p
1436 PERL_MAGIC_tied|5.007002||p
1437 PERL_MAGIC_utf8|5.008001||p
1438 PERL_MAGIC_uvar_elem|5.007003||p
1439 PERL_MAGIC_uvar|5.007002||p
1440 PERL_MAGIC_vec|5.007002||p
1441 PERL_MAGIC_vstring|5.008001||p
1442 PERL_QUAD_MAX|5.004000||p
1443 PERL_QUAD_MIN|5.004000||p
1444 PERL_REVISION|5.006000||p
1445 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
1446 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
1447 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
1448 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
1449 PERL_SHORT_MAX|5.004000||p
1450 PERL_SHORT_MIN|5.004000||p
1451 PERL_SUBVERSION|5.006000||p
1452 PERL_UCHAR_MAX|5.004000||p
1453 PERL_UCHAR_MIN|5.004000||p
1454 PERL_UINT_MAX|5.004000||p
1455 PERL_UINT_MIN|5.004000||p
1456 PERL_ULONG_MAX|5.004000||p
1457 PERL_ULONG_MIN|5.004000||p
1458 PERL_UNUSED_DECL|5.007002||p
1459 PERL_UQUAD_MAX|5.004000||p
1460 PERL_UQUAD_MIN|5.004000||p
1461 PERL_USHORT_MAX|5.004000||p
1462 PERL_USHORT_MIN|5.004000||p
1463 PERL_VERSION|5.006000||p
1468 PL_compiling|5.004050||p
1469 PL_copline|5.005000||p
1470 PL_curcop|5.004050||p
1471 PL_curstash|5.004050||p
1472 PL_debstash|5.004050||p
1473 PL_defgv|5.004050||p
1474 PL_diehook|5.004050||p
1475 PL_dirty|5.004050||p
1477 PL_errgv|5.004050||p
1478 PL_hexdigit|5.005000||p
1479 PL_hints|5.005000||p
1481 PL_modglobal||5.005000|n
1483 PL_no_modify|5.006000||p
1485 PL_perl_destruct_level|5.004050||p
1486 PL_perldb|5.004050||p
1487 PL_ppaddr|5.006000||p
1488 PL_rsfp_filters|5.004050||p
1491 PL_stack_base|5.004050||p
1492 PL_stack_sp|5.004050||p
1493 PL_stdingv|5.004050||p
1494 PL_sv_arenaroot|5.004050||p
1495 PL_sv_no|5.004050||pn
1496 PL_sv_undef|5.004050||pn
1497 PL_sv_yes|5.004050||pn
1498 PL_tainted|5.004050||p
1499 PL_tainting|5.004050||p
1503 POPpbytex||5.007001|n
1514 PUSHmortal|5.009002||p
1520 PerlIO_clearerr||5.007003|
1521 PerlIO_close||5.007003|
1522 PerlIO_eof||5.007003|
1523 PerlIO_error||5.007003|
1524 PerlIO_fileno||5.007003|
1525 PerlIO_fill||5.007003|
1526 PerlIO_flush||5.007003|
1527 PerlIO_get_base||5.007003|
1528 PerlIO_get_bufsiz||5.007003|
1529 PerlIO_get_cnt||5.007003|
1530 PerlIO_get_ptr||5.007003|
1531 PerlIO_read||5.007003|
1532 PerlIO_seek||5.007003|
1533 PerlIO_set_cnt||5.007003|
1534 PerlIO_set_ptrcnt||5.007003|
1535 PerlIO_setlinebuf||5.007003|
1536 PerlIO_stderr||5.007003|
1537 PerlIO_stdin||5.007003|
1538 PerlIO_stdout||5.007003|
1539 PerlIO_tell||5.007003|
1540 PerlIO_unread||5.007003|
1541 PerlIO_write||5.007003|
1550 SAVE_DEFSV|5.004050||p
1553 START_EXTERN_C|5.005000||p
1554 START_MY_CXT|5.007003||p
1572 SvGETMAGIC|5.004050||p
1575 SvIOK_notUV||5.006000|
1577 SvIOK_only_UV||5.006000|
1583 SvIV_nomg|5.009001||p
1586 SvIsCOW_shared_hash||5.008003|
1604 SvPOK_only_UTF8||5.006000|
1610 SvPV_force_nomg|5.007002||p
1612 SvPV_nolen|5.006000||p
1613 SvPV_nomg|5.007002||p
1614 SvPVbyte_force||5.009002|
1615 SvPVbyte_nolen||5.006000|
1616 SvPVbytex_force||5.006000|
1617 SvPVbytex||5.006000|
1618 SvPVbyte|5.006000||p
1619 SvPVutf8_force||5.006000|
1620 SvPVutf8_nolen||5.006000|
1621 SvPVutf8x_force||5.006000|
1622 SvPVutf8x||5.006000|
1636 SvSetMagicSV_nosteal||5.004000|
1637 SvSetMagicSV||5.004000|
1638 SvSetSV_nosteal||5.004000|
1640 SvTAINTED_off||5.004000|
1641 SvTAINTED_on||5.004000|
1642 SvTAINTED||5.004000|
1649 SvUTF8_off||5.006000|
1650 SvUTF8_on||5.006000|
1654 SvUV_nomg|5.009001||p
1659 UNDERBAR|5.009002||p
1667 XPUSHmortal|5.009002||p
1678 XSRETURN_UV|5.008001||p
1688 XS_VERSION_BOOTCHECK|||
1693 _aMY_CXT|5.007003||p
1694 _pMY_CXT|5.007003||p
1695 aMY_CXT_|5.007003||p
1707 apply_attrs_string||5.006001|
1712 atfork_lock||5.007003|n
1713 atfork_unlock||5.007003|n
1715 av_delete||5.006000|
1716 av_exists||5.006000|
1734 block_gimme||5.004000|
1738 boot_core_UNIVERSAL|||
1739 boot_core_xsutils|||
1740 bytes_from_utf8||5.007001|
1741 bytes_to_utf8||5.006001|
1743 call_argv|5.006000||p
1744 call_atexit||5.006000|
1747 call_list||5.004000|
1748 call_method|5.006000||p
1755 cast_ulong||5.006000|
1770 croak_nocontext|||vn
1772 csighandler||5.007001|n
1773 custom_op_desc||5.007003|
1774 custom_op_name||5.007003|
1777 cv_const_sv||5.004000|
1786 dMY_CXT_SV|5.007003||p
1795 dUNDERBAR|5.009002||p
1803 debprofdump||5.005000|
1805 debstackptrs||5.007003|
1827 despatch_signals||5.007001|
1837 do_binmode||5.004050|
1846 do_gv_dump||5.006000|
1847 do_gvgv_dump||5.006000|
1848 do_hv_dump||5.006000|
1853 do_magic_dump||5.006000|
1857 do_op_dump||5.006000|
1862 do_pmop_dump||5.006000|
1871 do_sv_dump||5.006000|
1874 do_trans_complex_utf8|||
1876 do_trans_count_utf8|||
1878 do_trans_simple_utf8|||
1891 doing_taint||5.008001|n
1903 dump_eval||5.006000|
1905 dump_form||5.006000|
1906 dump_indent||5.006000|v
1908 dump_packsubs||5.006000|
1910 dump_vindent||5.006000|
1917 fbm_compile||5.005000|
1918 fbm_instr||5.005000|
1928 find_rundefsvoffset||5.009002|
1941 fprintf_nocontext|||vn
1942 free_tied_hv_pool|||
1944 gen_constant_list|||
1946 get_context||5.006000|n
1955 get_op_descs||5.005000|
1956 get_op_names||5.005000|
1958 get_ppaddr||5.006000|
1961 getcwd_sv||5.007002|
1966 grok_bin|5.007003||p
1967 grok_hex|5.007003||p
1968 grok_number|5.007002||p
1969 grok_numeric_radix|5.007002||p
1970 grok_oct|5.007003||p
1975 gv_autoload4||5.004000|
1978 gv_efullname3||5.004000|
1979 gv_efullname4||5.006001|
1983 gv_fetchmeth_autoload||5.007003|
1984 gv_fetchmethod_autoload||5.004000|
1988 gv_fullname3||5.004000|
1989 gv_fullname4||5.006001|
1991 gv_handler||5.007001|
1995 gv_stashpvn|5.006000||p
2001 hv_assert||5.009001|
2002 hv_clear_placeholders||5.009001|
2004 hv_delayfree_ent||5.004000|
2006 hv_delete_ent||5.004000|
2008 hv_exists_ent||5.004000|
2011 hv_fetch_ent||5.004000|
2013 hv_free_ent||5.004000|
2015 hv_iterkeysv||5.004000|
2017 hv_iternext_flags||5.008000|
2021 hv_ksplit||5.004000|
2025 hv_scalar||5.009001|
2026 hv_store_ent||5.004000|
2027 hv_store_flags||5.008000|
2030 ibcmp_locale||5.004000|
2031 ibcmp_utf8||5.007003|
2037 init_argv_symbols|||
2039 init_i18nl10n||5.006000|
2040 init_i18nl14n||5.006000|
2046 init_postdump_symbols|||
2047 init_predump_symbols|||
2048 init_stacks||5.005000|
2064 is_handle_constructor|||
2065 is_lvalue_sub||5.007001|
2066 is_uni_alnum_lc||5.006000|
2067 is_uni_alnumc_lc||5.006000|
2068 is_uni_alnumc||5.006000|
2069 is_uni_alnum||5.006000|
2070 is_uni_alpha_lc||5.006000|
2071 is_uni_alpha||5.006000|
2072 is_uni_ascii_lc||5.006000|
2073 is_uni_ascii||5.006000|
2074 is_uni_cntrl_lc||5.006000|
2075 is_uni_cntrl||5.006000|
2076 is_uni_digit_lc||5.006000|
2077 is_uni_digit||5.006000|
2078 is_uni_graph_lc||5.006000|
2079 is_uni_graph||5.006000|
2080 is_uni_idfirst_lc||5.006000|
2081 is_uni_idfirst||5.006000|
2082 is_uni_lower_lc||5.006000|
2083 is_uni_lower||5.006000|
2084 is_uni_print_lc||5.006000|
2085 is_uni_print||5.006000|
2086 is_uni_punct_lc||5.006000|
2087 is_uni_punct||5.006000|
2088 is_uni_space_lc||5.006000|
2089 is_uni_space||5.006000|
2090 is_uni_upper_lc||5.006000|
2091 is_uni_upper||5.006000|
2092 is_uni_xdigit_lc||5.006000|
2093 is_uni_xdigit||5.006000|
2094 is_utf8_alnumc||5.006000|
2095 is_utf8_alnum||5.006000|
2096 is_utf8_alpha||5.006000|
2097 is_utf8_ascii||5.006000|
2098 is_utf8_char||5.006000|
2099 is_utf8_cntrl||5.006000|
2100 is_utf8_digit||5.006000|
2101 is_utf8_graph||5.006000|
2102 is_utf8_idcont||5.008000|
2103 is_utf8_idfirst||5.006000|
2104 is_utf8_lower||5.006000|
2105 is_utf8_mark||5.006000|
2106 is_utf8_print||5.006000|
2107 is_utf8_punct||5.006000|
2108 is_utf8_space||5.006000|
2109 is_utf8_string_loc||5.008001|
2110 is_utf8_string||5.006001|
2111 is_utf8_upper||5.006000|
2112 is_utf8_xdigit||5.006000|
2125 load_module_nocontext|||vn
2126 load_module||5.006000|v
2128 looks_like_number|||
2138 magic_clear_all_env|||
2142 magic_dump||5.006000|
2158 magic_killbackrefs|||
2163 magic_regdata_cnt|||
2164 magic_regdatum_get|||
2165 magic_regdatum_set|||
2167 magic_set_all_env|||
2171 magic_setcollxfrm|||
2211 mg_length||5.005000|
2215 mini_mktime||5.007002|
2217 mode_from_discipline|||
2251 my_failure_exit||5.004000|
2252 my_fflush_all||5.006000|
2275 my_memcmp||5.004000|n
2278 my_pclose||5.004000|
2279 my_popen_list||5.007001|
2282 my_socketpair||5.007003|n
2284 my_strftime||5.007002|
2289 newANONATTRSUB||5.006000|
2294 newATTRSUB||5.006000|
2299 newCONSTSUB|5.006000||p
2323 newRV_inc|5.004000||p
2324 newRV_noinc|5.006000||p
2333 newSVpvf_nocontext|||vn
2334 newSVpvf||5.004000|v
2335 newSVpvn_share||5.007001|
2336 newSVpvn|5.006000||p
2343 newWHILEOP||5.004040|
2344 newXSproto||5.006000|
2346 new_collate||5.006000|
2348 new_ctype||5.006000|
2351 new_numeric||5.006000|
2352 new_stackinfo||5.005000|
2353 new_version||5.009000|
2370 no_bareword_allowed|||
2374 nothreadhook||5.008000|
2386 pMY_CXT_|5.007003||p
2401 pad_fixup_inner_anons|||
2413 parse_unicode_opts|||
2417 perl_alloc_using|||n
2419 perl_clone_using|||n
2422 perl_destruct||5.007003|n
2424 perl_parse||5.006000|n
2428 pmop_dump||5.006000|
2436 printf_nocontext|||vn
2445 pv_display||5.006000|
2446 pv_uni_display||5.007003|
2450 re_intuit_start||5.006000|
2451 re_intuit_string||5.006000|
2455 reentrant_retry|||vn
2464 regclass_swash||5.007003|
2471 regexec_flags||5.005000|
2477 reginitcolors||5.006000|
2496 require_pv||5.006000|
2500 rsignal_state||5.004000|
2503 runops_debug||5.005000|
2504 runops_standard||5.005000|
2508 safesyscalloc||5.006000|n
2509 safesysfree||5.006000|n
2510 safesysmalloc||5.006000|n
2511 safesysrealloc||5.006000|n
2516 save_aelem||5.004050|
2517 save_alloc||5.006000|
2520 save_bool||5.008001|
2523 save_destructor_x||5.006000|
2524 save_destructor||5.006000|
2528 save_generic_pvref||5.006001|
2529 save_generic_svref||5.005030|
2533 save_helem||5.004050|
2534 save_hints||5.005000|
2543 save_mortalizesv||5.007001|
2546 save_padsv||5.007001|
2548 save_re_context||5.006000|
2551 save_set_svflags||5.009000|
2552 save_shared_pvref||5.007003|
2555 save_threadsv||5.005000|
2556 save_vptr||5.006000|
2559 savesharedpv||5.007003|
2560 savestack_grow_cnt||5.008001|
2583 scan_version||5.009001|
2584 scan_vstring||5.008001|
2587 screaminstr||5.005000|
2589 set_context||5.006000|n
2591 set_numeric_local||5.006000|
2592 set_numeric_radix||5.006000|
2593 set_numeric_standard||5.006000|
2606 start_subparse||5.004000|
2614 str_to_version||5.006000|
2625 sv_2iuv_non_preserve|||
2626 sv_2iv_flags||5.009001|
2630 sv_2pv_flags||5.007002|
2631 sv_2pv_nolen|5.006000||p
2633 sv_2pvbyte|5.006000||p
2634 sv_2pvutf8_nolen||5.006000|
2635 sv_2pvutf8||5.006000|
2637 sv_2uv_flags||5.009001|
2643 sv_cat_decode||5.008001|
2644 sv_catpv_mg|5.006000||p
2645 sv_catpvf_mg_nocontext|||pvn
2646 sv_catpvf_mg|5.006000|5.004000|pv
2647 sv_catpvf_nocontext|||vn
2648 sv_catpvf||5.004000|v
2649 sv_catpvn_flags||5.007002|
2650 sv_catpvn_mg|5.006000||p
2651 sv_catpvn_nomg|5.007002||p
2654 sv_catsv_flags||5.007002|
2655 sv_catsv_mg|5.006000||p
2656 sv_catsv_nomg|5.007002||p
2662 sv_cmp_locale||5.004000|
2665 sv_compile_2op||5.008001|
2666 sv_copypv||5.007003|
2669 sv_derived_from||5.004000|
2673 sv_force_normal_flags||5.007001|
2674 sv_force_normal||5.006000|
2685 sv_len_utf8||5.006000|
2687 sv_magicext||5.007003|
2692 sv_nolocking||5.007003|
2693 sv_nosharing||5.007003|
2694 sv_nounlocking||5.007003|
2697 sv_pos_b2u||5.006000|
2698 sv_pos_u2b||5.006000|
2699 sv_pvbyten_force||5.006000|
2700 sv_pvbyten||5.006000|
2701 sv_pvbyte||5.006000|
2702 sv_pvn_force_flags||5.007002|
2704 sv_pvn_nomg|5.007003||p
2706 sv_pvutf8n_force||5.006000|
2707 sv_pvutf8n||5.006000|
2708 sv_pvutf8||5.006000|
2710 sv_recode_to_utf8||5.007003|
2717 sv_rvweaken||5.006000|
2718 sv_setiv_mg|5.006000||p
2720 sv_setnv_mg|5.006000||p
2722 sv_setpv_mg|5.006000||p
2723 sv_setpvf_mg_nocontext|||pvn
2724 sv_setpvf_mg|5.006000|5.004000|pv
2725 sv_setpvf_nocontext|||vn
2726 sv_setpvf||5.004000|v
2727 sv_setpviv_mg||5.008001|
2728 sv_setpviv||5.008001|
2729 sv_setpvn_mg|5.006000||p
2736 sv_setref_uv||5.007001|
2738 sv_setsv_flags||5.007002|
2739 sv_setsv_mg|5.006000||p
2740 sv_setsv_nomg|5.007002||p
2742 sv_setuv_mg|5.006000||p
2743 sv_setuv|5.006000||p
2744 sv_tainted||5.004000|
2748 sv_uni_display||5.007003|
2750 sv_unref_flags||5.007001|
2752 sv_untaint||5.004000|
2754 sv_usepvn_mg|5.006000||p
2756 sv_utf8_decode||5.006000|
2757 sv_utf8_downgrade||5.006000|
2758 sv_utf8_encode||5.006000|
2759 sv_utf8_upgrade_flags||5.007002|
2760 sv_utf8_upgrade||5.007001|
2762 sv_vcatpvf_mg|5.006000|5.004000|p
2763 sv_vcatpvfn||5.004000|
2764 sv_vcatpvf|5.006000|5.004000|p
2765 sv_vsetpvf_mg|5.006000|5.004000|p
2766 sv_vsetpvfn||5.004000|
2767 sv_vsetpvf|5.006000|5.004000|p
2770 swash_fetch||5.007002|
2771 swash_init||5.006000|
2777 tmps_grow||5.006000|
2781 to_uni_fold||5.007003|
2782 to_uni_lower_lc||5.006000|
2783 to_uni_lower||5.007003|
2784 to_uni_title_lc||5.006000|
2785 to_uni_title||5.007003|
2786 to_uni_upper_lc||5.006000|
2787 to_uni_upper||5.007003|
2788 to_utf8_case||5.007003|
2789 to_utf8_fold||5.007003|
2790 to_utf8_lower||5.007003|
2792 to_utf8_title||5.007003|
2793 to_utf8_upper||5.007003|
2796 too_few_arguments|||
2797 too_many_arguments|||
2800 unpack_str||5.007003|
2801 unpackstring||5.008001|
2802 unshare_hek_or_pvn|||
2804 unsharepvn||5.004000|
2805 upg_version||5.009000|
2808 utf16_to_utf8_reversed||5.006001|
2809 utf16_to_utf8||5.006001|
2810 utf16rev_textfilter|||
2811 utf8_distance||5.006000|
2813 utf8_length||5.007001|
2816 utf8_to_bytes||5.006001|
2817 utf8_to_uvchr||5.007001|
2818 utf8_to_uvuni||5.007001|
2819 utf8n_to_uvchr||5.007001|
2820 utf8n_to_uvuni||5.007001|
2822 uvchr_to_utf8_flags||5.007003|
2823 uvchr_to_utf8||5.007001|
2824 uvuni_to_utf8_flags||5.007003|
2825 uvuni_to_utf8||5.007001|
2839 vload_module||5.006000|
2841 vnewSVpvf|5.006000|5.004000|p
2846 vstringify||5.009000|
2851 warner_nocontext|||vn
2863 if (exists $opt{'list-unsupported'}) {
2865 for $f (sort { lc $a cmp lc $b } keys %API) {
2866 next unless $API{$f}{todo};
2867 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
2872 # Scan for possible replacement candidates
2874 my(%replace, %need, %hints, %depends);
2880 if (m{^\s*\*\s(.*?)\s*$}) {
2881 $hints{$hint} ||= ''; # suppress warning with older perls
2882 $hints{$hint} .= "$1\n";
2888 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
2890 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
2891 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
2892 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
2893 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
2895 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
2896 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
2899 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
2902 if (exists $opt{'api-info'}) {
2905 for $f (sort { lc $a cmp lc $b } keys %API) {
2906 next unless $f =~ /$opt{'api-info'}/;
2907 print "\n=== $f ===\n\n";
2909 if ($API{$f}{base} || $API{$f}{todo}) {
2910 my $base = format_version($API{$f}{base} || $API{$f}{todo});
2911 print "May not be supported below perl-$base.\n";
2914 if ($API{$f}{provided}) {
2915 my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003";
2916 print "Support by $ppport provided down to perl-$todo.\n";
2917 print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
2918 print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
2919 print "$hints{$f}" if exists $hints{$f};
2923 print "No portability information available.\n";
2931 print "Found no API matching $opt{'api-info'}.\n";
2936 if (exists $opt{'list-provided'}) {
2938 for $f (sort { lc $a cmp lc $b } keys %API) {
2939 next unless $API{$f}{provided};
2941 push @flags, 'explicit' if exists $need{$f};
2942 push @flags, 'depend' if exists $depends{$f};
2943 push @flags, 'hint' if exists $hints{$f};
2944 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
2950 my(%files, %global, %revreplace);
2951 %revreplace = reverse %replace;
2953 my $patch_opened = 0;
2955 for $filename (@files) {
2956 unless (open IN, "<$filename") {
2957 warn "Unable to read from $filename: $!\n";
2961 info("Scanning $filename ...");
2963 my $c = do { local $/; <IN> };
2966 my %file = (orig => $c, changes => 0);
2968 # temporarily remove C comments from the code
2974 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
2976 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
2980 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
2985 defined $2 and push @ccom, $2;
2986 defined $1 ? $1 : "$ccs$#ccom$cce";
2989 $file{ccom} = \@ccom;
2991 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
2995 for $func (keys %API) {
2997 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
2998 if ($c =~ /\b(?:Perl_)?($match)\b/) {
2999 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
3000 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
3001 if (exists $API{$func}{provided}) {
3002 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
3003 $file{uses}{$func}++;
3004 my @deps = rec_depend($func);
3006 $file{uses_deps}{$func} = \@deps;
3008 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
3011 for ($func, @deps) {
3012 if (exists $need{$_}) {
3013 $file{needs}{$_} = 'static';
3018 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
3019 if ($c =~ /\b$func\b/) {
3020 $file{uses_todo}{$func}++;
3026 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
3027 if (exists $need{$2}) {
3028 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
3031 warning("Possibly wrong #define $1 in $filename");
3035 for (qw(uses needs uses_todo needed_global needed_static)) {
3036 for $func (keys %{$file{$_}}) {
3037 push @{$global{$_}{$func}}, $filename;
3041 $files{$filename} = \%file;
3044 # Globally resolve NEED_'s
3046 for $need (keys %{$global{needs}}) {
3047 if (@{$global{needs}{$need}} > 1) {
3048 my @targets = @{$global{needs}{$need}};
3049 my @t = grep $files{$_}{needed_global}{$need}, @targets;
3050 @targets = @t if @t;
3051 @t = grep /\.xs$/i, @targets;
3052 @targets = @t if @t;
3053 my $target = shift @targets;
3054 $files{$target}{needs}{$need} = 'global';
3055 for (@{$global{needs}{$need}}) {
3056 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
3061 for $filename (@files) {
3062 exists $files{$filename} or next;
3064 info("=== Analyzing $filename ===");
3066 my %file = %{$files{$filename}};
3068 my $c = $file{code};
3070 for $func (sort keys %{$file{uses_Perl}}) {
3071 if ($API{$func}{varargs}) {
3072 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
3073 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
3075 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
3076 $file{changes} += $changes;
3080 warning("Uses Perl_$func instead of $func");
3081 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
3086 for $func (sort keys %{$file{uses_replace}}) {
3087 warning("Uses $func instead of $replace{$func}");
3088 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3091 for $func (sort keys %{$file{uses}}) {
3092 next unless $file{uses}{$func}; # if it's only a dependency
3093 if (exists $file{uses_deps}{$func}) {
3094 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
3096 elsif (exists $replace{$func}) {
3097 warning("Uses $func instead of $replace{$func}");
3098 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3106 for $func (sort keys %{$file{uses_todo}}) {
3107 warning("Uses $func, which may not be portable below perl ",
3108 format_version($API{$func}{todo}));
3111 for $func (sort keys %{$file{needed_static}}) {
3113 if (not exists $file{uses}{$func}) {
3114 $message = "No need to define NEED_$func if $func is never used";
3116 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
3117 $message = "No need to define NEED_$func when already needed globally";
3121 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
3125 for $func (sort keys %{$file{needed_global}}) {
3127 if (not exists $global{uses}{$func}) {
3128 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
3130 elsif (exists $file{needs}{$func}) {
3131 if ($file{needs}{$func} eq 'extern') {
3132 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
3134 elsif ($file{needs}{$func} eq 'static') {
3135 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
3140 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
3144 $file{needs_inc_ppport} = keys %{$file{uses}};
3146 if ($file{needs_inc_ppport}) {
3149 for $func (sort keys %{$file{needs}}) {
3150 my $type = $file{needs}{$func};
3151 next if $type eq 'extern';
3152 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
3153 unless (exists $file{"needed_$type"}{$func}) {
3154 if ($type eq 'global') {
3155 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
3158 diag("File needs $func, adding static request");
3160 $pp .= "#define NEED_$func$suffix\n";
3164 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
3169 unless ($file{has_inc_ppport}) {
3170 diag("Needs to include '$ppport'");
3171 $pp .= qq(#include "$ppport"\n)
3175 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
3176 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
3177 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
3178 || ($c =~ s/^/$pp/);
3182 if ($file{has_inc_ppport}) {
3183 diag("No need to include '$ppport'");
3184 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
3188 # put back in our C comments
3191 my @ccom = @{$file{ccom}};
3192 for $ix (0 .. $#ccom) {
3193 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
3195 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
3198 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
3203 my $s = $cppc != 1 ? 's' : '';
3204 warning("Uses $cppc C++ style comment$s, which is not portable");
3207 if ($file{changes}) {
3208 if (exists $opt{copy}) {
3209 my $newfile = "$filename$opt{copy}";
3211 error("'$newfile' already exists, refusing to write copy of '$filename'");
3215 if (open F, ">$newfile") {
3216 info("Writing copy of '$filename' with changes to '$newfile'");
3221 error("Cannot open '$newfile' for writing: $!");
3225 elsif (exists $opt{patch} || $opt{changes}) {
3226 if (exists $opt{patch}) {
3227 unless ($patch_opened) {
3228 if (open PATCH, ">$opt{patch}") {
3232 error("Cannot open '$opt{patch}' for writing: $!");
3238 mydiff(\*PATCH, $filename, $c);
3242 info("Suggested changes:");
3243 mydiff(\*STDOUT, $filename, $c);
3247 my $s = $file{changes} == 1 ? '' : 's';
3248 info("$file{changes} potentially required change$s detected");
3256 close PATCH if $patch_opened;
3264 my($file, $str) = @_;
3267 if (exists $opt{diff}) {
3268 $diff = run_diff($opt{diff}, $file, $str);
3271 if (!defined $diff and can_use('Text::Diff')) {
3272 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
3273 $diff = <<HEADER . $diff;
3279 if (!defined $diff) {
3280 $diff = run_diff('diff -u', $file, $str);
3283 if (!defined $diff) {
3284 $diff = run_diff('diff', $file, $str);
3287 if (!defined $diff) {
3288 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
3298 my($prog, $file, $str) = @_;
3299 my $tmp = 'dppptemp';
3304 while (-e "$tmp.$suf") { $suf++ }
3307 if (open F, ">$tmp") {
3311 if (open F, "$prog $file $tmp |") {
3313 s/\Q$tmp\E/$file.patched/;
3324 error("Cannot open '$tmp' for writing: $!");
3340 return () unless exists $depends{$func};
3341 grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
3348 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
3349 return ($1, $2, $3);
3351 elsif ($ver !~ /^\d+\.[\d_]+$/) {
3352 die "cannot parse version '$ver'\n";
3356 $ver =~ s/$/000000/;
3358 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3363 if ($r < 5 || ($r == 5 && $v < 6)) {
3365 die "cannot parse version '$ver'\n";
3369 return ($r, $v, $s);
3376 $ver =~ s/$/000000/;
3377 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3382 if ($r < 5 || ($r == 5 && $v < 6)) {
3384 die "invalid version '$ver'\n";
3388 $ver = sprintf "%d.%03d", $r, $v;
3389 $s > 0 and $ver .= sprintf "_%02d", $s;
3394 return sprintf "%d.%d.%d", $r, $v, $s;
3399 $opt{quiet} and return;
3405 $opt{quiet} and return;
3406 $opt{diag} and print @_, "\n";
3411 $opt{quiet} and return;
3412 print "*** ", @_, "\n";
3417 print "*** ERROR: ", @_, "\n";
3423 $opt{quiet} and return;
3424 $opt{hints} or return;
3426 exists $hints{$func} or return;
3427 $given_hints{$func}++ and return;
3428 my $hint = $hints{$func};
3430 print " --- hint for $func ---\n", $hint;
3435 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
3436 my %M = ( 'I' => '*' );
3437 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
3438 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
3444 See perldoc $0 for details.
3454 #ifndef _P_P_PORTABILITY_H_
3455 #define _P_P_PORTABILITY_H_
3457 #ifndef DPPP_NAMESPACE
3458 # define DPPP_NAMESPACE DPPP_
3461 #define DPPP_CAT2(x,y) CAT2(x,y)
3462 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
3464 #ifndef PERL_REVISION
3465 # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
3466 # define PERL_PATCHLEVEL_H_IMPLICIT
3467 # include <patchlevel.h>
3469 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
3470 # include <could_not_find_Perl_patchlevel.h>
3472 # ifndef PERL_REVISION
3473 # define PERL_REVISION (5)
3475 # define PERL_VERSION PATCHLEVEL
3476 # define PERL_SUBVERSION SUBVERSION
3477 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
3482 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
3484 /* It is very unlikely that anyone will try to use this with Perl 6
3485 (or greater), but who knows.
3487 #if PERL_REVISION != 5
3488 # error ppport.h only works with Perl version 5
3489 #endif /* PERL_REVISION != 5 */
3492 # include <limits.h>
3495 #ifndef PERL_UCHAR_MIN
3496 # define PERL_UCHAR_MIN ((unsigned char)0)
3499 #ifndef PERL_UCHAR_MAX
3501 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
3504 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
3506 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
3511 #ifndef PERL_USHORT_MIN
3512 # define PERL_USHORT_MIN ((unsigned short)0)
3515 #ifndef PERL_USHORT_MAX
3517 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
3520 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
3523 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
3525 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
3531 #ifndef PERL_SHORT_MAX
3533 # define PERL_SHORT_MAX ((short)SHORT_MAX)
3535 # ifdef MAXSHORT /* Often used in <values.h> */
3536 # define PERL_SHORT_MAX ((short)MAXSHORT)
3539 # define PERL_SHORT_MAX ((short)SHRT_MAX)
3541 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
3547 #ifndef PERL_SHORT_MIN
3549 # define PERL_SHORT_MIN ((short)SHORT_MIN)
3552 # define PERL_SHORT_MIN ((short)MINSHORT)
3555 # define PERL_SHORT_MIN ((short)SHRT_MIN)
3557 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
3563 #ifndef PERL_UINT_MAX
3565 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
3568 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
3570 # define PERL_UINT_MAX (~(unsigned int)0)
3575 #ifndef PERL_UINT_MIN
3576 # define PERL_UINT_MIN ((unsigned int)0)
3579 #ifndef PERL_INT_MAX
3581 # define PERL_INT_MAX ((int)INT_MAX)
3583 # ifdef MAXINT /* Often used in <values.h> */
3584 # define PERL_INT_MAX ((int)MAXINT)
3586 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
3591 #ifndef PERL_INT_MIN
3593 # define PERL_INT_MIN ((int)INT_MIN)
3596 # define PERL_INT_MIN ((int)MININT)
3598 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
3603 #ifndef PERL_ULONG_MAX
3605 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
3608 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
3610 # define PERL_ULONG_MAX (~(unsigned long)0)
3615 #ifndef PERL_ULONG_MIN
3616 # define PERL_ULONG_MIN ((unsigned long)0L)
3619 #ifndef PERL_LONG_MAX
3621 # define PERL_LONG_MAX ((long)LONG_MAX)
3624 # define PERL_LONG_MAX ((long)MAXLONG)
3626 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
3631 #ifndef PERL_LONG_MIN
3633 # define PERL_LONG_MIN ((long)LONG_MIN)
3636 # define PERL_LONG_MIN ((long)MINLONG)
3638 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
3643 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
3644 # ifndef PERL_UQUAD_MAX
3645 # ifdef ULONGLONG_MAX
3646 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
3648 # ifdef MAXULONGLONG
3649 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
3651 # define PERL_UQUAD_MAX (~(unsigned long long)0)
3656 # ifndef PERL_UQUAD_MIN
3657 # define PERL_UQUAD_MIN ((unsigned long long)0L)
3660 # ifndef PERL_QUAD_MAX
3661 # ifdef LONGLONG_MAX
3662 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
3665 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
3667 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
3672 # ifndef PERL_QUAD_MIN
3673 # ifdef LONGLONG_MIN
3674 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
3677 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
3679 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
3685 /* This is based on code from 5.003 perl.h */
3693 # define IV_MIN PERL_INT_MIN
3697 # define IV_MAX PERL_INT_MAX
3701 # define UV_MIN PERL_UINT_MIN
3705 # define UV_MAX PERL_UINT_MAX
3710 # define IVSIZE INTSIZE
3715 # if defined(convex) || defined(uts)
3717 # define IVTYPE long long
3721 # define IV_MIN PERL_QUAD_MIN
3725 # define IV_MAX PERL_QUAD_MAX
3729 # define UV_MIN PERL_UQUAD_MIN
3733 # define UV_MAX PERL_UQUAD_MAX
3736 # ifdef LONGLONGSIZE
3738 # define IVSIZE LONGLONGSIZE
3744 # define IVTYPE long
3748 # define IV_MIN PERL_LONG_MIN
3752 # define IV_MAX PERL_LONG_MAX
3756 # define UV_MIN PERL_ULONG_MIN
3760 # define UV_MAX PERL_ULONG_MAX
3765 # define IVSIZE LONGSIZE
3775 #ifndef PERL_QUAD_MIN
3776 # define PERL_QUAD_MIN IV_MIN
3779 #ifndef PERL_QUAD_MAX
3780 # define PERL_QUAD_MAX IV_MAX
3783 #ifndef PERL_UQUAD_MIN
3784 # define PERL_UQUAD_MIN UV_MIN
3787 #ifndef PERL_UQUAD_MAX
3788 # define PERL_UQUAD_MAX UV_MAX
3793 # define IVTYPE long
3797 # define IV_MIN PERL_LONG_MIN
3801 # define IV_MAX PERL_LONG_MAX
3805 # define UV_MIN PERL_ULONG_MIN
3809 # define UV_MAX PERL_ULONG_MAX
3816 # define IVSIZE LONGSIZE
3818 # define IVSIZE 4 /* A bold guess, but the best we can make. */
3822 # define UVTYPE unsigned IVTYPE
3826 # define UVSIZE IVSIZE
3830 # define sv_setuv(sv, uv) \
3833 if (TeMpUv <= IV_MAX) \
3834 sv_setiv(sv, TeMpUv); \
3836 sv_setnv(sv, (double)TeMpUv); \
3841 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
3844 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
3848 # define SvUVX(sv) ((UV)SvIVX(sv))
3852 # define SvUVXx(sv) SvUVX(sv)
3856 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
3860 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
3864 * Always use the SvUVx() macro instead of sv_uv().
3867 # define sv_uv(sv) SvUVx(sv)
3870 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
3874 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
3877 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
3881 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
3884 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
3886 # define PL_DBsingle DBsingle
3887 # define PL_DBsub DBsub
3889 # define PL_compiling compiling
3890 # define PL_copline copline
3891 # define PL_curcop curcop
3892 # define PL_curstash curstash
3893 # define PL_debstash debstash
3894 # define PL_defgv defgv
3895 # define PL_diehook diehook
3896 # define PL_dirty dirty
3897 # define PL_dowarn dowarn
3898 # define PL_errgv errgv
3899 # define PL_hexdigit hexdigit
3900 # define PL_hints hints
3902 # define PL_no_modify no_modify
3903 # define PL_perl_destruct_level perl_destruct_level
3904 # define PL_perldb perldb
3905 # define PL_ppaddr ppaddr
3906 # define PL_rsfp_filters rsfp_filters
3907 # define PL_rsfp rsfp
3908 # define PL_stack_base stack_base
3909 # define PL_stack_sp stack_sp
3910 # define PL_stdingv stdingv
3911 # define PL_sv_arenaroot sv_arenaroot
3912 # define PL_sv_no sv_no
3913 # define PL_sv_undef sv_undef
3914 # define PL_sv_yes sv_yes
3915 # define PL_tainted tainted
3916 # define PL_tainting tainting
3921 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
3922 # define PERL_UNUSED_DECL
3924 # define PERL_UNUSED_DECL __attribute__((unused))
3927 # define PERL_UNUSED_DECL
3930 # define NOOP (void)0
3934 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
3938 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
3939 # define NVTYPE long double
3941 # define NVTYPE double
3948 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
3950 # define INT2PTR(any,d) (any)(d)
3952 # if PTRSIZE == LONGSIZE
3953 # define PTRV unsigned long
3955 # define PTRV unsigned
3957 # define INT2PTR(any,d) (any)(PTRV)(d)
3960 # define NUM2PTR(any,d) (any)(PTRV)(d)
3961 # define PTR2IV(p) INT2PTR(IV,p)
3962 # define PTR2UV(p) INT2PTR(UV,p)
3963 # define PTR2NV(p) NUM2PTR(NV,p)
3965 # if PTRSIZE == LONGSIZE
3966 # define PTR2ul(p) (unsigned long)(p)
3968 # define PTR2ul(p) INT2PTR(unsigned long,p)
3971 #endif /* !INT2PTR */
3973 #undef START_EXTERN_C
3977 # define START_EXTERN_C extern "C" {
3978 # define END_EXTERN_C }
3979 # define EXTERN_C extern "C"
3981 # define START_EXTERN_C
3982 # define END_EXTERN_C
3983 # define EXTERN_C extern
3986 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
3987 # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
3988 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
3994 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
3995 # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
3998 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
3999 # define STMT_START if (1)
4000 # define STMT_END else (void)0
4002 # define STMT_START do
4003 # define STMT_END while (0)
4007 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
4010 /* DEFSV appears first in 5.004_56 */
4012 # define DEFSV GvSV(PL_defgv)
4016 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
4019 /* Older perls (<=5.003) lack AvFILLp */
4021 # define AvFILLp AvFILL
4024 # define ERRSV get_sv("@",FALSE)
4027 # define newSVpvn(data,len) ((data) \
4028 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
4032 /* Hint: gv_stashpvn
4033 * This function's backport doesn't support the length parameter, but
4034 * rather ignores it. Portability can only be ensured if the length
4035 * parameter is used for speed reasons, but the length can always be
4036 * correctly computed from the string argument.
4039 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
4044 # define get_cv perl_get_cv
4048 # define get_sv perl_get_sv
4052 # define get_av perl_get_av
4056 # define get_hv perl_get_hv
4063 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
4067 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
4072 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
4076 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
4081 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
4085 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
4090 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
4095 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
4100 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
4103 # define dUNDERBAR dNOOP
4107 # define UNDERBAR DEFSV
4110 # define dAX I32 ax = MARK - PL_stack_base + 1
4114 # define dITEMS I32 items = SP - MARK
4124 # define dTHXa(x) dNOOP
4142 # define dTHXoa(x) dTHXa(x)
4145 # define PUSHmortal PUSHs(sv_newmortal())
4149 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
4153 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
4157 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
4161 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
4164 # define XPUSHmortal XPUSHs(sv_newmortal())
4168 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
4172 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
4176 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
4180 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
4185 # define call_sv perl_call_sv
4189 # define call_pv perl_call_pv
4193 # define call_argv perl_call_argv
4197 # define call_method perl_call_method
4200 # define eval_sv perl_eval_sv
4205 /* Replace perl_eval_pv with eval_pv */
4206 /* eval_pv depends on eval_sv */
4209 #if defined(NEED_eval_pv)
4210 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4213 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4219 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
4220 #define Perl_eval_pv DPPP_(my_eval_pv)
4222 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
4225 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
4228 SV* sv = newSVpv(p, 0);
4231 eval_sv(sv, G_SCALAR);
4238 if (croak_on_error && SvTRUE(GvSV(errgv)))
4239 croak(SvPVx(GvSV(errgv), na));
4247 # define newRV_inc(sv) newRV(sv) /* Replace */
4251 #if defined(NEED_newRV_noinc)
4252 static SV * DPPP_(my_newRV_noinc)(SV *sv);
4255 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
4261 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
4262 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
4264 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
4266 DPPP_(my_newRV_noinc)(SV *sv)
4268 SV *rv = (SV *)newRV(sv);
4275 /* Hint: newCONSTSUB
4276 * Returns a CV* as of perl-5.7.1. This return value is not supported
4280 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
4281 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
4282 #if defined(NEED_newCONSTSUB)
4283 static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4286 extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4292 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
4293 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
4295 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
4298 DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
4300 U32 oldhints = PL_hints;
4301 HV *old_cop_stash = PL_curcop->cop_stash;
4302 HV *old_curstash = PL_curstash;
4303 line_t oldline = PL_curcop->cop_line;
4304 PL_curcop->cop_line = PL_copline;
4306 PL_hints &= ~HINT_BLOCK_SCOPE;
4308 PL_curstash = PL_curcop->cop_stash = stash;
4312 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
4314 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
4316 #else /* 5.003_23 onwards */
4317 start_subparse(FALSE, 0),
4320 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4321 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4322 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4325 PL_hints = oldhints;
4326 PL_curcop->cop_stash = old_cop_stash;
4327 PL_curstash = old_curstash;
4328 PL_curcop->cop_line = oldline;
4334 * Boilerplate macros for initializing and accessing interpreter-local
4335 * data from C. All statics in extensions should be reworked to use
4336 * this, if you want to make the extension thread-safe. See ext/re/re.xs
4337 * for an example of the use of these macros.
4339 * Code that uses these macros is responsible for the following:
4340 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
4341 * 2. Declare a typedef named my_cxt_t that is a structure that contains
4342 * all the data that needs to be interpreter-local.
4343 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
4344 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
4345 * (typically put in the BOOT: section).
4346 * 5. Use the members of the my_cxt_t structure everywhere as
4348 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
4352 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
4353 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
4355 #ifndef START_MY_CXT
4357 /* This must appear in all extensions that define a my_cxt_t structure,
4358 * right after the definition (i.e. at file scope). The non-threads
4359 * case below uses it to declare the data as static. */
4360 #define START_MY_CXT
4362 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
4363 /* Fetches the SV that keeps the per-interpreter data. */
4364 #define dMY_CXT_SV \
4365 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
4366 #else /* >= perl5.004_68 */
4367 #define dMY_CXT_SV \
4368 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
4369 sizeof(MY_CXT_KEY)-1, TRUE)
4370 #endif /* < perl5.004_68 */
4372 /* This declaration should be used within all functions that use the
4373 * interpreter-local data. */
4376 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
4378 /* Creates and zeroes the per-interpreter data.
4379 * (We allocate my_cxtp in a Perl SV so that it will be released when
4380 * the interpreter goes away.) */
4381 #define MY_CXT_INIT \
4383 /* newSV() allocates one more than needed */ \
4384 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4385 Zero(my_cxtp, 1, my_cxt_t); \
4386 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4388 /* This macro must be used to access members of the my_cxt_t structure.
4389 * e.g. MYCXT.some_data */
4390 #define MY_CXT (*my_cxtp)
4392 /* Judicious use of these macros can reduce the number of times dMY_CXT
4393 * is used. Use is similar to pTHX, aTHX etc. */
4394 #define pMY_CXT my_cxt_t *my_cxtp
4395 #define pMY_CXT_ pMY_CXT,
4396 #define _pMY_CXT ,pMY_CXT
4397 #define aMY_CXT my_cxtp
4398 #define aMY_CXT_ aMY_CXT,
4399 #define _aMY_CXT ,aMY_CXT
4401 #endif /* START_MY_CXT */
4403 #ifndef MY_CXT_CLONE
4404 /* Clones the per-interpreter data. */
4405 #define MY_CXT_CLONE \
4407 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4408 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
4409 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4412 #else /* single interpreter */
4414 #ifndef START_MY_CXT
4416 #define START_MY_CXT static my_cxt_t my_cxt;
4417 #define dMY_CXT_SV dNOOP
4418 #define dMY_CXT dNOOP
4419 #define MY_CXT_INIT NOOP
4420 #define MY_CXT my_cxt
4422 #define pMY_CXT void
4429 #endif /* START_MY_CXT */
4431 #ifndef MY_CXT_CLONE
4432 #define MY_CXT_CLONE NOOP
4438 # if IVSIZE == LONGSIZE
4445 # if IVSIZE == INTSIZE
4456 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
4457 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
4458 # define NVef PERL_PRIeldbl
4459 # define NVff PERL_PRIfldbl
4460 # define NVgf PERL_PRIgldbl
4470 #if defined(NEED_sv_2pv_nolen)
4471 static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4474 extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4478 # undef sv_2pv_nolen
4480 #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
4481 #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
4483 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
4486 DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
4489 return sv_2pv(sv, &n_a);
4494 /* Hint: sv_2pv_nolen
4495 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
4498 /* SvPV_nolen depends on sv_2pv_nolen */
4499 #define SvPV_nolen(sv) \
4500 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
4501 ? SvPVX(sv) : sv_2pv_nolen(sv))
4508 * Does not work in perl-5.6.1, ppport.h implements a version
4509 * borrowed from perl-5.7.3.
4512 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
4514 #if defined(NEED_sv_2pvbyte)
4515 static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4518 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4524 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
4525 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
4527 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
4530 DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
4532 sv_utf8_downgrade(sv,0);
4533 return SvPV(sv,*lp);
4539 * Use the SvPVbyte() macro instead of sv_2pvbyte().
4544 /* SvPVbyte depends on sv_2pvbyte */
4545 #define SvPVbyte(sv, lp) \
4546 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
4547 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
4553 # define SvPVbyte SvPV
4554 # define sv_2pvbyte sv_2pv
4558 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
4559 #ifndef sv_2pvbyte_nolen
4560 # define sv_2pvbyte_nolen sv_2pv_nolen
4564 * Always use the SvPV() macro instead of sv_pvn().
4567 # define sv_pvn(sv, len) SvPV(sv, len)
4570 /* Hint: sv_pvn_force
4571 * Always use the SvPV_force() macro instead of sv_pvn_force().
4573 #ifndef sv_pvn_force
4574 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
4577 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
4578 #if defined(NEED_vnewSVpvf)
4579 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4582 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4588 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
4589 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
4591 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
4594 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
4596 register SV *sv = newSV(0);
4597 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4604 /* sv_vcatpvf depends on sv_vcatpvfn */
4605 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
4606 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4609 /* sv_vsetpvf depends on sv_vsetpvfn */
4610 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
4611 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4614 /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
4615 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
4616 #if defined(NEED_sv_catpvf_mg)
4617 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4620 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4623 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
4625 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
4628 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4631 va_start(args, pat);
4632 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4640 /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
4641 #ifdef PERL_IMPLICIT_CONTEXT
4642 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
4643 #if defined(NEED_sv_catpvf_mg_nocontext)
4644 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4647 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4650 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4651 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4653 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
4656 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4660 va_start(args, pat);
4661 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4670 #ifndef sv_catpvf_mg
4671 # ifdef PERL_IMPLICIT_CONTEXT
4672 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
4674 # define sv_catpvf_mg Perl_sv_catpvf_mg
4678 /* sv_vcatpvf_mg depends on sv_vcatpvfn */
4679 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
4680 # define sv_vcatpvf_mg(sv, pat, args) \
4682 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4687 /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
4688 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
4689 #if defined(NEED_sv_setpvf_mg)
4690 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4693 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4696 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
4698 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
4701 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4704 va_start(args, pat);
4705 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4713 /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
4714 #ifdef PERL_IMPLICIT_CONTEXT
4715 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
4716 #if defined(NEED_sv_setpvf_mg_nocontext)
4717 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4720 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4723 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4724 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4726 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
4729 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4733 va_start(args, pat);
4734 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4743 #ifndef sv_setpvf_mg
4744 # ifdef PERL_IMPLICIT_CONTEXT
4745 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
4747 # define sv_setpvf_mg Perl_sv_setpvf_mg
4751 /* sv_vsetpvf_mg depends on sv_vsetpvfn */
4752 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
4753 # define sv_vsetpvf_mg(sv, pat, args) \
4755 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4760 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
4762 #ifndef PERL_MAGIC_sv
4763 # define PERL_MAGIC_sv '\0'
4766 #ifndef PERL_MAGIC_overload
4767 # define PERL_MAGIC_overload 'A'
4770 #ifndef PERL_MAGIC_overload_elem
4771 # define PERL_MAGIC_overload_elem 'a'
4774 #ifndef PERL_MAGIC_overload_table
4775 # define PERL_MAGIC_overload_table 'c'
4778 #ifndef PERL_MAGIC_bm
4779 # define PERL_MAGIC_bm 'B'
4782 #ifndef PERL_MAGIC_regdata
4783 # define PERL_MAGIC_regdata 'D'
4786 #ifndef PERL_MAGIC_regdatum
4787 # define PERL_MAGIC_regdatum 'd'
4790 #ifndef PERL_MAGIC_env
4791 # define PERL_MAGIC_env 'E'
4794 #ifndef PERL_MAGIC_envelem
4795 # define PERL_MAGIC_envelem 'e'
4798 #ifndef PERL_MAGIC_fm
4799 # define PERL_MAGIC_fm 'f'
4802 #ifndef PERL_MAGIC_regex_global
4803 # define PERL_MAGIC_regex_global 'g'
4806 #ifndef PERL_MAGIC_isa
4807 # define PERL_MAGIC_isa 'I'
4810 #ifndef PERL_MAGIC_isaelem
4811 # define PERL_MAGIC_isaelem 'i'
4814 #ifndef PERL_MAGIC_nkeys
4815 # define PERL_MAGIC_nkeys 'k'
4818 #ifndef PERL_MAGIC_dbfile
4819 # define PERL_MAGIC_dbfile 'L'
4822 #ifndef PERL_MAGIC_dbline
4823 # define PERL_MAGIC_dbline 'l'
4826 #ifndef PERL_MAGIC_mutex
4827 # define PERL_MAGIC_mutex 'm'
4830 #ifndef PERL_MAGIC_shared
4831 # define PERL_MAGIC_shared 'N'
4834 #ifndef PERL_MAGIC_shared_scalar
4835 # define PERL_MAGIC_shared_scalar 'n'
4838 #ifndef PERL_MAGIC_collxfrm
4839 # define PERL_MAGIC_collxfrm 'o'
4842 #ifndef PERL_MAGIC_tied
4843 # define PERL_MAGIC_tied 'P'
4846 #ifndef PERL_MAGIC_tiedelem
4847 # define PERL_MAGIC_tiedelem 'p'
4850 #ifndef PERL_MAGIC_tiedscalar
4851 # define PERL_MAGIC_tiedscalar 'q'
4854 #ifndef PERL_MAGIC_qr
4855 # define PERL_MAGIC_qr 'r'
4858 #ifndef PERL_MAGIC_sig
4859 # define PERL_MAGIC_sig 'S'
4862 #ifndef PERL_MAGIC_sigelem
4863 # define PERL_MAGIC_sigelem 's'
4866 #ifndef PERL_MAGIC_taint
4867 # define PERL_MAGIC_taint 't'
4870 #ifndef PERL_MAGIC_uvar
4871 # define PERL_MAGIC_uvar 'U'
4874 #ifndef PERL_MAGIC_uvar_elem
4875 # define PERL_MAGIC_uvar_elem 'u'
4878 #ifndef PERL_MAGIC_vstring
4879 # define PERL_MAGIC_vstring 'V'
4882 #ifndef PERL_MAGIC_vec
4883 # define PERL_MAGIC_vec 'v'
4886 #ifndef PERL_MAGIC_utf8
4887 # define PERL_MAGIC_utf8 'w'
4890 #ifndef PERL_MAGIC_substr
4891 # define PERL_MAGIC_substr 'x'
4894 #ifndef PERL_MAGIC_defelem
4895 # define PERL_MAGIC_defelem 'y'
4898 #ifndef PERL_MAGIC_glob
4899 # define PERL_MAGIC_glob '*'
4902 #ifndef PERL_MAGIC_arylen
4903 # define PERL_MAGIC_arylen '#'
4906 #ifndef PERL_MAGIC_pos
4907 # define PERL_MAGIC_pos '.'
4910 #ifndef PERL_MAGIC_backref
4911 # define PERL_MAGIC_backref '<'
4914 #ifndef PERL_MAGIC_ext
4915 # define PERL_MAGIC_ext '~'
4918 /* That's the best we can do... */
4919 #ifndef SvPV_force_nomg
4920 # define SvPV_force_nomg SvPV_force
4924 # define SvPV_nomg SvPV
4927 #ifndef sv_catpvn_nomg
4928 # define sv_catpvn_nomg sv_catpvn
4931 #ifndef sv_catsv_nomg
4932 # define sv_catsv_nomg sv_catsv
4935 #ifndef sv_setsv_nomg
4936 # define sv_setsv_nomg sv_setsv
4940 # define sv_pvn_nomg sv_pvn
4944 # define SvIV_nomg SvIV
4948 # define SvUV_nomg SvUV
4952 # define sv_catpv_mg(sv, ptr) \
4955 sv_catpv(TeMpSv,ptr); \
4956 SvSETMAGIC(TeMpSv); \
4960 #ifndef sv_catpvn_mg
4961 # define sv_catpvn_mg(sv, ptr, len) \
4964 sv_catpvn(TeMpSv,ptr,len); \
4965 SvSETMAGIC(TeMpSv); \
4970 # define sv_catsv_mg(dsv, ssv) \
4973 sv_catsv(TeMpSv,ssv); \
4974 SvSETMAGIC(TeMpSv); \
4979 # define sv_setiv_mg(sv, i) \
4982 sv_setiv(TeMpSv,i); \
4983 SvSETMAGIC(TeMpSv); \
4988 # define sv_setnv_mg(sv, num) \
4991 sv_setnv(TeMpSv,num); \
4992 SvSETMAGIC(TeMpSv); \
4997 # define sv_setpv_mg(sv, ptr) \
5000 sv_setpv(TeMpSv,ptr); \
5001 SvSETMAGIC(TeMpSv); \
5005 #ifndef sv_setpvn_mg
5006 # define sv_setpvn_mg(sv, ptr, len) \
5009 sv_setpvn(TeMpSv,ptr,len); \
5010 SvSETMAGIC(TeMpSv); \
5015 # define sv_setsv_mg(dsv, ssv) \
5018 sv_setsv(TeMpSv,ssv); \
5019 SvSETMAGIC(TeMpSv); \
5024 # define sv_setuv_mg(sv, i) \
5027 sv_setuv(TeMpSv,i); \
5028 SvSETMAGIC(TeMpSv); \
5032 #ifndef sv_usepvn_mg
5033 # define sv_usepvn_mg(sv, ptr, len) \
5036 sv_usepvn(TeMpSv,ptr,len); \
5037 SvSETMAGIC(TeMpSv); \
5043 # define CopFILE(c) ((c)->cop_file)
5047 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
5051 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
5055 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
5059 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
5063 # define CopSTASHPV(c) ((c)->cop_stashpv)
5066 #ifndef CopSTASHPV_set
5067 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
5071 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
5074 #ifndef CopSTASH_set
5075 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
5079 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
5080 || (CopSTASHPV(c) && HvNAME(hv) \
5081 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
5086 # define CopFILEGV(c) ((c)->cop_filegv)
5089 #ifndef CopFILEGV_set
5090 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
5094 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
5098 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
5102 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
5106 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
5110 # define CopSTASH(c) ((c)->cop_stash)
5113 #ifndef CopSTASH_set
5114 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
5118 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
5121 #ifndef CopSTASHPV_set
5122 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
5126 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
5129 #endif /* USE_ITHREADS */
5130 #ifndef IN_PERL_COMPILETIME
5131 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
5134 #ifndef IN_LOCALE_RUNTIME
5135 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
5138 #ifndef IN_LOCALE_COMPILETIME
5139 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
5143 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
5145 #ifndef IS_NUMBER_IN_UV
5146 # define IS_NUMBER_IN_UV 0x01
5149 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
5150 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
5153 #ifndef IS_NUMBER_NOT_INT
5154 # define IS_NUMBER_NOT_INT 0x04
5157 #ifndef IS_NUMBER_NEG
5158 # define IS_NUMBER_NEG 0x08
5161 #ifndef IS_NUMBER_INFINITY
5162 # define IS_NUMBER_INFINITY 0x10
5165 #ifndef IS_NUMBER_NAN
5166 # define IS_NUMBER_NAN 0x20
5169 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
5170 #ifndef GROK_NUMERIC_RADIX
5171 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
5173 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
5174 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
5177 #ifndef PERL_SCAN_SILENT_ILLDIGIT
5178 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
5181 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
5182 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
5185 #ifndef PERL_SCAN_DISALLOW_PREFIX
5186 # define PERL_SCAN_DISALLOW_PREFIX 0x02
5189 #ifndef grok_numeric_radix
5190 #if defined(NEED_grok_numeric_radix)
5191 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5194 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5197 #ifdef grok_numeric_radix
5198 # undef grok_numeric_radix
5200 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
5201 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
5203 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
5205 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
5207 #ifdef USE_LOCALE_NUMERIC
5208 #ifdef PL_numeric_radix_sv
5209 if (PL_numeric_radix_sv && IN_LOCALE) {
5211 char* radix = SvPV(PL_numeric_radix_sv, len);
5212 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5218 /* older perls don't have PL_numeric_radix_sv so the radix
5219 * must manually be requested from locale.h
5222 dTHR; /* needed for older threaded perls */
5223 struct lconv *lc = localeconv();
5224 char *radix = lc->decimal_point;
5225 if (radix && IN_LOCALE) {
5226 STRLEN len = strlen(radix);
5227 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5232 #endif /* PERL_VERSION */
5233 #endif /* USE_LOCALE_NUMERIC */
5234 /* always try "." if numeric radix didn't match because
5235 * we may have data from different locales mixed */
5236 if (*sp < send && **sp == '.') {
5245 /* grok_number depends on grok_numeric_radix */
5248 #if defined(NEED_grok_number)
5249 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5252 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5258 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
5259 #define Perl_grok_number DPPP_(my_grok_number)
5261 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
5263 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
5266 const char *send = pv + len;
5267 const UV max_div_10 = UV_MAX / 10;
5268 const char max_mod_10 = UV_MAX % 10;
5273 while (s < send && isSPACE(*s))
5277 } else if (*s == '-') {
5279 numtype = IS_NUMBER_NEG;
5287 /* next must be digit or the radix separator or beginning of infinity */
5289 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
5291 UV value = *s - '0';
5292 /* This construction seems to be more optimiser friendly.
5293 (without it gcc does the isDIGIT test and the *s - '0' separately)
5294 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
5295 In theory the optimiser could deduce how far to unroll the loop
5296 before checking for overflow. */
5298 int digit = *s - '0';
5299 if (digit >= 0 && digit <= 9) {
5300 value = value * 10 + digit;
5303 if (digit >= 0 && digit <= 9) {
5304 value = value * 10 + digit;
5307 if (digit >= 0 && digit <= 9) {
5308 value = value * 10 + digit;
5311 if (digit >= 0 && digit <= 9) {
5312 value = value * 10 + digit;
5315 if (digit >= 0 && digit <= 9) {
5316 value = value * 10 + digit;
5319 if (digit >= 0 && digit <= 9) {
5320 value = value * 10 + digit;
5323 if (digit >= 0 && digit <= 9) {
5324 value = value * 10 + digit;
5327 if (digit >= 0 && digit <= 9) {
5328 value = value * 10 + digit;
5330 /* Now got 9 digits, so need to check
5331 each time for overflow. */
5333 while (digit >= 0 && digit <= 9
5334 && (value < max_div_10
5335 || (value == max_div_10
5336 && digit <= max_mod_10))) {
5337 value = value * 10 + digit;
5343 if (digit >= 0 && digit <= 9
5345 /* value overflowed.
5346 skip the remaining digits, don't
5347 worry about setting *valuep. */
5350 } while (s < send && isDIGIT(*s));
5352 IS_NUMBER_GREATER_THAN_UV_MAX;
5372 numtype |= IS_NUMBER_IN_UV;
5377 if (GROK_NUMERIC_RADIX(&s, send)) {
5378 numtype |= IS_NUMBER_NOT_INT;
5379 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
5383 else if (GROK_NUMERIC_RADIX(&s, send)) {
5384 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
5385 /* no digits before the radix means we need digits after it */
5386 if (s < send && isDIGIT(*s)) {
5389 } while (s < send && isDIGIT(*s));
5391 /* integer approximation is valid - it's 0. */
5397 } else if (*s == 'I' || *s == 'i') {
5398 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5399 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
5400 s++; if (s < send && (*s == 'I' || *s == 'i')) {
5401 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5402 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
5403 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
5404 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
5408 } else if (*s == 'N' || *s == 'n') {
5409 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
5410 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
5411 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5418 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5419 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
5420 } else if (sawnan) {
5421 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5422 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
5423 } else if (s < send) {
5424 /* we can have an optional exponent part */
5425 if (*s == 'e' || *s == 'E') {
5426 /* The only flag we keep is sign. Blow away any "it's UV" */
5427 numtype &= IS_NUMBER_NEG;
5428 numtype |= IS_NUMBER_NOT_INT;
5430 if (s < send && (*s == '-' || *s == '+'))
5432 if (s < send && isDIGIT(*s)) {
5435 } while (s < send && isDIGIT(*s));
5441 while (s < send && isSPACE(*s))
5445 if (len == 10 && memEQ(pv, "0 but true", 10)) {
5448 return IS_NUMBER_IN_UV;
5456 * The grok_* routines have been modified to use warn() instead of
5457 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
5458 * which is why the stack variable has been renamed to 'xdigit'.
5462 #if defined(NEED_grok_bin)
5463 static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5466 extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5472 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
5473 #define Perl_grok_bin DPPP_(my_grok_bin)
5475 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
5477 DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5479 const char *s = start;
5480 STRLEN len = *len_p;
5484 const UV max_div_2 = UV_MAX / 2;
5485 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5486 bool overflowed = FALSE;
5488 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5489 /* strip off leading b or 0b.
5490 for compatibility silently suffer "b" and "0b" as valid binary
5497 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
5504 for (; len-- && *s; s++) {
5506 if (bit == '0' || bit == '1') {
5507 /* Write it in this wonky order with a goto to attempt to get the
5508 compiler to make the common case integer-only loop pretty tight.
5509 With gcc seems to be much straighter code than old scan_bin. */
5512 if (value <= max_div_2) {
5513 value = (value << 1) | (bit - '0');
5516 /* Bah. We're just overflowed. */
5517 warn("Integer overflow in binary number");
5519 value_nv = (NV) value;
5522 /* If an NV has not enough bits in its mantissa to
5523 * represent a UV this summing of small low-order numbers
5524 * is a waste of time (because the NV cannot preserve
5525 * the low-order bits anyway): we could just remember when
5526 * did we overflow and in the end just multiply value_nv by the
5528 value_nv += (NV)(bit - '0');
5531 if (bit == '_' && len && allow_underscores && (bit = s[1])
5532 && (bit == '0' || bit == '1'))
5538 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5539 warn("Illegal binary digit '%c' ignored", *s);
5543 if ( ( overflowed && value_nv > 4294967295.0)
5545 || (!overflowed && value > 0xffffffff )
5548 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
5555 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5564 #if defined(NEED_grok_hex)
5565 static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5568 extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5574 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
5575 #define Perl_grok_hex DPPP_(my_grok_hex)
5577 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
5579 DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5581 const char *s = start;
5582 STRLEN len = *len_p;
5586 const UV max_div_16 = UV_MAX / 16;
5587 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5588 bool overflowed = FALSE;
5591 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5592 /* strip off leading x or 0x.
5593 for compatibility silently suffer "x" and "0x" as valid hex numbers.
5600 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
5607 for (; len-- && *s; s++) {
5608 xdigit = strchr((char *) PL_hexdigit, *s);
5610 /* Write it in this wonky order with a goto to attempt to get the
5611 compiler to make the common case integer-only loop pretty tight.
5612 With gcc seems to be much straighter code than old scan_hex. */
5615 if (value <= max_div_16) {
5616 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
5619 warn("Integer overflow in hexadecimal number");
5621 value_nv = (NV) value;
5624 /* If an NV has not enough bits in its mantissa to
5625 * represent a UV this summing of small low-order numbers
5626 * is a waste of time (because the NV cannot preserve
5627 * the low-order bits anyway): we could just remember when
5628 * did we overflow and in the end just multiply value_nv by the
5629 * right amount of 16-tuples. */
5630 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
5633 if (*s == '_' && len && allow_underscores && s[1]
5634 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
5640 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5641 warn("Illegal hexadecimal digit '%c' ignored", *s);
5645 if ( ( overflowed && value_nv > 4294967295.0)
5647 || (!overflowed && value > 0xffffffff )
5650 warn("Hexadecimal number > 0xffffffff non-portable");
5657 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5666 #if defined(NEED_grok_oct)
5667 static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5670 extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5676 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
5677 #define Perl_grok_oct DPPP_(my_grok_oct)
5679 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
5681 DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5683 const char *s = start;
5684 STRLEN len = *len_p;
5688 const UV max_div_8 = UV_MAX / 8;
5689 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5690 bool overflowed = FALSE;
5692 for (; len-- && *s; s++) {
5693 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
5694 out front allows slicker code. */
5695 int digit = *s - '0';
5696 if (digit >= 0 && digit <= 7) {
5697 /* Write it in this wonky order with a goto to attempt to get the
5698 compiler to make the common case integer-only loop pretty tight.
5702 if (value <= max_div_8) {
5703 value = (value << 3) | digit;
5706 /* Bah. We're just overflowed. */
5707 warn("Integer overflow in octal number");
5709 value_nv = (NV) value;
5712 /* If an NV has not enough bits in its mantissa to
5713 * represent a UV this summing of small low-order numbers
5714 * is a waste of time (because the NV cannot preserve
5715 * the low-order bits anyway): we could just remember when
5716 * did we overflow and in the end just multiply value_nv by the
5717 * right amount of 8-tuples. */
5718 value_nv += (NV)digit;
5721 if (digit == ('_' - '0') && len && allow_underscores
5722 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
5728 /* Allow \octal to work the DWIM way (that is, stop scanning
5729 * as soon as non-octal characters are seen, complain only iff
5730 * someone seems to want to use the digits eight and nine). */
5731 if (digit == 8 || digit == 9) {
5732 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5733 warn("Illegal octal digit '%c' ignored", *s);
5738 if ( ( overflowed && value_nv > 4294967295.0)
5740 || (!overflowed && value > 0xffffffff )
5743 warn("Octal number > 037777777777 non-portable");
5750 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5758 #endif /* _P_P_PORTABILITY_H_ */
5760 /* End of File ppport.h */
projects / p5sagit/p5-mst-13.2.git / blob