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.02 $' =~ /(\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
956 POD =head1 COMPATIBILITY
958 POD This version of F<ppport.h> is designed to support operation with Perl
959 POD installations back to 5.003, and has been tested up to 5.9.2.
965 POD Display a brief usage summary.
967 POD =head2 --patch=I<file>
969 POD If this option is given, a single patch file will be created if
970 POD any changes are suggested. This requires a working diff program
971 POD to be installed on your system.
973 POD =head2 --copy=I<suffix>
975 POD If this option is given, a copy of each file will be saved with
976 POD the given suffix that contains the suggested changes. This does
977 POD not require any external programs.
979 POD If neither C<--patch> or C<--copy> are given, the default is to
980 POD simply print the diffs for each file. This requires either
981 POD C<Text::Diff> or a C<diff> program to be installed.
983 POD =head2 --diff=I<program>
985 POD Manually set the diff program and options to use. The default
986 POD is to use C<Text::Diff>, when installed, and output unified
989 POD =head2 --compat-version=I<version>
991 POD Tell F<ppport.h> to check for compatibility with the given
992 POD Perl version. The default is to check for compatibility with Perl
993 POD version 5.003. You can use this option to reduce the output
994 POD of F<ppport.h> if you intend to be backward compatible only
995 POD up to a certain Perl version.
997 POD =head2 --cplusplus
999 POD Usually, F<ppport.h> will detect C++ style comments and
1000 POD replace them with C style comments for portability reasons.
1001 POD Using this option instructs F<ppport.h> to leave C++
1002 POD comments untouched.
1006 POD Be quiet. Don't print anything except fatal errors.
1010 POD Don't output any diagnostic messages. Only portability
1011 POD alerts will be printed.
1013 POD =head2 --nohints
1015 POD Don't output any hints. Hints often contain useful portability
1018 POD =head2 --nochanges
1020 POD Don't suggest any changes. Only give diagnostic output and hints
1021 POD unless these are also deactivated.
1023 POD =head2 --list-provided
1025 POD Lists the API elements for which compatibility is provided by
1026 POD F<ppport.h>. Also lists if it must be explicitly requested,
1027 POD if it has dependencies, and if there are hints for it.
1029 POD =head2 --list-unsupported
1031 POD Lists the API elements that are known not to be supported by
1032 POD F<ppport.h> and below which version of Perl they probably
1033 POD won't be available or work.
1035 POD =head1 DESCRIPTION
1037 POD In order for a Perl extension (XS) module to be as portable as possible
1038 POD across differing versions of Perl itself, certain steps need to be taken.
1044 POD Including this header is the first major one. This alone will give you
1045 POD access to a large part of the Perl API that hasn't been available in
1046 POD earlier Perl releases. Use
1048 POD perl ppport.h --list-provided
1050 POD to see which API elements are provided by ppport.h.
1054 POD You should avoid using deprecated parts of the API. For example, using
1055 POD global Perl variables without the C<PL_> prefix is deprecated. Also,
1056 POD some API functions used to have a C<perl_> prefix. Using this form is
1057 POD also deprecated. You can safely use the supported API, as F<ppport.h>
1058 POD will provide wrappers for older Perl versions.
1062 POD If you use one of a few functions that were not present in earlier
1063 POD versions of Perl, and that can't be provided using a macro, you have
1064 POD to explicitly request support for these functions by adding one or
1065 POD more C<#define>s in your source code before the inclusion of F<ppport.h>.
1067 POD These functions will be marked C<explicit> in the list shown by
1068 POD C<--list-provided>.
1070 POD Depending on whether you module has a single or multiple files that
1071 POD use such functions, you want either C<static> or global variants.
1073 POD For a C<static> function, use:
1075 POD #define NEED_function
1077 POD For a global function, use:
1079 POD #define NEED_function_GLOBAL
1081 POD Note that you mustn't have more than one global request for one
1082 POD function in your project.
1084 POD Function Static Request Global Request
1085 POD -----------------------------------------------------------------------------------------
1086 POD eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
1087 POD grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
1088 POD grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
1089 POD grok_number() NEED_grok_number NEED_grok_number_GLOBAL
1090 POD grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
1091 POD grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
1092 POD newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
1093 POD newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
1094 POD sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
1095 POD sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
1096 POD sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL
1097 POD sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL
1098 POD sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL
1099 POD sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL
1100 POD vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL
1102 POD To avoid namespace conflicts, you can change the namespace of the
1103 POD explicitly exported functions using the C<DPPP_NAMESPACE> macro.
1104 POD Just C<#define> the macro before including C<ppport.h>:
1106 POD #define DPPP_NAMESPACE MyOwnNamespace_
1107 POD #include "ppport.h"
1109 POD The default namespace is C<DPPP_>.
1113 POD The good thing is that most of the above can be checked by running
1114 POD F<ppport.h> on your source code. See the next section for
1119 POD To verify whether F<ppport.h> is needed for your module, whether you
1120 POD should make any changes to your code, and whether any special defines
1121 POD should be used, F<ppport.h> can be run as a Perl script to check your
1122 POD source code. Simply say:
1126 POD The result will usually be a list of patches suggesting changes
1127 POD that should at least be acceptable, if not necessarily the most
1128 POD efficient solution, or a fix for all possible problems.
1130 POD If you know that your XS module uses features only available in
1131 POD newer Perl releases, if you're aware that it uses C++ comments,
1132 POD and if you want all suggestions as a single patch file, you could
1133 POD use something like this:
1135 POD perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
1137 POD If you only want your code to be scanned without any suggestions
1138 POD for changes, use:
1140 POD perl ppport.h --nochanges
1142 POD You can specify a different C<diff> program or options, using
1143 POD the C<--diff> option:
1145 POD perl ppport.h --diff='diff -C 10'
1147 POD This would output context diffs with 10 lines of context.
1151 POD If this version of F<ppport.h> is causing failure during
1152 POD the compilation of this module, please check if newer versions
1153 POD of either this module or C<Devel::PPPort> are available on CPAN
1154 POD before sending a bug report.
1156 POD If F<ppport.h> was generated using the latest version of
1157 POD C<Devel::PPPort> and is causing failure of this module, please
1158 POD file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
1160 POD Please include the following information:
1166 POD The complete output from running "perl -V"
1174 POD The name and version of the module you were trying to build.
1178 POD A full log of the build that failed.
1182 POD Any other information that you think could be relevant.
1186 POD For the latest version of this code, please get the C<Devel::PPPort>
1187 POD module from CPAN.
1189 POD =head1 COPYRIGHT
1191 POD Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz.
1193 POD Version 2.x, Copyright (C) 2001, Paul Marquess.
1195 POD Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
1197 POD This program is free software; you can redistribute it and/or
1198 POD modify it under the same terms as Perl itself.
1202 POD See L<Devel::PPPort>.
1216 my($ppport) = $0 =~ /([\w.]+)$/;
1217 my $LF = '(?:\r\n|[\r\n])'; # line feed
1218 my $HS = "[ \t]"; # horizontal whitespace
1221 require Getopt::Long;
1222 Getopt::Long::GetOptions(\%opt, qw(
1223 help quiet diag! hints! changes! cplusplus
1224 patch=s copy=s diff=s compat-version=s
1225 list-provided list-unsupported
1229 if ($@ and grep /^-/, @ARGV) {
1230 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
1231 die "Getopt::Long not found. Please don't use any options.\n";
1234 usage() if $opt{help};
1236 if (exists $opt{'compat-version'}) {
1237 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
1239 die "Invalid version number format: '$opt{'compat-version'}'\n";
1241 die "Only Perl 5 is supported\n" if $r != 5;
1242 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000;
1243 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
1246 $opt{'compat-version'} = 5;
1249 # Never use C comments in this file!!!!!
1252 my $rccs = quotemeta $ccs;
1253 my $rcce = quotemeta $cce;
1258 @files = map { glob $_ } @ARGV;
1263 File::Find::find(sub {
1264 $File::Find::name =~ /\.(xs|c|h|cc)$/i
1265 and push @files, $File::Find::name;
1269 @files = map { glob $_ } qw(*.xs *.c *.h *.cc);
1271 my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files;
1272 @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files;
1276 die "No input files given!\n";
1279 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
1281 ($2 ? ( base => $2 ) : ()),
1282 ($3 ? ( todo => $3 ) : ()),
1283 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
1284 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
1285 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
1287 : die "invalid spec: $_" } qw(
1293 CopFILEAV|5.006000||p
1294 CopFILEGV_set|5.006000||p
1295 CopFILEGV|5.006000||p
1296 CopFILESV|5.006000||p
1297 CopFILE_set|5.006000||p
1299 CopSTASHPV_set|5.006000||p
1300 CopSTASHPV|5.006000||p
1301 CopSTASH_eq|5.006000||p
1302 CopSTASH_set|5.006000||p
1303 CopSTASH|5.006000||p
1310 END_EXTERN_C|5.005000||p
1314 EXTERN_C|5.005000||p
1318 GROK_NUMERIC_RADIX|5.007002||p
1328 HEf_SVKEY||5.004000|
1333 HeSVKEY_force||5.004000|
1334 HeSVKEY_set||5.004000|
1339 IN_LOCALE_COMPILETIME|5.007002||p
1340 IN_LOCALE_RUNTIME|5.007002||p
1341 IN_LOCALE|5.007002||p
1342 IN_PERL_COMPILETIME|5.008001||p
1343 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
1344 IS_NUMBER_INFINITY|5.007002||p
1345 IS_NUMBER_IN_UV|5.007002||p
1346 IS_NUMBER_NAN|5.007003||p
1347 IS_NUMBER_NEG|5.007002||p
1348 IS_NUMBER_NOT_INT|5.007002||p
1355 MY_CXT_CLONE|5.009002||p
1356 MY_CXT_INIT|5.007003||p
1378 PAD_COMPNAME_FLAGS|||
1380 PAD_COMPNAME_OURSTASH|||
1382 PAD_COMPNAME_TYPE|||
1383 PAD_RESTORE_LOCAL|||
1385 PAD_SAVE_SETNULLPAD|||
1387 PAD_SET_CUR_NOSAVE|||
1391 PERL_BCDVERSION|5.009002||p
1392 PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p
1393 PERL_INT_MAX|5.004000||p
1394 PERL_INT_MIN|5.004000||p
1395 PERL_LONG_MAX|5.004000||p
1396 PERL_LONG_MIN|5.004000||p
1397 PERL_MAGIC_arylen|5.007002||p
1398 PERL_MAGIC_backref|5.007002||p
1399 PERL_MAGIC_bm|5.007002||p
1400 PERL_MAGIC_collxfrm|5.007002||p
1401 PERL_MAGIC_dbfile|5.007002||p
1402 PERL_MAGIC_dbline|5.007002||p
1403 PERL_MAGIC_defelem|5.007002||p
1404 PERL_MAGIC_envelem|5.007002||p
1405 PERL_MAGIC_env|5.007002||p
1406 PERL_MAGIC_ext|5.007002||p
1407 PERL_MAGIC_fm|5.007002||p
1408 PERL_MAGIC_glob|5.007002||p
1409 PERL_MAGIC_isaelem|5.007002||p
1410 PERL_MAGIC_isa|5.007002||p
1411 PERL_MAGIC_mutex|5.007002||p
1412 PERL_MAGIC_nkeys|5.007002||p
1413 PERL_MAGIC_overload_elem|5.007002||p
1414 PERL_MAGIC_overload_table|5.007002||p
1415 PERL_MAGIC_overload|5.007002||p
1416 PERL_MAGIC_pos|5.007002||p
1417 PERL_MAGIC_qr|5.007002||p
1418 PERL_MAGIC_regdata|5.007002||p
1419 PERL_MAGIC_regdatum|5.007002||p
1420 PERL_MAGIC_regex_global|5.007002||p
1421 PERL_MAGIC_shared_scalar|5.007003||p
1422 PERL_MAGIC_shared|5.007003||p
1423 PERL_MAGIC_sigelem|5.007002||p
1424 PERL_MAGIC_sig|5.007002||p
1425 PERL_MAGIC_substr|5.007002||p
1426 PERL_MAGIC_sv|5.007002||p
1427 PERL_MAGIC_taint|5.007002||p
1428 PERL_MAGIC_tiedelem|5.007002||p
1429 PERL_MAGIC_tiedscalar|5.007002||p
1430 PERL_MAGIC_tied|5.007002||p
1431 PERL_MAGIC_utf8|5.008001||p
1432 PERL_MAGIC_uvar_elem|5.007003||p
1433 PERL_MAGIC_uvar|5.007002||p
1434 PERL_MAGIC_vec|5.007002||p
1435 PERL_MAGIC_vstring|5.008001||p
1436 PERL_QUAD_MAX|5.004000||p
1437 PERL_QUAD_MIN|5.004000||p
1438 PERL_REVISION|5.006000||p
1439 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
1440 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
1441 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
1442 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
1443 PERL_SHORT_MAX|5.004000||p
1444 PERL_SHORT_MIN|5.004000||p
1445 PERL_SUBVERSION|5.006000||p
1446 PERL_UCHAR_MAX|5.004000||p
1447 PERL_UCHAR_MIN|5.004000||p
1448 PERL_UINT_MAX|5.004000||p
1449 PERL_UINT_MIN|5.004000||p
1450 PERL_ULONG_MAX|5.004000||p
1451 PERL_ULONG_MIN|5.004000||p
1452 PERL_UNUSED_DECL|5.007002||p
1453 PERL_UQUAD_MAX|5.004000||p
1454 PERL_UQUAD_MIN|5.004000||p
1455 PERL_USHORT_MAX|5.004000||p
1456 PERL_USHORT_MIN|5.004000||p
1457 PERL_VERSION|5.006000||p
1462 PL_compiling|5.004050||p
1463 PL_copline|5.005000||p
1464 PL_curcop|5.004050||p
1465 PL_curstash|5.004050||p
1466 PL_debstash|5.004050||p
1467 PL_defgv|5.004050||p
1468 PL_diehook|5.004050||p
1469 PL_dirty|5.004050||p
1471 PL_errgv|5.004050||p
1472 PL_hexdigit|5.005000||p
1473 PL_hints|5.005000||p
1475 PL_modglobal||5.005000|n
1477 PL_no_modify|5.006000||p
1479 PL_perl_destruct_level|5.004050||p
1480 PL_perldb|5.004050||p
1481 PL_ppaddr|5.006000||p
1482 PL_rsfp_filters|5.004050||p
1485 PL_stack_base|5.004050||p
1486 PL_stack_sp|5.004050||p
1487 PL_stdingv|5.004050||p
1488 PL_sv_arenaroot|5.004050||p
1489 PL_sv_no|5.004050||pn
1490 PL_sv_undef|5.004050||pn
1491 PL_sv_yes|5.004050||pn
1492 PL_tainted|5.004050||p
1493 PL_tainting|5.004050||p
1497 POPpbytex||5.007001|n
1508 PUSHmortal|5.009002||p
1514 PerlIO_clearerr||5.007003|
1515 PerlIO_close||5.007003|
1516 PerlIO_eof||5.007003|
1517 PerlIO_error||5.007003|
1518 PerlIO_fileno||5.007003|
1519 PerlIO_fill||5.007003|
1520 PerlIO_flush||5.007003|
1521 PerlIO_get_base||5.007003|
1522 PerlIO_get_bufsiz||5.007003|
1523 PerlIO_get_cnt||5.007003|
1524 PerlIO_get_ptr||5.007003|
1525 PerlIO_read||5.007003|
1526 PerlIO_seek||5.007003|
1527 PerlIO_set_cnt||5.007003|
1528 PerlIO_set_ptrcnt||5.007003|
1529 PerlIO_setlinebuf||5.007003|
1530 PerlIO_stderr||5.007003|
1531 PerlIO_stdin||5.007003|
1532 PerlIO_stdout||5.007003|
1533 PerlIO_tell||5.007003|
1534 PerlIO_unread||5.007003|
1535 PerlIO_write||5.007003|
1544 SAVE_DEFSV|5.004050||p
1547 START_EXTERN_C|5.005000||p
1548 START_MY_CXT|5.007003||p
1566 SvGETMAGIC|5.004050||p
1569 SvIOK_notUV||5.006000|
1571 SvIOK_only_UV||5.006000|
1577 SvIV_nomg|5.009001||p
1580 SvIsCOW_shared_hash||5.008003|
1598 SvPOK_only_UTF8||5.006000|
1604 SvPV_force_nomg|5.007002||p
1606 SvPV_nolen|5.006000||p
1607 SvPV_nomg|5.007002||p
1608 SvPVbyte_force||5.009002|
1609 SvPVbyte_nolen||5.006000|
1610 SvPVbytex_force||5.006000|
1611 SvPVbytex||5.006000|
1612 SvPVbyte|5.006000||p
1613 SvPVutf8_force||5.006000|
1614 SvPVutf8_nolen||5.006000|
1615 SvPVutf8x_force||5.006000|
1616 SvPVutf8x||5.006000|
1630 SvSetMagicSV_nosteal||5.004000|
1631 SvSetMagicSV||5.004000|
1632 SvSetSV_nosteal||5.004000|
1634 SvTAINTED_off||5.004000|
1635 SvTAINTED_on||5.004000|
1636 SvTAINTED||5.004000|
1643 SvUTF8_off||5.006000|
1644 SvUTF8_on||5.006000|
1648 SvUV_nomg|5.009001||p
1653 UNDERBAR|5.009002||p
1661 XPUSHmortal|5.009002||p
1672 XSRETURN_UV|5.008001||p
1682 XS_VERSION_BOOTCHECK|||
1687 _aMY_CXT|5.007003||p
1688 _pMY_CXT|5.007003||p
1689 aMY_CXT_|5.007003||p
1701 apply_attrs_string||5.006001|
1706 atfork_lock||5.007003|n
1707 atfork_unlock||5.007003|n
1709 av_delete||5.006000|
1710 av_exists||5.006000|
1728 block_gimme||5.004000|
1732 boot_core_UNIVERSAL|||
1733 boot_core_xsutils|||
1734 bytes_from_utf8||5.007001|
1735 bytes_to_utf8||5.006001|
1737 call_argv|5.006000||p
1738 call_atexit||5.006000|
1741 call_list||5.004000|
1742 call_method|5.006000||p
1749 cast_ulong||5.006000|
1764 croak_nocontext|||vn
1766 csighandler||5.007001|n
1767 custom_op_desc||5.007003|
1768 custom_op_name||5.007003|
1771 cv_const_sv||5.004000|
1780 dMY_CXT_SV|5.007003||p
1789 dUNDERBAR|5.009002||p
1797 debprofdump||5.005000|
1799 debstackptrs||5.007003|
1821 despatch_signals||5.007001|
1831 do_binmode||5.004050|
1840 do_gv_dump||5.006000|
1841 do_gvgv_dump||5.006000|
1842 do_hv_dump||5.006000|
1847 do_magic_dump||5.006000|
1851 do_op_dump||5.006000|
1856 do_pmop_dump||5.006000|
1865 do_sv_dump||5.006000|
1868 do_trans_complex_utf8|||
1870 do_trans_count_utf8|||
1872 do_trans_simple_utf8|||
1885 doing_taint||5.008001|n
1897 dump_eval||5.006000|
1899 dump_form||5.006000|
1900 dump_indent||5.006000|v
1902 dump_packsubs||5.006000|
1904 dump_vindent||5.006000|
1911 fbm_compile||5.005000|
1912 fbm_instr||5.005000|
1922 find_rundefsvoffset||5.009002|
1935 fprintf_nocontext|||vn
1936 free_tied_hv_pool|||
1938 gen_constant_list|||
1940 get_context||5.006000|n
1949 get_op_descs||5.005000|
1950 get_op_names||5.005000|
1952 get_ppaddr||5.006000|
1955 getcwd_sv||5.007002|
1960 grok_bin|5.007003||p
1961 grok_hex|5.007003||p
1962 grok_number|5.007002||p
1963 grok_numeric_radix|5.007002||p
1964 grok_oct|5.007003||p
1969 gv_autoload4||5.004000|
1972 gv_efullname3||5.004000|
1973 gv_efullname4||5.006001|
1977 gv_fetchmeth_autoload||5.007003|
1978 gv_fetchmethod_autoload||5.004000|
1982 gv_fullname3||5.004000|
1983 gv_fullname4||5.006001|
1985 gv_handler||5.007001|
1989 gv_stashpvn|5.006000||p
1995 hv_assert||5.009001|
1996 hv_clear_placeholders||5.009001|
1998 hv_delayfree_ent||5.004000|
2000 hv_delete_ent||5.004000|
2002 hv_exists_ent||5.004000|
2005 hv_fetch_ent||5.004000|
2007 hv_free_ent||5.004000|
2009 hv_iterkeysv||5.004000|
2011 hv_iternext_flags||5.008000|
2015 hv_ksplit||5.004000|
2019 hv_scalar||5.009001|
2020 hv_store_ent||5.004000|
2021 hv_store_flags||5.008000|
2024 ibcmp_locale||5.004000|
2025 ibcmp_utf8||5.007003|
2031 init_argv_symbols|||
2033 init_i18nl10n||5.006000|
2034 init_i18nl14n||5.006000|
2040 init_postdump_symbols|||
2041 init_predump_symbols|||
2042 init_stacks||5.005000|
2058 is_handle_constructor|||
2059 is_lvalue_sub||5.007001|
2060 is_uni_alnum_lc||5.006000|
2061 is_uni_alnumc_lc||5.006000|
2062 is_uni_alnumc||5.006000|
2063 is_uni_alnum||5.006000|
2064 is_uni_alpha_lc||5.006000|
2065 is_uni_alpha||5.006000|
2066 is_uni_ascii_lc||5.006000|
2067 is_uni_ascii||5.006000|
2068 is_uni_cntrl_lc||5.006000|
2069 is_uni_cntrl||5.006000|
2070 is_uni_digit_lc||5.006000|
2071 is_uni_digit||5.006000|
2072 is_uni_graph_lc||5.006000|
2073 is_uni_graph||5.006000|
2074 is_uni_idfirst_lc||5.006000|
2075 is_uni_idfirst||5.006000|
2076 is_uni_lower_lc||5.006000|
2077 is_uni_lower||5.006000|
2078 is_uni_print_lc||5.006000|
2079 is_uni_print||5.006000|
2080 is_uni_punct_lc||5.006000|
2081 is_uni_punct||5.006000|
2082 is_uni_space_lc||5.006000|
2083 is_uni_space||5.006000|
2084 is_uni_upper_lc||5.006000|
2085 is_uni_upper||5.006000|
2086 is_uni_xdigit_lc||5.006000|
2087 is_uni_xdigit||5.006000|
2088 is_utf8_alnumc||5.006000|
2089 is_utf8_alnum||5.006000|
2090 is_utf8_alpha||5.006000|
2091 is_utf8_ascii||5.006000|
2092 is_utf8_char||5.006000|
2093 is_utf8_cntrl||5.006000|
2094 is_utf8_digit||5.006000|
2095 is_utf8_graph||5.006000|
2096 is_utf8_idcont||5.008000|
2097 is_utf8_idfirst||5.006000|
2098 is_utf8_lower||5.006000|
2099 is_utf8_mark||5.006000|
2100 is_utf8_print||5.006000|
2101 is_utf8_punct||5.006000|
2102 is_utf8_space||5.006000|
2103 is_utf8_string_loc||5.008001|
2104 is_utf8_string||5.006001|
2105 is_utf8_upper||5.006000|
2106 is_utf8_xdigit||5.006000|
2119 load_module_nocontext|||vn
2120 load_module||5.006000|v
2122 looks_like_number|||
2132 magic_clear_all_env|||
2136 magic_dump||5.006000|
2152 magic_killbackrefs|||
2157 magic_regdata_cnt|||
2158 magic_regdatum_get|||
2159 magic_regdatum_set|||
2161 magic_set_all_env|||
2165 magic_setcollxfrm|||
2205 mg_length||5.005000|
2209 mini_mktime||5.007002|
2211 mode_from_discipline|||
2245 my_failure_exit||5.004000|
2246 my_fflush_all||5.006000|
2269 my_memcmp||5.004000|n
2272 my_pclose||5.004000|
2273 my_popen_list||5.007001|
2276 my_socketpair||5.007003|n
2278 my_strftime||5.007002|
2283 newANONATTRSUB||5.006000|
2288 newATTRSUB||5.006000|
2293 newCONSTSUB|5.006000||p
2317 newRV_inc|5.004000||p
2318 newRV_noinc|5.006000||p
2327 newSVpvf_nocontext|||vn
2328 newSVpvf||5.004000|v
2329 newSVpvn_share||5.007001|
2330 newSVpvn|5.006000||p
2337 newWHILEOP||5.004040|
2338 newXSproto||5.006000|
2340 new_collate||5.006000|
2342 new_ctype||5.006000|
2345 new_numeric||5.006000|
2346 new_stackinfo||5.005000|
2347 new_version||5.009000|
2364 no_bareword_allowed|||
2368 nothreadhook||5.008000|
2380 pMY_CXT_|5.007003||p
2395 pad_fixup_inner_anons|||
2407 parse_unicode_opts|||
2411 perl_alloc_using|||n
2413 perl_clone_using|||n
2416 perl_destruct||5.007003|n
2418 perl_parse||5.006000|n
2422 pmop_dump||5.006000|
2430 printf_nocontext|||vn
2439 pv_display||5.006000|
2440 pv_uni_display||5.007003|
2444 re_intuit_start||5.006000|
2445 re_intuit_string||5.006000|
2449 reentrant_retry|||vn
2458 regclass_swash||5.007003|
2465 regexec_flags||5.005000|
2471 reginitcolors||5.006000|
2490 require_pv||5.006000|
2494 rsignal_state||5.004000|
2497 runops_debug||5.005000|
2498 runops_standard||5.005000|
2502 safesyscalloc||5.006000|n
2503 safesysfree||5.006000|n
2504 safesysmalloc||5.006000|n
2505 safesysrealloc||5.006000|n
2510 save_aelem||5.004050|
2511 save_alloc||5.006000|
2514 save_bool||5.008001|
2517 save_destructor_x||5.006000|
2518 save_destructor||5.006000|
2522 save_generic_pvref||5.006001|
2523 save_generic_svref||5.005030|
2527 save_helem||5.004050|
2528 save_hints||5.005000|
2537 save_mortalizesv||5.007001|
2540 save_padsv||5.007001|
2542 save_re_context||5.006000|
2545 save_set_svflags||5.009000|
2546 save_shared_pvref||5.007003|
2549 save_threadsv||5.005000|
2550 save_vptr||5.006000|
2553 savesharedpv||5.007003|
2554 savestack_grow_cnt||5.008001|
2577 scan_version||5.009001|
2578 scan_vstring||5.008001|
2581 screaminstr||5.005000|
2583 set_context||5.006000|n
2585 set_numeric_local||5.006000|
2586 set_numeric_radix||5.006000|
2587 set_numeric_standard||5.006000|
2600 start_subparse||5.004000|
2608 str_to_version||5.006000|
2619 sv_2iuv_non_preserve|||
2620 sv_2iv_flags||5.009001|
2624 sv_2pv_flags||5.007002|
2625 sv_2pv_nolen|5.006000||p
2627 sv_2pvbyte|5.006000||p
2628 sv_2pvutf8_nolen||5.006000|
2629 sv_2pvutf8||5.006000|
2631 sv_2uv_flags||5.009001|
2637 sv_cat_decode||5.008001|
2638 sv_catpv_mg|5.006000||p
2639 sv_catpvf_mg_nocontext|||pvn
2640 sv_catpvf_mg|5.006000|5.004000|pv
2641 sv_catpvf_nocontext|||vn
2642 sv_catpvf||5.004000|v
2643 sv_catpvn_flags||5.007002|
2644 sv_catpvn_mg|5.006000||p
2645 sv_catpvn_nomg|5.007002||p
2648 sv_catsv_flags||5.007002|
2649 sv_catsv_mg|5.006000||p
2650 sv_catsv_nomg|5.007002||p
2656 sv_cmp_locale||5.004000|
2659 sv_compile_2op||5.008001|
2660 sv_copypv||5.007003|
2663 sv_derived_from||5.004000|
2667 sv_force_normal_flags||5.007001|
2668 sv_force_normal||5.006000|
2679 sv_len_utf8||5.006000|
2681 sv_magicext||5.007003|
2686 sv_nolocking||5.007003|
2687 sv_nosharing||5.007003|
2688 sv_nounlocking||5.007003|
2691 sv_pos_b2u||5.006000|
2692 sv_pos_u2b||5.006000|
2693 sv_pvbyten_force||5.006000|
2694 sv_pvbyten||5.006000|
2695 sv_pvbyte||5.006000|
2696 sv_pvn_force_flags||5.007002|
2698 sv_pvn_nomg|5.007003||p
2700 sv_pvutf8n_force||5.006000|
2701 sv_pvutf8n||5.006000|
2702 sv_pvutf8||5.006000|
2704 sv_recode_to_utf8||5.007003|
2711 sv_rvweaken||5.006000|
2712 sv_setiv_mg|5.006000||p
2714 sv_setnv_mg|5.006000||p
2716 sv_setpv_mg|5.006000||p
2717 sv_setpvf_mg_nocontext|||pvn
2718 sv_setpvf_mg|5.006000|5.004000|pv
2719 sv_setpvf_nocontext|||vn
2720 sv_setpvf||5.004000|v
2721 sv_setpviv_mg||5.008001|
2722 sv_setpviv||5.008001|
2723 sv_setpvn_mg|5.006000||p
2730 sv_setref_uv||5.007001|
2732 sv_setsv_flags||5.007002|
2733 sv_setsv_mg|5.006000||p
2734 sv_setsv_nomg|5.007002||p
2736 sv_setuv_mg|5.006000||p
2737 sv_setuv|5.006000||p
2738 sv_tainted||5.004000|
2742 sv_uni_display||5.007003|
2744 sv_unref_flags||5.007001|
2746 sv_untaint||5.004000|
2748 sv_usepvn_mg|5.006000||p
2750 sv_utf8_decode||5.006000|
2751 sv_utf8_downgrade||5.006000|
2752 sv_utf8_encode||5.006000|
2753 sv_utf8_upgrade_flags||5.007002|
2754 sv_utf8_upgrade||5.007001|
2756 sv_vcatpvf_mg|5.006000|5.004000|p
2757 sv_vcatpvfn||5.004000|
2758 sv_vcatpvf|5.006000|5.004000|p
2759 sv_vsetpvf_mg|5.006000|5.004000|p
2760 sv_vsetpvfn||5.004000|
2761 sv_vsetpvf|5.006000|5.004000|p
2764 swash_fetch||5.007002|
2765 swash_init||5.006000|
2771 tmps_grow||5.006000|
2775 to_uni_fold||5.007003|
2776 to_uni_lower_lc||5.006000|
2777 to_uni_lower||5.007003|
2778 to_uni_title_lc||5.006000|
2779 to_uni_title||5.007003|
2780 to_uni_upper_lc||5.006000|
2781 to_uni_upper||5.007003|
2782 to_utf8_case||5.007003|
2783 to_utf8_fold||5.007003|
2784 to_utf8_lower||5.007003|
2786 to_utf8_title||5.007003|
2787 to_utf8_upper||5.007003|
2790 too_few_arguments|||
2791 too_many_arguments|||
2794 unpack_str||5.007003|
2795 unpackstring||5.008001|
2796 unshare_hek_or_pvn|||
2798 unsharepvn||5.004000|
2799 upg_version||5.009000|
2802 utf16_to_utf8_reversed||5.006001|
2803 utf16_to_utf8||5.006001|
2804 utf16rev_textfilter|||
2805 utf8_distance||5.006000|
2807 utf8_length||5.007001|
2810 utf8_to_bytes||5.006001|
2811 utf8_to_uvchr||5.007001|
2812 utf8_to_uvuni||5.007001|
2813 utf8n_to_uvchr||5.007001|
2814 utf8n_to_uvuni||5.007001|
2816 uvchr_to_utf8_flags||5.007003|
2817 uvchr_to_utf8||5.007001|
2818 uvuni_to_utf8_flags||5.007003|
2819 uvuni_to_utf8||5.007001|
2833 vload_module||5.006000|
2835 vnewSVpvf|5.006000|5.004000|p
2840 vstringify||5.009000|
2845 warner_nocontext|||vn
2857 if (exists $opt{'list-unsupported'}) {
2859 for $f (sort { lc $a cmp lc $b } keys %API) {
2860 next unless $API{$f}{todo};
2861 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
2866 # Scan for possible replacement candidates
2868 my(%replace, %need, %hints, %depends);
2874 if (m{^\s*\*\s(.*?)\s*$}) {
2875 $hints{$hint} ||= ''; # suppress warning with older perls
2876 $hints{$hint} .= "$1\n";
2882 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
2884 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
2885 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
2886 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
2887 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
2889 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
2890 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
2893 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
2896 if (exists $opt{'list-provided'}) {
2898 for $f (sort { lc $a cmp lc $b } keys %API) {
2899 next unless $API{$f}{provided};
2901 push @flags, 'explicit' if exists $need{$f};
2902 push @flags, 'depend' if exists $depends{$f};
2903 push @flags, 'hint' if exists $hints{$f};
2904 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
2910 my(%files, %global, %revreplace);
2911 %revreplace = reverse %replace;
2913 my $patch_opened = 0;
2915 for $filename (@files) {
2916 unless (open IN, "<$filename") {
2917 warn "Unable to read from $filename: $!\n";
2921 info("Scanning $filename ...");
2923 my $c = do { local $/; <IN> };
2926 my %file = (orig => $c, changes => 0);
2928 # temporarily remove C comments from the code
2934 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
2936 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
2940 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
2945 defined $2 and push @ccom, $2;
2946 defined $1 ? $1 : "$ccs$#ccom$cce";
2949 $file{ccom} = \@ccom;
2951 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
2955 for $func (keys %API) {
2957 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
2958 if ($c =~ /\b(?:Perl_)?($match)\b/) {
2959 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
2960 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
2961 if (exists $API{$func}{provided}) {
2962 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
2963 $file{uses}{$func}++;
2964 my @deps = rec_depend($func);
2966 $file{uses_deps}{$func} = \@deps;
2968 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
2971 for ($func, @deps) {
2972 if (exists $need{$_}) {
2973 $file{needs}{$_} = 'static';
2978 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
2979 if ($c =~ /\b$func\b/) {
2980 $file{uses_todo}{$func}++;
2986 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
2987 if (exists $need{$2}) {
2988 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
2991 warning("Possibly wrong #define $1 in $filename");
2995 for (qw(uses needs uses_todo needed_global needed_static)) {
2996 for $func (keys %{$file{$_}}) {
2997 push @{$global{$_}{$func}}, $filename;
3001 $files{$filename} = \%file;
3004 # Globally resolve NEED_'s
3006 for $need (keys %{$global{needs}}) {
3007 if (@{$global{needs}{$need}} > 1) {
3008 my @targets = @{$global{needs}{$need}};
3009 my @t = grep $files{$_}{needed_global}{$need}, @targets;
3010 @targets = @t if @t;
3011 @t = grep /\.xs$/i, @targets;
3012 @targets = @t if @t;
3013 my $target = shift @targets;
3014 $files{$target}{needs}{$need} = 'global';
3015 for (@{$global{needs}{$need}}) {
3016 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
3021 for $filename (@files) {
3022 exists $files{$filename} or next;
3024 info("=== Analyzing $filename ===");
3026 my %file = %{$files{$filename}};
3028 my $c = $file{code};
3030 for $func (sort keys %{$file{uses_Perl}}) {
3031 if ($API{$func}{varargs}) {
3032 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
3033 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
3035 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
3036 $file{changes} += $changes;
3040 warning("Uses Perl_$func instead of $func");
3041 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
3046 for $func (sort keys %{$file{uses_replace}}) {
3047 warning("Uses $func instead of $replace{$func}");
3048 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3051 for $func (sort keys %{$file{uses}}) {
3052 next unless $file{uses}{$func}; # if it's only a dependency
3053 if (exists $file{uses_deps}{$func}) {
3054 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
3056 elsif (exists $replace{$func}) {
3057 warning("Uses $func instead of $replace{$func}");
3058 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3066 for $func (sort keys %{$file{uses_todo}}) {
3067 warning("Uses $func, which may not be portable below perl ",
3068 format_version($API{$func}{todo}));
3071 for $func (sort keys %{$file{needed_static}}) {
3073 if (not exists $file{uses}{$func}) {
3074 $message = "No need to define NEED_$func if $func is never used";
3076 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
3077 $message = "No need to define NEED_$func when already needed globally";
3081 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
3085 for $func (sort keys %{$file{needed_global}}) {
3087 if (not exists $global{uses}{$func}) {
3088 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
3090 elsif (exists $file{needs}{$func}) {
3091 if ($file{needs}{$func} eq 'extern') {
3092 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
3094 elsif ($file{needs}{$func} eq 'static') {
3095 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
3100 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
3104 $file{needs_inc_ppport} = keys %{$file{uses}};
3106 if ($file{needs_inc_ppport}) {
3109 for $func (sort keys %{$file{needs}}) {
3110 my $type = $file{needs}{$func};
3111 next if $type eq 'extern';
3112 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
3113 unless (exists $file{"needed_$type"}{$func}) {
3114 if ($type eq 'global') {
3115 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
3118 diag("File needs $func, adding static request");
3120 $pp .= "#define NEED_$func$suffix\n";
3124 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
3129 unless ($file{has_inc_ppport}) {
3130 diag("Needs to include '$ppport'");
3131 $pp .= qq(#include "$ppport"\n)
3135 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
3136 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
3137 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
3138 || ($c =~ s/^/$pp/);
3142 if ($file{has_inc_ppport}) {
3143 diag("No need to include '$ppport'");
3144 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
3148 # put back in our C comments
3151 my @ccom = @{$file{ccom}};
3152 for $ix (0 .. $#ccom) {
3153 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
3155 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
3158 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
3163 my $s = $cppc != 1 ? 's' : '';
3164 warning("Uses $cppc C++ style comment$s, which is not portable");
3167 if ($file{changes}) {
3168 if (exists $opt{copy}) {
3169 my $newfile = "$filename$opt{copy}";
3171 error("'$newfile' already exists, refusing to write copy of '$filename'");
3175 if (open F, ">$newfile") {
3176 info("Writing copy of '$filename' with changes to '$newfile'");
3181 error("Cannot open '$newfile' for writing: $!");
3185 elsif (exists $opt{patch} || $opt{changes}) {
3186 if (exists $opt{patch}) {
3187 unless ($patch_opened) {
3188 if (open PATCH, ">$opt{patch}") {
3192 error("Cannot open '$opt{patch}' for writing: $!");
3198 mydiff(\*PATCH, $filename, $c);
3202 info("Suggested changes:");
3203 mydiff(\*STDOUT, $filename, $c);
3207 my $s = $file{changes} == 1 ? '' : 's';
3208 info("$file{changes} potentially required change$s detected");
3216 close PATCH if $patch_opened;
3224 my($file, $str) = @_;
3227 if (exists $opt{diff}) {
3228 $diff = run_diff($opt{diff}, $file, $str);
3231 if (!defined $diff and can_use('Text::Diff')) {
3232 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
3233 $diff = <<HEADER . $diff;
3239 if (!defined $diff) {
3240 $diff = run_diff('diff -u', $file, $str);
3243 if (!defined $diff) {
3244 $diff = run_diff('diff', $file, $str);
3247 if (!defined $diff) {
3248 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
3258 my($prog, $file, $str) = @_;
3259 my $tmp = 'dppptemp';
3264 while (-e "$tmp.$suf") { $suf++ }
3267 if (open F, ">$tmp") {
3271 if (open F, "$prog $file $tmp |") {
3273 s/\Q$tmp\E/$file.patched/;
3284 error("Cannot open '$tmp' for writing: $!");
3300 return () unless exists $depends{$func};
3301 grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
3308 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
3309 return ($1, $2, $3);
3311 elsif ($ver !~ /^\d+\.[\d_]+$/) {
3312 die "cannot parse version '$ver'\n";
3316 $ver =~ s/$/000000/;
3318 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3323 if ($r < 5 || ($r == 5 && $v < 6)) {
3325 die "cannot parse version '$ver'\n";
3329 return ($r, $v, $s);
3336 $ver =~ s/$/000000/;
3337 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3342 if ($r < 5 || ($r == 5 && $v < 6)) {
3344 die "invalid version '$ver'\n";
3348 $ver = sprintf "%d.%03d", $r, $v;
3349 $s > 0 and $ver .= sprintf "_%02d", $s;
3354 return sprintf "%d.%d.%d", $r, $v, $s;
3359 $opt{quiet} and return;
3365 $opt{quiet} and return;
3366 $opt{diag} and print @_, "\n";
3371 $opt{quiet} and return;
3372 print "*** ", @_, "\n";
3377 print "*** ERROR: ", @_, "\n";
3383 $opt{quiet} and return;
3384 $opt{hints} or return;
3386 exists $hints{$func} or return;
3387 $given_hints{$func}++ and return;
3388 my $hint = $hints{$func};
3390 print " --- hint for $func ---\n", $hint;
3395 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
3396 my %M = ( 'I' => '*' );
3397 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
3398 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
3404 See perldoc $0 for details.
3414 #ifndef _P_P_PORTABILITY_H_
3415 #define _P_P_PORTABILITY_H_
3417 #ifndef DPPP_NAMESPACE
3418 # define DPPP_NAMESPACE DPPP_
3421 #define DPPP_CAT2(x,y) CAT2(x,y)
3422 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
3424 #ifndef PERL_REVISION
3425 # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
3426 # define PERL_PATCHLEVEL_H_IMPLICIT
3427 # include <patchlevel.h>
3429 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
3430 # include <could_not_find_Perl_patchlevel.h>
3432 # ifndef PERL_REVISION
3433 # define PERL_REVISION (5)
3435 # define PERL_VERSION PATCHLEVEL
3436 # define PERL_SUBVERSION SUBVERSION
3437 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
3442 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
3444 /* It is very unlikely that anyone will try to use this with Perl 6
3445 (or greater), but who knows.
3447 #if PERL_REVISION != 5
3448 # error ppport.h only works with Perl version 5
3449 #endif /* PERL_REVISION != 5 */
3452 # include <limits.h>
3455 #ifndef PERL_UCHAR_MIN
3456 # define PERL_UCHAR_MIN ((unsigned char)0)
3459 #ifndef PERL_UCHAR_MAX
3461 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
3464 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
3466 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
3471 #ifndef PERL_USHORT_MIN
3472 # define PERL_USHORT_MIN ((unsigned short)0)
3475 #ifndef PERL_USHORT_MAX
3477 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
3480 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
3483 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
3485 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
3491 #ifndef PERL_SHORT_MAX
3493 # define PERL_SHORT_MAX ((short)SHORT_MAX)
3495 # ifdef MAXSHORT /* Often used in <values.h> */
3496 # define PERL_SHORT_MAX ((short)MAXSHORT)
3499 # define PERL_SHORT_MAX ((short)SHRT_MAX)
3501 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
3507 #ifndef PERL_SHORT_MIN
3509 # define PERL_SHORT_MIN ((short)SHORT_MIN)
3512 # define PERL_SHORT_MIN ((short)MINSHORT)
3515 # define PERL_SHORT_MIN ((short)SHRT_MIN)
3517 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
3523 #ifndef PERL_UINT_MAX
3525 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
3528 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
3530 # define PERL_UINT_MAX (~(unsigned int)0)
3535 #ifndef PERL_UINT_MIN
3536 # define PERL_UINT_MIN ((unsigned int)0)
3539 #ifndef PERL_INT_MAX
3541 # define PERL_INT_MAX ((int)INT_MAX)
3543 # ifdef MAXINT /* Often used in <values.h> */
3544 # define PERL_INT_MAX ((int)MAXINT)
3546 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
3551 #ifndef PERL_INT_MIN
3553 # define PERL_INT_MIN ((int)INT_MIN)
3556 # define PERL_INT_MIN ((int)MININT)
3558 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
3563 #ifndef PERL_ULONG_MAX
3565 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
3568 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
3570 # define PERL_ULONG_MAX (~(unsigned long)0)
3575 #ifndef PERL_ULONG_MIN
3576 # define PERL_ULONG_MIN ((unsigned long)0L)
3579 #ifndef PERL_LONG_MAX
3581 # define PERL_LONG_MAX ((long)LONG_MAX)
3584 # define PERL_LONG_MAX ((long)MAXLONG)
3586 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
3591 #ifndef PERL_LONG_MIN
3593 # define PERL_LONG_MIN ((long)LONG_MIN)
3596 # define PERL_LONG_MIN ((long)MINLONG)
3598 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
3603 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
3604 # ifndef PERL_UQUAD_MAX
3605 # ifdef ULONGLONG_MAX
3606 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
3608 # ifdef MAXULONGLONG
3609 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
3611 # define PERL_UQUAD_MAX (~(unsigned long long)0)
3616 # ifndef PERL_UQUAD_MIN
3617 # define PERL_UQUAD_MIN ((unsigned long long)0L)
3620 # ifndef PERL_QUAD_MAX
3621 # ifdef LONGLONG_MAX
3622 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
3625 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
3627 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
3632 # ifndef PERL_QUAD_MIN
3633 # ifdef LONGLONG_MIN
3634 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
3637 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
3639 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
3645 /* This is based on code from 5.003 perl.h */
3653 # define IV_MIN PERL_INT_MIN
3657 # define IV_MAX PERL_INT_MAX
3661 # define UV_MIN PERL_UINT_MIN
3665 # define UV_MAX PERL_UINT_MAX
3670 # define IVSIZE INTSIZE
3675 # if defined(convex) || defined(uts)
3677 # define IVTYPE long long
3681 # define IV_MIN PERL_QUAD_MIN
3685 # define IV_MAX PERL_QUAD_MAX
3689 # define UV_MIN PERL_UQUAD_MIN
3693 # define UV_MAX PERL_UQUAD_MAX
3696 # ifdef LONGLONGSIZE
3698 # define IVSIZE LONGLONGSIZE
3704 # define IVTYPE long
3708 # define IV_MIN PERL_LONG_MIN
3712 # define IV_MAX PERL_LONG_MAX
3716 # define UV_MIN PERL_ULONG_MIN
3720 # define UV_MAX PERL_ULONG_MAX
3725 # define IVSIZE LONGSIZE
3735 #ifndef PERL_QUAD_MIN
3736 # define PERL_QUAD_MIN IV_MIN
3739 #ifndef PERL_QUAD_MAX
3740 # define PERL_QUAD_MAX IV_MAX
3743 #ifndef PERL_UQUAD_MIN
3744 # define PERL_UQUAD_MIN UV_MIN
3747 #ifndef PERL_UQUAD_MAX
3748 # define PERL_UQUAD_MAX UV_MAX
3753 # define IVTYPE long
3757 # define IV_MIN PERL_LONG_MIN
3761 # define IV_MAX PERL_LONG_MAX
3765 # define UV_MIN PERL_ULONG_MIN
3769 # define UV_MAX PERL_ULONG_MAX
3776 # define IVSIZE LONGSIZE
3778 # define IVSIZE 4 /* A bold guess, but the best we can make. */
3782 # define UVTYPE unsigned IVTYPE
3786 # define UVSIZE IVSIZE
3790 # define sv_setuv(sv, uv) \
3793 if (TeMpUv <= IV_MAX) \
3794 sv_setiv(sv, TeMpUv); \
3796 sv_setnv(sv, (double)TeMpUv); \
3801 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
3804 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
3808 # define SvUVX(sv) ((UV)SvIVX(sv))
3812 # define SvUVXx(sv) SvUVX(sv)
3816 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
3820 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
3824 * Always use the SvUVx() macro instead of sv_uv().
3827 # define sv_uv(sv) SvUVx(sv)
3830 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
3834 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
3837 # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
3841 # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
3844 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
3846 # define PL_DBsingle DBsingle
3847 # define PL_DBsub DBsub
3849 # define PL_compiling compiling
3850 # define PL_copline copline
3851 # define PL_curcop curcop
3852 # define PL_curstash curstash
3853 # define PL_debstash debstash
3854 # define PL_defgv defgv
3855 # define PL_diehook diehook
3856 # define PL_dirty dirty
3857 # define PL_dowarn dowarn
3858 # define PL_errgv errgv
3859 # define PL_hexdigit hexdigit
3860 # define PL_hints hints
3862 # define PL_no_modify no_modify
3863 # define PL_perl_destruct_level perl_destruct_level
3864 # define PL_perldb perldb
3865 # define PL_ppaddr ppaddr
3866 # define PL_rsfp_filters rsfp_filters
3867 # define PL_rsfp rsfp
3868 # define PL_stack_base stack_base
3869 # define PL_stack_sp stack_sp
3870 # define PL_stdingv stdingv
3871 # define PL_sv_arenaroot sv_arenaroot
3872 # define PL_sv_no sv_no
3873 # define PL_sv_undef sv_undef
3874 # define PL_sv_yes sv_yes
3875 # define PL_tainted tainted
3876 # define PL_tainting tainting
3881 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
3882 # define PERL_UNUSED_DECL
3884 # define PERL_UNUSED_DECL __attribute__((unused))
3887 # define PERL_UNUSED_DECL
3890 # define NOOP (void)0
3894 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
3898 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
3899 # define NVTYPE long double
3901 # define NVTYPE double
3908 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
3910 # define INT2PTR(any,d) (any)(d)
3912 # if PTRSIZE == LONGSIZE
3913 # define PTRV unsigned long
3915 # define PTRV unsigned
3917 # define INT2PTR(any,d) (any)(PTRV)(d)
3920 # define NUM2PTR(any,d) (any)(PTRV)(d)
3921 # define PTR2IV(p) INT2PTR(IV,p)
3922 # define PTR2UV(p) INT2PTR(UV,p)
3923 # define PTR2NV(p) NUM2PTR(NV,p)
3925 # if PTRSIZE == LONGSIZE
3926 # define PTR2ul(p) (unsigned long)(p)
3928 # define PTR2ul(p) INT2PTR(unsigned long,p)
3931 #endif /* !INT2PTR */
3933 #undef START_EXTERN_C
3937 # define START_EXTERN_C extern "C" {
3938 # define END_EXTERN_C }
3939 # define EXTERN_C extern "C"
3941 # define START_EXTERN_C
3942 # define END_EXTERN_C
3943 # define EXTERN_C extern
3946 #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
3947 # if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
3948 # define PERL_GCC_BRACE_GROUPS_FORBIDDEN
3954 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
3955 # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
3958 # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
3959 # define STMT_START if (1)
3960 # define STMT_END else (void)0
3962 # define STMT_START do
3963 # define STMT_END while (0)
3967 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
3970 /* DEFSV appears first in 5.004_56 */
3972 # define DEFSV GvSV(PL_defgv)
3976 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
3979 /* Older perls (<=5.003) lack AvFILLp */
3981 # define AvFILLp AvFILL
3984 # define ERRSV get_sv("@",FALSE)
3987 # define newSVpvn(data,len) ((data) \
3988 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
3992 /* Hint: gv_stashpvn
3993 * This function's backport doesn't support the length parameter, but
3994 * rather ignores it. Portability can only be ensured if the length
3995 * parameter is used for speed reasons, but the length can always be
3996 * correctly computed from the string argument.
3999 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
4004 # define get_cv perl_get_cv
4008 # define get_sv perl_get_sv
4012 # define get_av perl_get_av
4016 # define get_hv perl_get_hv
4023 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
4027 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
4032 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
4036 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
4041 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
4045 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
4050 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
4055 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
4060 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
4063 # define dUNDERBAR dNOOP
4067 # define UNDERBAR DEFSV
4070 # define dAX I32 ax = MARK - PL_stack_base + 1
4074 # define dITEMS I32 items = SP - MARK
4084 # define dTHXa(x) dNOOP
4102 # define dTHXoa(x) dTHXa(x)
4105 # define PUSHmortal PUSHs(sv_newmortal())
4109 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
4113 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
4117 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
4121 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
4124 # define XPUSHmortal XPUSHs(sv_newmortal())
4128 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
4132 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
4136 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
4140 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
4145 # define call_sv perl_call_sv
4149 # define call_pv perl_call_pv
4153 # define call_argv perl_call_argv
4157 # define call_method perl_call_method
4160 # define eval_sv perl_eval_sv
4165 /* Replace perl_eval_pv with eval_pv */
4166 /* eval_pv depends on eval_sv */
4169 #if defined(NEED_eval_pv)
4170 static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4173 extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
4179 #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
4180 #define Perl_eval_pv DPPP_(my_eval_pv)
4182 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
4185 DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
4188 SV* sv = newSVpv(p, 0);
4191 eval_sv(sv, G_SCALAR);
4198 if (croak_on_error && SvTRUE(GvSV(errgv)))
4199 croak(SvPVx(GvSV(errgv), na));
4207 # define newRV_inc(sv) newRV(sv) /* Replace */
4211 #if defined(NEED_newRV_noinc)
4212 static SV * DPPP_(my_newRV_noinc)(SV *sv);
4215 extern SV * DPPP_(my_newRV_noinc)(SV *sv);
4221 #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a)
4222 #define Perl_newRV_noinc DPPP_(my_newRV_noinc)
4224 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
4226 DPPP_(my_newRV_noinc)(SV *sv)
4228 SV *rv = (SV *)newRV(sv);
4235 /* Hint: newCONSTSUB
4236 * Returns a CV* as of perl-5.7.1. This return value is not supported
4240 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
4241 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
4242 #if defined(NEED_newCONSTSUB)
4243 static void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4246 extern void DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv);
4252 #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c)
4253 #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB)
4255 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
4258 DPPP_(my_newCONSTSUB)(HV *stash, char *name, SV *sv)
4260 U32 oldhints = PL_hints;
4261 HV *old_cop_stash = PL_curcop->cop_stash;
4262 HV *old_curstash = PL_curstash;
4263 line_t oldline = PL_curcop->cop_line;
4264 PL_curcop->cop_line = PL_copline;
4266 PL_hints &= ~HINT_BLOCK_SCOPE;
4268 PL_curstash = PL_curcop->cop_stash = stash;
4272 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
4274 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
4276 #else /* 5.003_23 onwards */
4277 start_subparse(FALSE, 0),
4280 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4281 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4282 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4285 PL_hints = oldhints;
4286 PL_curcop->cop_stash = old_cop_stash;
4287 PL_curstash = old_curstash;
4288 PL_curcop->cop_line = oldline;
4293 #ifndef START_MY_CXT
4296 * Boilerplate macros for initializing and accessing interpreter-local
4297 * data from C. All statics in extensions should be reworked to use
4298 * this, if you want to make the extension thread-safe. See ext/re/re.xs
4299 * for an example of the use of these macros.
4301 * Code that uses these macros is responsible for the following:
4302 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
4303 * 2. Declare a typedef named my_cxt_t that is a structure that contains
4304 * all the data that needs to be interpreter-local.
4305 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
4306 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
4307 * (typically put in the BOOT: section).
4308 * 5. Use the members of the my_cxt_t structure everywhere as
4310 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
4314 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
4315 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
4317 /* This must appear in all extensions that define a my_cxt_t structure,
4318 * right after the definition (i.e. at file scope). The non-threads
4319 * case below uses it to declare the data as static. */
4320 #define START_MY_CXT
4322 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
4323 /* Fetches the SV that keeps the per-interpreter data. */
4324 #define dMY_CXT_SV \
4325 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
4326 #else /* >= perl5.004_68 */
4327 #define dMY_CXT_SV \
4328 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
4329 sizeof(MY_CXT_KEY)-1, TRUE)
4330 #endif /* < perl5.004_68 */
4332 /* This declaration should be used within all functions that use the
4333 * interpreter-local data. */
4336 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
4338 /* Creates and zeroes the per-interpreter data.
4339 * (We allocate my_cxtp in a Perl SV so that it will be released when
4340 * the interpreter goes away.) */
4341 #define MY_CXT_INIT \
4343 /* newSV() allocates one more than needed */ \
4344 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4345 Zero(my_cxtp, 1, my_cxt_t); \
4346 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4348 /* Clones the per-interpreter data. */
4349 #define MY_CXT_CLONE \
4351 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4352 Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
4353 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4355 /* This macro must be used to access members of the my_cxt_t structure.
4356 * e.g. MYCXT.some_data */
4357 #define MY_CXT (*my_cxtp)
4359 /* Judicious use of these macros can reduce the number of times dMY_CXT
4360 * is used. Use is similar to pTHX, aTHX etc. */
4361 #define pMY_CXT my_cxt_t *my_cxtp
4362 #define pMY_CXT_ pMY_CXT,
4363 #define _pMY_CXT ,pMY_CXT
4364 #define aMY_CXT my_cxtp
4365 #define aMY_CXT_ aMY_CXT,
4366 #define _aMY_CXT ,aMY_CXT
4368 #else /* single interpreter */
4370 #define START_MY_CXT static my_cxt_t my_cxt;
4371 #define dMY_CXT_SV dNOOP
4372 #define dMY_CXT dNOOP
4373 #define MY_CXT_INIT NOOP
4374 #define MY_CXT_CLONE NOOP
4375 #define MY_CXT my_cxt
4377 #define pMY_CXT void
4386 #endif /* START_MY_CXT */
4389 # if IVSIZE == LONGSIZE
4396 # if IVSIZE == INTSIZE
4407 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
4408 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
4409 # define NVef PERL_PRIeldbl
4410 # define NVff PERL_PRIfldbl
4411 # define NVgf PERL_PRIgldbl
4421 #if defined(NEED_sv_2pv_nolen)
4422 static char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4425 extern char * DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv);
4429 # undef sv_2pv_nolen
4431 #define sv_2pv_nolen(a) DPPP_(my_sv_2pv_nolen)(aTHX_ a)
4432 #define Perl_sv_2pv_nolen DPPP_(my_sv_2pv_nolen)
4434 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
4437 DPPP_(my_sv_2pv_nolen)(pTHX_ register SV *sv)
4440 return sv_2pv(sv, &n_a);
4445 /* Hint: sv_2pv_nolen
4446 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
4449 /* SvPV_nolen depends on sv_2pv_nolen */
4450 #define SvPV_nolen(sv) \
4451 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
4452 ? SvPVX(sv) : sv_2pv_nolen(sv))
4459 * Does not work in perl-5.6.1, ppport.h implements a version
4460 * borrowed from perl-5.7.3.
4463 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
4465 #if defined(NEED_sv_2pvbyte)
4466 static char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4469 extern char * DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4475 #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b)
4476 #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte)
4478 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
4481 DPPP_(my_sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
4483 sv_utf8_downgrade(sv,0);
4484 return SvPV(sv,*lp);
4490 * Use the SvPVbyte() macro instead of sv_2pvbyte().
4495 /* SvPVbyte depends on sv_2pvbyte */
4496 #define SvPVbyte(sv, lp) \
4497 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
4498 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
4504 # define SvPVbyte SvPV
4505 # define sv_2pvbyte sv_2pv
4509 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
4510 #ifndef sv_2pvbyte_nolen
4511 # define sv_2pvbyte_nolen sv_2pv_nolen
4515 * Always use the SvPV() macro instead of sv_pvn().
4518 # define sv_pvn(sv, len) SvPV(sv, len)
4522 * Always use the SvPV_force() macro instead of sv_pvn_force().
4524 #ifndef sv_pvn_force
4525 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
4528 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(vnewSVpvf)
4529 #if defined(NEED_vnewSVpvf)
4530 static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4533 extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char * pat, va_list * args);
4539 #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b)
4540 #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf)
4542 #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL)
4545 DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args)
4547 register SV *sv = newSV(0);
4548 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4555 /* sv_vcatpvf depends on sv_vcatpvfn */
4556 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf)
4557 # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4560 /* sv_vsetpvf depends on sv_vsetpvfn */
4561 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf)
4562 # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
4565 /* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
4566 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg)
4567 #if defined(NEED_sv_catpvf_mg)
4568 static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4571 extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4574 #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg)
4576 #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL)
4579 DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4582 va_start(args, pat);
4583 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4591 /* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
4592 #ifdef PERL_IMPLICIT_CONTEXT
4593 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_catpvf_mg_nocontext)
4594 #if defined(NEED_sv_catpvf_mg_nocontext)
4595 static void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4598 extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4601 #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4602 #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext)
4604 #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL)
4607 DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4611 va_start(args, pat);
4612 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4621 #ifndef sv_catpvf_mg
4622 # ifdef PERL_IMPLICIT_CONTEXT
4623 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
4625 # define sv_catpvf_mg Perl_sv_catpvf_mg
4629 /* sv_vcatpvf_mg depends on sv_vcatpvfn */
4630 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vcatpvf_mg)
4631 # define sv_vcatpvf_mg(sv, pat, args) \
4633 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4638 /* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
4639 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg)
4640 #if defined(NEED_sv_setpvf_mg)
4641 static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4644 extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * sv, const char * pat, ...);
4647 #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg)
4649 #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL)
4652 DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...)
4655 va_start(args, pat);
4656 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4664 /* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
4665 #ifdef PERL_IMPLICIT_CONTEXT
4666 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_setpvf_mg_nocontext)
4667 #if defined(NEED_sv_setpvf_mg_nocontext)
4668 static void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4671 extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * sv, const char * pat, ...);
4674 #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4675 #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext)
4677 #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL)
4680 DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...)
4684 va_start(args, pat);
4685 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4694 #ifndef sv_setpvf_mg
4695 # ifdef PERL_IMPLICIT_CONTEXT
4696 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
4698 # define sv_setpvf_mg Perl_sv_setpvf_mg
4702 /* sv_vsetpvf_mg depends on sv_vsetpvfn */
4703 #if ((PERL_VERSION > 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION >= 0))) && !defined(sv_vsetpvf_mg)
4704 # define sv_vsetpvf_mg(sv, pat, args) \
4706 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
4711 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
4713 #ifndef PERL_MAGIC_sv
4714 # define PERL_MAGIC_sv '\0'
4717 #ifndef PERL_MAGIC_overload
4718 # define PERL_MAGIC_overload 'A'
4721 #ifndef PERL_MAGIC_overload_elem
4722 # define PERL_MAGIC_overload_elem 'a'
4725 #ifndef PERL_MAGIC_overload_table
4726 # define PERL_MAGIC_overload_table 'c'
4729 #ifndef PERL_MAGIC_bm
4730 # define PERL_MAGIC_bm 'B'
4733 #ifndef PERL_MAGIC_regdata
4734 # define PERL_MAGIC_regdata 'D'
4737 #ifndef PERL_MAGIC_regdatum
4738 # define PERL_MAGIC_regdatum 'd'
4741 #ifndef PERL_MAGIC_env
4742 # define PERL_MAGIC_env 'E'
4745 #ifndef PERL_MAGIC_envelem
4746 # define PERL_MAGIC_envelem 'e'
4749 #ifndef PERL_MAGIC_fm
4750 # define PERL_MAGIC_fm 'f'
4753 #ifndef PERL_MAGIC_regex_global
4754 # define PERL_MAGIC_regex_global 'g'
4757 #ifndef PERL_MAGIC_isa
4758 # define PERL_MAGIC_isa 'I'
4761 #ifndef PERL_MAGIC_isaelem
4762 # define PERL_MAGIC_isaelem 'i'
4765 #ifndef PERL_MAGIC_nkeys
4766 # define PERL_MAGIC_nkeys 'k'
4769 #ifndef PERL_MAGIC_dbfile
4770 # define PERL_MAGIC_dbfile 'L'
4773 #ifndef PERL_MAGIC_dbline
4774 # define PERL_MAGIC_dbline 'l'
4777 #ifndef PERL_MAGIC_mutex
4778 # define PERL_MAGIC_mutex 'm'
4781 #ifndef PERL_MAGIC_shared
4782 # define PERL_MAGIC_shared 'N'
4785 #ifndef PERL_MAGIC_shared_scalar
4786 # define PERL_MAGIC_shared_scalar 'n'
4789 #ifndef PERL_MAGIC_collxfrm
4790 # define PERL_MAGIC_collxfrm 'o'
4793 #ifndef PERL_MAGIC_tied
4794 # define PERL_MAGIC_tied 'P'
4797 #ifndef PERL_MAGIC_tiedelem
4798 # define PERL_MAGIC_tiedelem 'p'
4801 #ifndef PERL_MAGIC_tiedscalar
4802 # define PERL_MAGIC_tiedscalar 'q'
4805 #ifndef PERL_MAGIC_qr
4806 # define PERL_MAGIC_qr 'r'
4809 #ifndef PERL_MAGIC_sig
4810 # define PERL_MAGIC_sig 'S'
4813 #ifndef PERL_MAGIC_sigelem
4814 # define PERL_MAGIC_sigelem 's'
4817 #ifndef PERL_MAGIC_taint
4818 # define PERL_MAGIC_taint 't'
4821 #ifndef PERL_MAGIC_uvar
4822 # define PERL_MAGIC_uvar 'U'
4825 #ifndef PERL_MAGIC_uvar_elem
4826 # define PERL_MAGIC_uvar_elem 'u'
4829 #ifndef PERL_MAGIC_vstring
4830 # define PERL_MAGIC_vstring 'V'
4833 #ifndef PERL_MAGIC_vec
4834 # define PERL_MAGIC_vec 'v'
4837 #ifndef PERL_MAGIC_utf8
4838 # define PERL_MAGIC_utf8 'w'
4841 #ifndef PERL_MAGIC_substr
4842 # define PERL_MAGIC_substr 'x'
4845 #ifndef PERL_MAGIC_defelem
4846 # define PERL_MAGIC_defelem 'y'
4849 #ifndef PERL_MAGIC_glob
4850 # define PERL_MAGIC_glob '*'
4853 #ifndef PERL_MAGIC_arylen
4854 # define PERL_MAGIC_arylen '#'
4857 #ifndef PERL_MAGIC_pos
4858 # define PERL_MAGIC_pos '.'
4861 #ifndef PERL_MAGIC_backref
4862 # define PERL_MAGIC_backref '<'
4865 #ifndef PERL_MAGIC_ext
4866 # define PERL_MAGIC_ext '~'
4869 /* That's the best we can do... */
4870 #ifndef SvPV_force_nomg
4871 # define SvPV_force_nomg SvPV_force
4875 # define SvPV_nomg SvPV
4878 #ifndef sv_catpvn_nomg
4879 # define sv_catpvn_nomg sv_catpvn
4882 #ifndef sv_catsv_nomg
4883 # define sv_catsv_nomg sv_catsv
4886 #ifndef sv_setsv_nomg
4887 # define sv_setsv_nomg sv_setsv
4891 # define sv_pvn_nomg sv_pvn
4895 # define SvIV_nomg SvIV
4899 # define SvUV_nomg SvUV
4903 # define sv_catpv_mg(sv, ptr) \
4906 sv_catpv(TeMpSv,ptr); \
4907 SvSETMAGIC(TeMpSv); \
4911 #ifndef sv_catpvn_mg
4912 # define sv_catpvn_mg(sv, ptr, len) \
4915 sv_catpvn(TeMpSv,ptr,len); \
4916 SvSETMAGIC(TeMpSv); \
4921 # define sv_catsv_mg(dsv, ssv) \
4924 sv_catsv(TeMpSv,ssv); \
4925 SvSETMAGIC(TeMpSv); \
4930 # define sv_setiv_mg(sv, i) \
4933 sv_setiv(TeMpSv,i); \
4934 SvSETMAGIC(TeMpSv); \
4939 # define sv_setnv_mg(sv, num) \
4942 sv_setnv(TeMpSv,num); \
4943 SvSETMAGIC(TeMpSv); \
4948 # define sv_setpv_mg(sv, ptr) \
4951 sv_setpv(TeMpSv,ptr); \
4952 SvSETMAGIC(TeMpSv); \
4956 #ifndef sv_setpvn_mg
4957 # define sv_setpvn_mg(sv, ptr, len) \
4960 sv_setpvn(TeMpSv,ptr,len); \
4961 SvSETMAGIC(TeMpSv); \
4966 # define sv_setsv_mg(dsv, ssv) \
4969 sv_setsv(TeMpSv,ssv); \
4970 SvSETMAGIC(TeMpSv); \
4975 # define sv_setuv_mg(sv, i) \
4978 sv_setuv(TeMpSv,i); \
4979 SvSETMAGIC(TeMpSv); \
4983 #ifndef sv_usepvn_mg
4984 # define sv_usepvn_mg(sv, ptr, len) \
4987 sv_usepvn(TeMpSv,ptr,len); \
4988 SvSETMAGIC(TeMpSv); \
4994 # define CopFILE(c) ((c)->cop_file)
4998 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
5002 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
5006 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
5010 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
5014 # define CopSTASHPV(c) ((c)->cop_stashpv)
5017 #ifndef CopSTASHPV_set
5018 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
5022 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
5025 #ifndef CopSTASH_set
5026 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
5030 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
5031 || (CopSTASHPV(c) && HvNAME(hv) \
5032 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
5037 # define CopFILEGV(c) ((c)->cop_filegv)
5040 #ifndef CopFILEGV_set
5041 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
5045 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
5049 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
5053 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
5057 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
5061 # define CopSTASH(c) ((c)->cop_stash)
5064 #ifndef CopSTASH_set
5065 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
5069 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
5072 #ifndef CopSTASHPV_set
5073 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
5077 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
5080 #endif /* USE_ITHREADS */
5081 #ifndef IN_PERL_COMPILETIME
5082 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
5085 #ifndef IN_LOCALE_RUNTIME
5086 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
5089 #ifndef IN_LOCALE_COMPILETIME
5090 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
5094 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
5096 #ifndef IS_NUMBER_IN_UV
5097 # define IS_NUMBER_IN_UV 0x01
5100 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
5101 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
5104 #ifndef IS_NUMBER_NOT_INT
5105 # define IS_NUMBER_NOT_INT 0x04
5108 #ifndef IS_NUMBER_NEG
5109 # define IS_NUMBER_NEG 0x08
5112 #ifndef IS_NUMBER_INFINITY
5113 # define IS_NUMBER_INFINITY 0x10
5116 #ifndef IS_NUMBER_NAN
5117 # define IS_NUMBER_NAN 0x20
5120 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
5121 #ifndef GROK_NUMERIC_RADIX
5122 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
5124 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
5125 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
5128 #ifndef PERL_SCAN_SILENT_ILLDIGIT
5129 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
5132 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
5133 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
5136 #ifndef PERL_SCAN_DISALLOW_PREFIX
5137 # define PERL_SCAN_DISALLOW_PREFIX 0x02
5140 #ifndef grok_numeric_radix
5141 #if defined(NEED_grok_numeric_radix)
5142 static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5145 extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
5148 #ifdef grok_numeric_radix
5149 # undef grok_numeric_radix
5151 #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b)
5152 #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix)
5154 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
5156 DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send)
5158 #ifdef USE_LOCALE_NUMERIC
5159 #ifdef PL_numeric_radix_sv
5160 if (PL_numeric_radix_sv && IN_LOCALE) {
5162 char* radix = SvPV(PL_numeric_radix_sv, len);
5163 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5169 /* older perls don't have PL_numeric_radix_sv so the radix
5170 * must manually be requested from locale.h
5173 dTHR; /* needed for older threaded perls */
5174 struct lconv *lc = localeconv();
5175 char *radix = lc->decimal_point;
5176 if (radix && IN_LOCALE) {
5177 STRLEN len = strlen(radix);
5178 if (*sp + len <= send && memEQ(*sp, radix, len)) {
5183 #endif /* PERL_VERSION */
5184 #endif /* USE_LOCALE_NUMERIC */
5185 /* always try "." if numeric radix didn't match because
5186 * we may have data from different locales mixed */
5187 if (*sp < send && **sp == '.') {
5196 /* grok_number depends on grok_numeric_radix */
5199 #if defined(NEED_grok_number)
5200 static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5203 extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
5209 #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c)
5210 #define Perl_grok_number DPPP_(my_grok_number)
5212 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
5214 DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
5217 const char *send = pv + len;
5218 const UV max_div_10 = UV_MAX / 10;
5219 const char max_mod_10 = UV_MAX % 10;
5224 while (s < send && isSPACE(*s))
5228 } else if (*s == '-') {
5230 numtype = IS_NUMBER_NEG;
5238 /* next must be digit or the radix separator or beginning of infinity */
5240 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
5242 UV value = *s - '0';
5243 /* This construction seems to be more optimiser friendly.
5244 (without it gcc does the isDIGIT test and the *s - '0' separately)
5245 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
5246 In theory the optimiser could deduce how far to unroll the loop
5247 before checking for overflow. */
5249 int digit = *s - '0';
5250 if (digit >= 0 && digit <= 9) {
5251 value = value * 10 + digit;
5254 if (digit >= 0 && digit <= 9) {
5255 value = value * 10 + digit;
5258 if (digit >= 0 && digit <= 9) {
5259 value = value * 10 + digit;
5262 if (digit >= 0 && digit <= 9) {
5263 value = value * 10 + digit;
5266 if (digit >= 0 && digit <= 9) {
5267 value = value * 10 + digit;
5270 if (digit >= 0 && digit <= 9) {
5271 value = value * 10 + digit;
5274 if (digit >= 0 && digit <= 9) {
5275 value = value * 10 + digit;
5278 if (digit >= 0 && digit <= 9) {
5279 value = value * 10 + digit;
5281 /* Now got 9 digits, so need to check
5282 each time for overflow. */
5284 while (digit >= 0 && digit <= 9
5285 && (value < max_div_10
5286 || (value == max_div_10
5287 && digit <= max_mod_10))) {
5288 value = value * 10 + digit;
5294 if (digit >= 0 && digit <= 9
5296 /* value overflowed.
5297 skip the remaining digits, don't
5298 worry about setting *valuep. */
5301 } while (s < send && isDIGIT(*s));
5303 IS_NUMBER_GREATER_THAN_UV_MAX;
5323 numtype |= IS_NUMBER_IN_UV;
5328 if (GROK_NUMERIC_RADIX(&s, send)) {
5329 numtype |= IS_NUMBER_NOT_INT;
5330 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
5334 else if (GROK_NUMERIC_RADIX(&s, send)) {
5335 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
5336 /* no digits before the radix means we need digits after it */
5337 if (s < send && isDIGIT(*s)) {
5340 } while (s < send && isDIGIT(*s));
5342 /* integer approximation is valid - it's 0. */
5348 } else if (*s == 'I' || *s == 'i') {
5349 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5350 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
5351 s++; if (s < send && (*s == 'I' || *s == 'i')) {
5352 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5353 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
5354 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
5355 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
5359 } else if (*s == 'N' || *s == 'n') {
5360 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
5361 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
5362 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5369 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5370 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
5371 } else if (sawnan) {
5372 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5373 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
5374 } else if (s < send) {
5375 /* we can have an optional exponent part */
5376 if (*s == 'e' || *s == 'E') {
5377 /* The only flag we keep is sign. Blow away any "it's UV" */
5378 numtype &= IS_NUMBER_NEG;
5379 numtype |= IS_NUMBER_NOT_INT;
5381 if (s < send && (*s == '-' || *s == '+'))
5383 if (s < send && isDIGIT(*s)) {
5386 } while (s < send && isDIGIT(*s));
5392 while (s < send && isSPACE(*s))
5396 if (len == 10 && memEQ(pv, "0 but true", 10)) {
5399 return IS_NUMBER_IN_UV;
5407 * The grok_* routines have been modified to use warn() instead of
5408 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
5409 * which is why the stack variable has been renamed to 'xdigit'.
5413 #if defined(NEED_grok_bin)
5414 static UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5417 extern UV DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5423 #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d)
5424 #define Perl_grok_bin DPPP_(my_grok_bin)
5426 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
5428 DPPP_(my_grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5430 const char *s = start;
5431 STRLEN len = *len_p;
5435 const UV max_div_2 = UV_MAX / 2;
5436 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5437 bool overflowed = FALSE;
5439 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5440 /* strip off leading b or 0b.
5441 for compatibility silently suffer "b" and "0b" as valid binary
5448 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
5455 for (; len-- && *s; s++) {
5457 if (bit == '0' || bit == '1') {
5458 /* Write it in this wonky order with a goto to attempt to get the
5459 compiler to make the common case integer-only loop pretty tight.
5460 With gcc seems to be much straighter code than old scan_bin. */
5463 if (value <= max_div_2) {
5464 value = (value << 1) | (bit - '0');
5467 /* Bah. We're just overflowed. */
5468 warn("Integer overflow in binary number");
5470 value_nv = (NV) value;
5473 /* If an NV has not enough bits in its mantissa to
5474 * represent a UV this summing of small low-order numbers
5475 * is a waste of time (because the NV cannot preserve
5476 * the low-order bits anyway): we could just remember when
5477 * did we overflow and in the end just multiply value_nv by the
5479 value_nv += (NV)(bit - '0');
5482 if (bit == '_' && len && allow_underscores && (bit = s[1])
5483 && (bit == '0' || bit == '1'))
5489 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5490 warn("Illegal binary digit '%c' ignored", *s);
5494 if ( ( overflowed && value_nv > 4294967295.0)
5496 || (!overflowed && value > 0xffffffff )
5499 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
5506 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5515 #if defined(NEED_grok_hex)
5516 static UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5519 extern UV DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5525 #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d)
5526 #define Perl_grok_hex DPPP_(my_grok_hex)
5528 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
5530 DPPP_(my_grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5532 const char *s = start;
5533 STRLEN len = *len_p;
5537 const UV max_div_16 = UV_MAX / 16;
5538 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5539 bool overflowed = FALSE;
5542 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5543 /* strip off leading x or 0x.
5544 for compatibility silently suffer "x" and "0x" as valid hex numbers.
5551 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
5558 for (; len-- && *s; s++) {
5559 xdigit = strchr((char *) PL_hexdigit, *s);
5561 /* Write it in this wonky order with a goto to attempt to get the
5562 compiler to make the common case integer-only loop pretty tight.
5563 With gcc seems to be much straighter code than old scan_hex. */
5566 if (value <= max_div_16) {
5567 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
5570 warn("Integer overflow in hexadecimal number");
5572 value_nv = (NV) value;
5575 /* If an NV has not enough bits in its mantissa to
5576 * represent a UV this summing of small low-order numbers
5577 * is a waste of time (because the NV cannot preserve
5578 * the low-order bits anyway): we could just remember when
5579 * did we overflow and in the end just multiply value_nv by the
5580 * right amount of 16-tuples. */
5581 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
5584 if (*s == '_' && len && allow_underscores && s[1]
5585 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
5591 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5592 warn("Illegal hexadecimal digit '%c' ignored", *s);
5596 if ( ( overflowed && value_nv > 4294967295.0)
5598 || (!overflowed && value > 0xffffffff )
5601 warn("Hexadecimal number > 0xffffffff non-portable");
5608 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5617 #if defined(NEED_grok_oct)
5618 static UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5621 extern UV DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5627 #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d)
5628 #define Perl_grok_oct DPPP_(my_grok_oct)
5630 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
5632 DPPP_(my_grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5634 const char *s = start;
5635 STRLEN len = *len_p;
5639 const UV max_div_8 = UV_MAX / 8;
5640 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5641 bool overflowed = FALSE;
5643 for (; len-- && *s; s++) {
5644 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
5645 out front allows slicker code. */
5646 int digit = *s - '0';
5647 if (digit >= 0 && digit <= 7) {
5648 /* Write it in this wonky order with a goto to attempt to get the
5649 compiler to make the common case integer-only loop pretty tight.
5653 if (value <= max_div_8) {
5654 value = (value << 3) | digit;
5657 /* Bah. We're just overflowed. */
5658 warn("Integer overflow in octal number");
5660 value_nv = (NV) value;
5663 /* If an NV has not enough bits in its mantissa to
5664 * represent a UV this summing of small low-order numbers
5665 * is a waste of time (because the NV cannot preserve
5666 * the low-order bits anyway): we could just remember when
5667 * did we overflow and in the end just multiply value_nv by the
5668 * right amount of 8-tuples. */
5669 value_nv += (NV)digit;
5672 if (digit == ('_' - '0') && len && allow_underscores
5673 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
5679 /* Allow \octal to work the DWIM way (that is, stop scanning
5680 * as soon as non-octal characters are seen, complain only iff
5681 * someone seems to want to use the digits eight and nine). */
5682 if (digit == 8 || digit == 9) {
5683 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5684 warn("Illegal octal digit '%c' ignored", *s);
5689 if ( ( overflowed && value_nv > 4294967295.0)
5691 || (!overflowed && value > 0xffffffff )
5694 warn("Octal number > 037777777777 non-portable");
5701 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5709 #endif /* _P_P_PORTABILITY_H_ */
5711 /* End of File ppport.h */
projects / p5sagit/p5-mst-13.2.git / blob