1 ################################################################################
3 # !!!!! Do NOT edit this file directly! -- Edit PPPort_pm.PL instead. !!!!!
5 ################################################################################
7 # Perl/Pollution/Portability
9 ################################################################################
13 # $Date: 2004/08/13 12:49:22 +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:
161 IN_LOCALE_COMPILETIME
165 IS_NUMBER_GREATER_THAN_UV_MAX
220 PERL_MAGIC_overload_elem
221 PERL_MAGIC_overload_table
226 PERL_MAGIC_regex_global
228 PERL_MAGIC_shared_scalar
236 PERL_MAGIC_tiedscalar
245 PERL_SCAN_ALLOW_UNDERSCORES
246 PERL_SCAN_DISALLOW_PREFIX
247 PERL_SCAN_GREATER_THAN_UV_MAX
248 PERL_SCAN_SILENT_ILLDIGIT
340 =head2 Perl API not supported by ppport.h
342 There is still a big part of the API not supported by F<ppport.h>.
343 Either because it doesn't make sense to back-port that part of the API,
344 or simply because it hasn't been implemented yet. Patches welcome!
346 Here's a list of the currently unsupported API, and also the version of
347 Perl below which it is unsupported:
360 hv_clear_placeholders
436 gv_fetchmeth_autoload
485 sv_utf8_upgrade_flags
503 sv_force_normal_flags
524 utf16_to_utf8_reversed
766 gv_fetchmethod_autoload
803 If you find any bugs, C<Devel::PPPort> doesn't seem to build on your
804 system or any of its tests fail, please use the CPAN Request Tracker
805 at L<http://rt.cpan.org/> to create a ticket for the module.
813 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
817 Version 2.x was ported to the Perl core by Paul Marquess.
821 Version 3.x was ported back to CPAN by Marcus Holland-Moritz.
827 Version 3.x, Copyright (C) 2004, Marcus Holland-Moritz.
829 Version 2.x, Copyright (C) 2001, Paul Marquess.
831 Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
833 This program is free software; you can redistribute it and/or
834 modify it under the same terms as Perl itself.
838 See L<h2xs>, L<ppport.h>.
842 package Devel::PPPort;
846 use vars qw($VERSION @ISA $data);
848 $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.00 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
850 @ISA = qw(DynaLoader);
852 bootstrap Devel::PPPort;
855 $data = do { local $/; <DATA> };
857 my $pkg = 'Devel::PPPort';
858 $data =~ s/__PERL_VERSION__/$]/g;
859 $data =~ s/__VERSION__/$VERSION/g;
860 $data =~ s/__DATE__/$now/g;
861 $data =~ s/__PKG__/$pkg/g;
862 $data =~ s/^POD\s//gm;
867 my $file = shift || 'ppport.h';
869 $copy =~ s/\bppport\.h\b/$file/g;
871 open F, ">$file" or return undef;
885 ----------------------------------------------------------------------
887 ppport.h -- Perl/Pollution/Portability Version __VERSION__
889 Automatically created by __PKG__ running under
890 perl __PERL_VERSION__ on __DATE__.
892 Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
893 includes in parts/inc/ instead.
895 Use 'perldoc ppport.h' to view the documentation below.
897 ----------------------------------------------------------------------
905 POD ppport.h - Perl/Pollution/Portability version __VERSION__
909 POD perl ppport.h [options] [files]
911 POD --help show short help
913 POD --patch=file write one patch file with changes
914 POD --copy=suffix write changed copies with suffix
915 POD --diff=program use diff program and options
917 POD --compat-version=version provide compatibility with Perl version
918 POD --cplusplus accept C++ comments
920 POD --quiet don't output anything except fatal errors
921 POD --nodiag don't show diagnostics
922 POD --nohints don't show hints
923 POD --nochanges don't suggest changes
925 POD --list-provided list provided API
926 POD --list-unsupported list unsupported API
928 POD =head1 COMPATIBILITY
930 POD This version of F<ppport.h> is designed to support operation with Perl
931 POD installations back to 5.003, and has been tested up to 5.9.2.
937 POD Display a brief usage summary.
939 POD =head2 --patch=I<file>
941 POD If this option is given, a single patch file will be created if
942 POD any changes are suggested. This requires a working diff program
943 POD to be installed on your system.
945 POD =head2 --copy=I<suffix>
947 POD If this option is given, a copy of each file will be saved with
948 POD the given suffix that contains the suggested changes. This does
949 POD not require any external programs.
951 POD If neither C<--patch> or C<--copy> are given, the default is to
952 POD simply print the diffs for each file. This requires either
953 POD C<Text::Diff> or a C<diff> program to be installed.
955 POD =head2 --diff=I<program>
957 POD Manually set the diff program and options to use. The default
958 POD is to use C<Text::Diff>, when installed, and output unified
961 POD =head2 --compat-version=I<version>
963 POD Tell F<ppport.h> to check for compatibility with the given
964 POD Perl version. The default is to check for compatibility with Perl
965 POD version 5.003. You can use this option to reduce the output
966 POD of F<ppport.h> if you intend to be backward compatible only
967 POD up to a certain Perl version.
969 POD =head2 --cplusplus
971 POD Usually, F<ppport.h> will detect C++ style comments and
972 POD replace them with C style comments for portability reasons.
973 POD Using this option instructs F<ppport.h> to leave C++
974 POD comments untouched.
978 POD Be quiet. Don't print anything except fatal errors.
982 POD Don't output any diagnostic messages. Only portability
983 POD alerts will be printed.
987 POD Don't output any hints. Hints often contain useful portability
990 POD =head2 --nochanges
992 POD Don't suggest any changes. Only give diagnostic output and hints
993 POD unless these are also deactivated.
995 POD =head2 --list-provided
997 POD Lists the API elements for which compatibility is provided by
998 POD F<ppport.h>. Also lists if it must be explicitly requested,
999 POD if it has dependencies, and if there are hints for it.
1001 POD =head2 --list-unsupported
1003 POD Lists the API elements that are known not to be supported by
1004 POD F<ppport.h> and below which version of Perl they probably
1005 POD won't be available or work.
1007 POD =head1 DESCRIPTION
1009 POD In order for a Perl extension (XS) module to be as portable as possible
1010 POD across differing versions of Perl itself, certain steps need to be taken.
1016 POD Including this header is the first major one. This alone will give you
1017 POD access to a large part of the Perl API that hasn't been available in
1018 POD earlier Perl releases. Use
1020 POD perl ppport.h --list-provided
1022 POD to see which API elements are provided by ppport.h.
1026 POD You should avoid using deprecated parts of the API. For example, using
1027 POD global Perl variables without the C<PL_> prefix is deprecated. Also,
1028 POD some API functions used to have a C<perl_> prefix. Using this form is
1029 POD also deprecated. You can safely use the supported API, as F<ppport.h>
1030 POD will provide wrappers for older Perl versions.
1034 POD If you use one of a few functions that were not present in earlier
1035 POD versions of Perl, and that can't be provided using a macro, you have
1036 POD to explicitly request support for these functions by adding one or
1037 POD more C<#define>s in your source code before the inclusion of F<ppport.h>.
1039 POD These functions will be marked C<explicit> in the list shown by
1040 POD C<--list-provided>.
1042 POD Depending on whether you module has a single or multiple files that
1043 POD use such functions, you want either C<static> or global variants.
1045 POD For a C<static> function, use:
1047 POD #define NEED_function
1049 POD For a global function, use:
1051 POD #define NEED_function_GLOBAL
1053 POD Note that you mustn't have more than one global request for one
1054 POD function in your project.
1056 POD Function Static Request Global Request
1057 POD -----------------------------------------------------------------------------
1058 POD eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL
1059 POD grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL
1060 POD grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL
1061 POD grok_number() NEED_grok_number NEED_grok_number_GLOBAL
1062 POD grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL
1063 POD grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL
1064 POD newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
1065 POD newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL
1066 POD sv_2pv_nolen() NEED_sv_2pv_nolen NEED_sv_2pv_nolen_GLOBAL
1067 POD sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL
1069 POD To avoid namespace conflicts, you can change the namespace of the
1070 POD explicitly exported functions using the C<DPPP_NAMESPACE> macro.
1071 POD Just C<#define> the macro before including C<ppport.h>:
1073 POD #define DPPP_NAMESPACE MyOwnNamespace_
1074 POD #include "ppport.h"
1076 POD The default namespace is C<DPPP_>.
1080 POD The good thing is that most of the above can be checked by running
1081 POD F<ppport.h> on your source code. See the next section for
1086 POD To verify whether F<ppport.h> is needed for your module, whether you
1087 POD should make any changes to your code, and whether any special defines
1088 POD should be used, F<ppport.h> can be run as a Perl script to check your
1089 POD source code. Simply say:
1093 POD The result will usually be a list of patches suggesting changes
1094 POD that should at least be acceptable, if not necessarily the most
1095 POD efficient solution, or a fix for all possible problems.
1097 POD If you know that your XS module uses features only available in
1098 POD newer Perl releases, if you're aware that it uses C++ comments,
1099 POD and if you want all suggestions as a single patch file, you could
1100 POD use something like this:
1102 POD perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
1104 POD If you only want your code to be scanned without any suggestions
1105 POD for changes, use:
1107 POD perl ppport.h --nochanges
1109 POD You can specify a different C<diff> program or options, using
1110 POD the C<--diff> option:
1112 POD perl ppport.h --diff='diff -C 10'
1114 POD This would output context diffs with 10 lines of context.
1118 POD If this version of F<ppport.h> is causing failure during
1119 POD the compilation of this module, please check if newer versions
1120 POD of either this module or C<Devel::PPPort> are available on CPAN
1121 POD before sending a bug report.
1123 POD If F<ppport.h> was generated using the latest version of
1124 POD C<Devel::PPPort> and is causing failure of this module, please
1125 POD file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
1127 POD Please include the following information:
1133 POD The complete output from running "perl -V"
1141 POD The name and version of the module you were trying to build.
1145 POD A full log of the build that failed.
1149 POD Any other information that you think could be relevant.
1153 POD For the latest version of this code, please get the C<Devel::PPPort>
1154 POD module from CPAN.
1156 POD =head1 COPYRIGHT
1158 POD Version 3.x, Copyright (c) 2004, Marcus Holland-Moritz.
1160 POD Version 2.x, Copyright (C) 2001, Paul Marquess.
1162 POD Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
1164 POD This program is free software; you can redistribute it and/or
1165 POD modify it under the same terms as Perl itself.
1169 POD See L<Devel::PPPort>.
1183 my($ppport) = $0 =~ /([\w.]+)$/;
1184 my $LF = '(?:\r\n|[\r\n])'; # line feed
1185 my $HS = "[ \t]"; # horizontal whitespace
1188 require Getopt::Long;
1189 Getopt::Long::GetOptions(\%opt, qw(
1190 help quiet diag! hints! changes! cplusplus
1191 patch=s copy=s diff=s compat-version=s
1192 list-provided list-unsupported
1196 if ($@ and grep /^-/, @ARGV) {
1197 usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
1198 die "Getopt::Long not found. Please don't use any options.\n";
1201 usage() if $opt{help};
1203 if (exists $opt{'compat-version'}) {
1204 my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
1206 die "Invalid version number format: '$opt{'compat-version'}'\n";
1208 die "Only Perl 5 is supported\n" if $r != 5;
1209 die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $v >= 1000;
1210 $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
1213 $opt{'compat-version'} = 5;
1216 # Never use C comments in this file!!!!!
1219 my $rccs = quotemeta $ccs;
1220 my $rcce = quotemeta $cce;
1225 @files = map { glob $_ } @ARGV;
1230 File::Find::find(sub {
1231 $File::Find::name =~ /\.(xs|c|h|cc)$/i
1232 and push @files, $File::Find::name;
1236 @files = map { glob $_ } qw(*.xs *.c *.h *.cc);
1238 my %filter = map { /(.*)\.xs$/ ? ("$1.c" => 1) : () } @files;
1239 @files = grep { !/\b\Q$ppport\E$/i && !exists $filter{$_} } @files;
1243 die "No input files given!\n";
1246 my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
1248 ($2 ? ( base => $2 ) : ()),
1249 ($3 ? ( todo => $3 ) : ()),
1250 (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
1251 (index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
1252 (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
1254 : die "invalid spec: $_" } qw(
1260 CopFILEAV|5.006000||p
1261 CopFILEGV_set|5.006000||p
1262 CopFILEGV|5.006000||p
1263 CopFILESV|5.006000||p
1264 CopFILE_set|5.006000||p
1266 CopSTASHPV_set|5.006000||p
1267 CopSTASHPV|5.006000||p
1268 CopSTASH_eq|5.006000||p
1269 CopSTASH_set|5.006000||p
1270 CopSTASH|5.006000||p
1283 GROK_NUMERIC_RADIX|5.007002||p
1293 HEf_SVKEY||5.004000|
1298 HeSVKEY_force||5.004000|
1299 HeSVKEY_set||5.004000|
1304 IN_LOCALE_COMPILETIME|5.007002||p
1305 IN_LOCALE_RUNTIME|5.007002||p
1306 IN_LOCALE|5.007002||p
1307 IN_PERL_COMPILETIME|5.008001||p
1308 IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p
1309 IS_NUMBER_INFINITY|5.007002||p
1310 IS_NUMBER_IN_UV|5.007002||p
1311 IS_NUMBER_NAN|5.007003||p
1312 IS_NUMBER_NEG|5.007002||p
1313 IS_NUMBER_NOT_INT|5.007002||p
1320 MY_CXT_INIT|5.007003||p
1342 PAD_COMPNAME_FLAGS|||
1344 PAD_COMPNAME_OURSTASH|||
1346 PAD_COMPNAME_TYPE|||
1347 PAD_RESTORE_LOCAL|||
1349 PAD_SAVE_SETNULLPAD|||
1351 PAD_SET_CUR_NOSAVE|||
1355 PERL_BCDVERSION|5.009002||p
1356 PERL_INT_MAX|5.004000||p
1357 PERL_INT_MIN|5.004000||p
1358 PERL_LONG_MAX|5.004000||p
1359 PERL_LONG_MIN|5.004000||p
1360 PERL_MAGIC_arylen|5.007002||p
1361 PERL_MAGIC_backref|5.007002||p
1362 PERL_MAGIC_bm|5.007002||p
1363 PERL_MAGIC_collxfrm|5.007002||p
1364 PERL_MAGIC_dbfile|5.007002||p
1365 PERL_MAGIC_dbline|5.007002||p
1366 PERL_MAGIC_defelem|5.007002||p
1367 PERL_MAGIC_envelem|5.007002||p
1368 PERL_MAGIC_env|5.007002||p
1369 PERL_MAGIC_ext|5.007002||p
1370 PERL_MAGIC_fm|5.007002||p
1371 PERL_MAGIC_glob|5.007002||p
1372 PERL_MAGIC_isaelem|5.007002||p
1373 PERL_MAGIC_isa|5.007002||p
1374 PERL_MAGIC_mutex|5.007002||p
1375 PERL_MAGIC_nkeys|5.007002||p
1376 PERL_MAGIC_overload_elem|5.007002||p
1377 PERL_MAGIC_overload_table|5.007002||p
1378 PERL_MAGIC_overload|5.007002||p
1379 PERL_MAGIC_pos|5.007002||p
1380 PERL_MAGIC_qr|5.007002||p
1381 PERL_MAGIC_regdata|5.007002||p
1382 PERL_MAGIC_regdatum|5.007002||p
1383 PERL_MAGIC_regex_global|5.007002||p
1384 PERL_MAGIC_shared_scalar|5.007003||p
1385 PERL_MAGIC_shared|5.007003||p
1386 PERL_MAGIC_sigelem|5.007002||p
1387 PERL_MAGIC_sig|5.007002||p
1388 PERL_MAGIC_substr|5.007002||p
1389 PERL_MAGIC_sv|5.007002||p
1390 PERL_MAGIC_taint|5.007002||p
1391 PERL_MAGIC_tiedelem|5.007002||p
1392 PERL_MAGIC_tiedscalar|5.007002||p
1393 PERL_MAGIC_tied|5.007002||p
1394 PERL_MAGIC_utf8|5.008001||p
1395 PERL_MAGIC_uvar_elem|5.007003||p
1396 PERL_MAGIC_uvar|5.007002||p
1397 PERL_MAGIC_vec|5.007002||p
1398 PERL_MAGIC_vstring|5.008001||p
1399 PERL_QUAD_MAX|5.004000||p
1400 PERL_QUAD_MIN|5.004000||p
1401 PERL_REVISION|5.006000||p
1402 PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p
1403 PERL_SCAN_DISALLOW_PREFIX|5.007003||p
1404 PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p
1405 PERL_SCAN_SILENT_ILLDIGIT|5.008001||p
1406 PERL_SHORT_MAX|5.004000||p
1407 PERL_SHORT_MIN|5.004000||p
1408 PERL_SUBVERSION|5.006000||p
1409 PERL_UCHAR_MAX|5.004000||p
1410 PERL_UCHAR_MIN|5.004000||p
1411 PERL_UINT_MAX|5.004000||p
1412 PERL_UINT_MIN|5.004000||p
1413 PERL_ULONG_MAX|5.004000||p
1414 PERL_ULONG_MIN|5.004000||p
1415 PERL_UNUSED_DECL|5.007002||p
1416 PERL_UQUAD_MAX|5.004000||p
1417 PERL_UQUAD_MIN|5.004000||p
1418 PERL_USHORT_MAX|5.004000||p
1419 PERL_USHORT_MIN|5.004000||p
1420 PERL_VERSION|5.006000||p
1425 PL_compiling|5.004050||p
1426 PL_copline|5.005000||p
1427 PL_curcop|5.004050||p
1428 PL_curstash|5.004050||p
1429 PL_defgv|5.004050||p
1430 PL_dirty|5.004050||p
1432 PL_hexdigit|5.005000||p
1433 PL_hints|5.005000||p
1435 PL_modglobal||5.005000|n
1438 PL_perldb|5.004050||p
1439 PL_rsfp_filters|5.004050||p
1443 PL_stdingv|5.004050||p
1444 PL_sv_no|5.004050||pn
1445 PL_sv_undef|5.004050||pn
1446 PL_sv_yes|5.004050||pn
1450 POPpbytex||5.007001|n
1461 PUSHmortal|5.009002||p
1467 PerlIO_clearerr||5.007003|
1468 PerlIO_close||5.007003|
1469 PerlIO_eof||5.007003|
1470 PerlIO_error||5.007003|
1471 PerlIO_fileno||5.007003|
1472 PerlIO_fill||5.007003|
1473 PerlIO_flush||5.007003|
1474 PerlIO_get_base||5.007003|
1475 PerlIO_get_bufsiz||5.007003|
1476 PerlIO_get_cnt||5.007003|
1477 PerlIO_get_ptr||5.007003|
1478 PerlIO_read||5.007003|
1479 PerlIO_seek||5.007003|
1480 PerlIO_set_cnt||5.007003|
1481 PerlIO_set_ptrcnt||5.007003|
1482 PerlIO_setlinebuf||5.007003|
1483 PerlIO_stderr||5.007003|
1484 PerlIO_stdin||5.007003|
1485 PerlIO_stdout||5.007003|
1486 PerlIO_tell||5.007003|
1487 PerlIO_unread||5.007003|
1488 PerlIO_write||5.007003|
1497 SAVE_DEFSV|5.004050||p
1500 START_MY_CXT|5.007003||p
1516 SvGETMAGIC|5.004050||p
1519 SvIOK_notUV||5.006000|
1521 SvIOK_only_UV||5.006000|
1527 SvIV_nomg|5.009001||p
1530 SvIsCOW_shared_hash||5.008003|
1548 SvPOK_only_UTF8||5.006000|
1554 SvPV_force_nomg|5.007002||p
1556 SvPV_nolen|5.006000||p
1557 SvPV_nomg|5.007002||p
1558 SvPVbyte_force||5.009002|
1559 SvPVbyte_nolen||5.006000|
1560 SvPVbytex_force||5.006000|
1561 SvPVbytex||5.006000|
1562 SvPVbyte|5.006000||p
1563 SvPVutf8_force||5.006000|
1564 SvPVutf8_nolen||5.006000|
1565 SvPVutf8x_force||5.006000|
1566 SvPVutf8x||5.006000|
1580 SvSetMagicSV_nosteal||5.004000|
1581 SvSetMagicSV||5.004000|
1582 SvSetSV_nosteal||5.004000|
1584 SvTAINTED_off||5.004000|
1585 SvTAINTED_on||5.004000|
1586 SvTAINTED||5.004000|
1593 SvUTF8_off||5.006000|
1594 SvUTF8_on||5.006000|
1598 SvUV_nomg|5.009001||p
1603 UNDERBAR|5.009002||p
1611 XPUSHmortal|5.009002||p
1622 XSRETURN_UV|5.008001||p
1632 XS_VERSION_BOOTCHECK|||
1637 _aMY_CXT|5.007003||p
1638 _pMY_CXT|5.007003||p
1639 aMY_CXT_|5.007003||p
1651 apply_attrs_string||5.006001|
1656 atfork_lock||5.007003|n
1657 atfork_unlock||5.007003|n
1659 av_delete||5.006000|
1660 av_exists||5.006000|
1678 block_gimme||5.004000|
1682 boot_core_UNIVERSAL|||
1683 boot_core_xsutils|||
1684 bytes_from_utf8||5.007001|
1685 bytes_to_utf8||5.006001|
1687 call_argv|5.006000||p
1688 call_atexit||5.006000|
1691 call_list||5.004000|
1692 call_method|5.006000||p
1699 cast_ulong||5.006000|
1714 croak_nocontext|||vn
1716 csighandler||5.007001|n
1717 custom_op_desc||5.007003|
1718 custom_op_name||5.007003|
1721 cv_const_sv||5.004000|
1730 dMY_CXT_SV|5.007003||p
1739 dUNDERBAR|5.009002||p
1747 debprofdump||5.005000|
1749 debstackptrs||5.007003|
1771 despatch_signals||5.007001|
1781 do_binmode||5.004050|
1790 do_gv_dump||5.006000|
1791 do_gvgv_dump||5.006000|
1792 do_hv_dump||5.006000|
1797 do_magic_dump||5.006000|
1801 do_op_dump||5.006000|
1806 do_pmop_dump||5.006000|
1815 do_sv_dump||5.006000|
1818 do_trans_complex_utf8|||
1820 do_trans_count_utf8|||
1822 do_trans_simple_utf8|||
1835 doing_taint||5.008001|n
1847 dump_eval||5.006000|
1849 dump_form||5.006000|
1850 dump_indent||5.006000|v
1852 dump_packsubs||5.006000|
1854 dump_vindent||5.006000|
1861 fbm_compile||5.005000|
1862 fbm_instr||5.005000|
1872 find_rundefsvoffset||5.009002|
1885 fprintf_nocontext|||vn
1886 free_tied_hv_pool|||
1888 gen_constant_list|||
1890 get_context||5.006000|n
1899 get_op_descs||5.005000|
1900 get_op_names||5.005000|
1902 get_ppaddr||5.006000|
1905 getcwd_sv||5.007002|
1910 grok_bin|5.007003||p
1911 grok_hex|5.007003||p
1912 grok_number|5.007002||p
1913 grok_numeric_radix|5.007002||p
1914 grok_oct|5.007003||p
1919 gv_autoload4||5.004000|
1922 gv_efullname3||5.004000|
1923 gv_efullname4||5.006001|
1927 gv_fetchmeth_autoload||5.007003|
1928 gv_fetchmethod_autoload||5.004000|
1932 gv_fullname3||5.004000|
1933 gv_fullname4||5.006001|
1935 gv_handler||5.007001|
1939 gv_stashpvn|5.006000||p
1945 hv_assert||5.009001|
1946 hv_clear_placeholders||5.009001|
1948 hv_delayfree_ent||5.004000|
1950 hv_delete_ent||5.004000|
1952 hv_exists_ent||5.004000|
1955 hv_fetch_ent||5.004000|
1957 hv_free_ent||5.004000|
1959 hv_iterkeysv||5.004000|
1961 hv_iternext_flags||5.008000|
1965 hv_ksplit||5.004000|
1969 hv_scalar||5.009001|
1970 hv_store_ent||5.004000|
1971 hv_store_flags||5.008000|
1974 ibcmp_locale||5.004000|
1975 ibcmp_utf8||5.007003|
1981 init_argv_symbols|||
1983 init_i18nl10n||5.006000|
1984 init_i18nl14n||5.006000|
1990 init_postdump_symbols|||
1991 init_predump_symbols|||
1992 init_stacks||5.005000|
2008 is_handle_constructor|||
2009 is_lvalue_sub||5.007001|
2010 is_uni_alnum_lc||5.006000|
2011 is_uni_alnumc_lc||5.006000|
2012 is_uni_alnumc||5.006000|
2013 is_uni_alnum||5.006000|
2014 is_uni_alpha_lc||5.006000|
2015 is_uni_alpha||5.006000|
2016 is_uni_ascii_lc||5.006000|
2017 is_uni_ascii||5.006000|
2018 is_uni_cntrl_lc||5.006000|
2019 is_uni_cntrl||5.006000|
2020 is_uni_digit_lc||5.006000|
2021 is_uni_digit||5.006000|
2022 is_uni_graph_lc||5.006000|
2023 is_uni_graph||5.006000|
2024 is_uni_idfirst_lc||5.006000|
2025 is_uni_idfirst||5.006000|
2026 is_uni_lower_lc||5.006000|
2027 is_uni_lower||5.006000|
2028 is_uni_print_lc||5.006000|
2029 is_uni_print||5.006000|
2030 is_uni_punct_lc||5.006000|
2031 is_uni_punct||5.006000|
2032 is_uni_space_lc||5.006000|
2033 is_uni_space||5.006000|
2034 is_uni_upper_lc||5.006000|
2035 is_uni_upper||5.006000|
2036 is_uni_xdigit_lc||5.006000|
2037 is_uni_xdigit||5.006000|
2038 is_utf8_alnumc||5.006000|
2039 is_utf8_alnum||5.006000|
2040 is_utf8_alpha||5.006000|
2041 is_utf8_ascii||5.006000|
2042 is_utf8_char||5.006000|
2043 is_utf8_cntrl||5.006000|
2044 is_utf8_digit||5.006000|
2045 is_utf8_graph||5.006000|
2046 is_utf8_idcont||5.008000|
2047 is_utf8_idfirst||5.006000|
2048 is_utf8_lower||5.006000|
2049 is_utf8_mark||5.006000|
2050 is_utf8_print||5.006000|
2051 is_utf8_punct||5.006000|
2052 is_utf8_space||5.006000|
2053 is_utf8_string_loc||5.008001|
2054 is_utf8_string||5.006001|
2055 is_utf8_upper||5.006000|
2056 is_utf8_xdigit||5.006000|
2069 load_module_nocontext|||vn
2070 load_module||5.006000|v
2072 looks_like_number|||
2082 magic_clear_all_env|||
2086 magic_dump||5.006000|
2102 magic_killbackrefs|||
2107 magic_regdata_cnt|||
2108 magic_regdatum_get|||
2109 magic_regdatum_set|||
2111 magic_set_all_env|||
2115 magic_setcollxfrm|||
2155 mg_length||5.005000|
2159 mini_mktime||5.007002|
2161 mode_from_discipline|||
2195 my_failure_exit||5.004000|
2196 my_fflush_all||5.006000|
2219 my_memcmp||5.004000|n
2222 my_pclose||5.004000|
2223 my_popen_list||5.007001|
2226 my_socketpair||5.007003|n
2228 my_strftime||5.007002|
2233 newANONATTRSUB||5.006000|
2238 newATTRSUB||5.006000|
2243 newCONSTSUB|5.006000||p
2267 newRV_inc|5.004000||p
2268 newRV_noinc|5.006000||p
2277 newSVpvf_nocontext|||vn
2278 newSVpvf||5.004000|v
2279 newSVpvn_share||5.007001|
2280 newSVpvn|5.006000||p
2287 newWHILEOP||5.004040|
2288 newXSproto||5.006000|
2290 new_collate||5.006000|
2292 new_ctype||5.006000|
2295 new_numeric||5.006000|
2296 new_stackinfo||5.005000|
2297 new_version||5.009000|
2314 no_bareword_allowed|||
2318 nothreadhook||5.008000|
2330 pMY_CXT_|5.007003||p
2345 pad_fixup_inner_anons|||
2357 parse_unicode_opts|||
2361 perl_alloc_using|||n
2363 perl_clone_using|||n
2366 perl_destruct||5.007003|n
2368 perl_parse||5.006000|n
2372 pmop_dump||5.006000|
2380 printf_nocontext|||vn
2389 pv_display||5.006000|
2390 pv_uni_display||5.007003|
2394 re_intuit_start||5.006000|
2395 re_intuit_string||5.006000|
2399 reentrant_retry|||vn
2408 regclass_swash||5.007003|
2415 regexec_flags||5.005000|
2421 reginitcolors||5.006000|
2440 require_pv||5.006000|
2444 rsignal_state||5.004000|
2447 runops_debug||5.005000|
2448 runops_standard||5.005000|
2452 safesyscalloc||5.006000|n
2453 safesysfree||5.006000|n
2454 safesysmalloc||5.006000|n
2455 safesysrealloc||5.006000|n
2460 save_aelem||5.004050|
2461 save_alloc||5.006000|
2464 save_bool||5.008001|
2467 save_destructor_x||5.006000|
2468 save_destructor||5.006000|
2472 save_generic_pvref||5.006001|
2473 save_generic_svref||5.005030|
2477 save_helem||5.004050|
2478 save_hints||5.005000|
2487 save_mortalizesv||5.007001|
2490 save_padsv||5.007001|
2492 save_re_context||5.006000|
2495 save_set_svflags||5.009000|
2496 save_shared_pvref||5.007003|
2499 save_threadsv||5.005000|
2500 save_vptr||5.006000|
2503 savesharedpv||5.007003|
2504 savestack_grow_cnt||5.008001|
2527 scan_version||5.009001|
2528 scan_vstring||5.008001|
2531 screaminstr||5.005000|
2533 set_context||5.006000|n
2535 set_numeric_local||5.006000|
2536 set_numeric_radix||5.006000|
2537 set_numeric_standard||5.006000|
2550 start_subparse||5.004000|
2558 str_to_version||5.006000|
2569 sv_2iuv_non_preserve|||
2570 sv_2iv_flags||5.009001|
2574 sv_2pv_flags||5.007002|
2575 sv_2pv_nolen|5.006000||p
2577 sv_2pvbyte|5.006000||p
2578 sv_2pvutf8_nolen||5.006000|
2579 sv_2pvutf8||5.006000|
2581 sv_2uv_flags||5.009001|
2587 sv_cat_decode||5.008001|
2588 sv_catpv_mg|5.006000||p
2589 sv_catpvf_mg_nocontext|||vn
2590 sv_catpvf_mg||5.004050|v
2591 sv_catpvf_nocontext|||vn
2592 sv_catpvf||5.004000|v
2593 sv_catpvn_flags||5.007002|
2594 sv_catpvn_mg|5.006000||p
2595 sv_catpvn_nomg|5.007002||p
2598 sv_catsv_flags||5.007002|
2599 sv_catsv_mg|5.006000||p
2600 sv_catsv_nomg|5.007002||p
2606 sv_cmp_locale||5.004000|
2609 sv_compile_2op||5.008001|
2610 sv_copypv||5.007003|
2613 sv_derived_from||5.004000|
2617 sv_force_normal_flags||5.007001|
2618 sv_force_normal||5.006000|
2629 sv_len_utf8||5.006000|
2631 sv_magicext||5.007003|
2636 sv_nolocking||5.007003|
2637 sv_nosharing||5.007003|
2638 sv_nounlocking||5.007003|
2641 sv_pos_b2u||5.006000|
2642 sv_pos_u2b||5.006000|
2643 sv_pvbyten_force||5.006000|
2644 sv_pvbyten||5.006000|
2645 sv_pvbyte||5.006000|
2646 sv_pvn_force_flags||5.007002|
2648 sv_pvn_nomg|5.007003||p
2650 sv_pvutf8n_force||5.006000|
2651 sv_pvutf8n||5.006000|
2652 sv_pvutf8||5.006000|
2654 sv_recode_to_utf8||5.007003|
2661 sv_rvweaken||5.006000|
2662 sv_setiv_mg|5.006000||p
2664 sv_setnv_mg|5.006000||p
2666 sv_setpv_mg|5.006000||p
2667 sv_setpvf_mg_nocontext|||vn
2668 sv_setpvf_mg||5.004050|v
2669 sv_setpvf_nocontext|||vn
2670 sv_setpvf||5.004000|v
2671 sv_setpviv_mg||5.008001|
2672 sv_setpviv||5.008001|
2673 sv_setpvn_mg|5.006000||p
2680 sv_setref_uv||5.007001|
2682 sv_setsv_flags||5.007002|
2683 sv_setsv_mg|5.006000||p
2684 sv_setsv_nomg|5.007002||p
2686 sv_setuv_mg|5.006000||p
2687 sv_setuv|5.006000||p
2688 sv_tainted||5.004000|
2692 sv_uni_display||5.007003|
2694 sv_unref_flags||5.007001|
2696 sv_untaint||5.004000|
2698 sv_usepvn_mg|5.006000||p
2700 sv_utf8_decode||5.006000|
2701 sv_utf8_downgrade||5.006000|
2702 sv_utf8_encode||5.006000|
2703 sv_utf8_upgrade_flags||5.007002|
2704 sv_utf8_upgrade||5.007001|
2706 sv_vcatpvf_mg||5.006000|
2707 sv_vcatpvfn||5.004000|
2708 sv_vcatpvf||5.006000|
2709 sv_vsetpvf_mg||5.006000|
2710 sv_vsetpvfn||5.004000|
2711 sv_vsetpvf||5.006000|
2714 swash_fetch||5.007002|
2715 swash_init||5.006000|
2721 tmps_grow||5.006000|
2725 to_uni_fold||5.007003|
2726 to_uni_lower_lc||5.006000|
2727 to_uni_lower||5.007003|
2728 to_uni_title_lc||5.006000|
2729 to_uni_title||5.007003|
2730 to_uni_upper_lc||5.006000|
2731 to_uni_upper||5.007003|
2732 to_utf8_case||5.007003|
2733 to_utf8_fold||5.007003|
2734 to_utf8_lower||5.007003|
2736 to_utf8_title||5.007003|
2737 to_utf8_upper||5.007003|
2740 too_few_arguments|||
2741 too_many_arguments|||
2744 unpack_str||5.007003|
2745 unpackstring||5.008001|
2746 unshare_hek_or_pvn|||
2748 unsharepvn||5.004000|
2749 upg_version||5.009000|
2752 utf16_to_utf8_reversed||5.006001|
2753 utf16_to_utf8||5.006001|
2754 utf16rev_textfilter|||
2755 utf8_distance||5.006000|
2757 utf8_length||5.007001|
2760 utf8_to_bytes||5.006001|
2761 utf8_to_uvchr||5.007001|
2762 utf8_to_uvuni||5.007001|
2763 utf8n_to_uvchr||5.007001|
2764 utf8n_to_uvuni||5.007001|
2766 uvchr_to_utf8_flags||5.007003|
2767 uvchr_to_utf8||5.007001|
2768 uvuni_to_utf8_flags||5.007003|
2769 uvuni_to_utf8||5.007001|
2783 vload_module||5.006000|
2785 vnewSVpvf||5.006000|
2790 vstringify||5.009000|
2795 warner_nocontext|||vn
2807 if (exists $opt{'list-unsupported'}) {
2809 for $f (sort { lc $a cmp lc $b } keys %API) {
2810 next unless $API{$f}{todo};
2811 print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
2816 # Scan for possible replacement candidates
2818 my(%replace, %need, %hints, %depends);
2824 if (m{^\s*\*\s(.*?)\s*$}) {
2825 $hints{$hint} ||= ''; # suppress warning with older perls
2826 $hints{$hint} .= "$1\n";
2832 $hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
2834 $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
2835 $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
2836 $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
2837 $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
2839 if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
2840 push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
2843 $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
2846 if (exists $opt{'list-provided'}) {
2848 for $f (sort { lc $a cmp lc $b } keys %API) {
2849 next unless $API{$f}{provided};
2851 push @flags, 'explicit' if exists $need{$f};
2852 push @flags, 'depend' if exists $depends{$f};
2853 push @flags, 'hint' if exists $hints{$f};
2854 my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
2860 my(%files, %global, %revreplace);
2861 %revreplace = reverse %replace;
2863 my $patch_opened = 0;
2865 for $filename (@files) {
2866 unless (open IN, "<$filename") {
2867 warn "Unable to read from $filename: $!\n";
2871 info("Scanning $filename ...");
2873 my $c = do { local $/; <IN> };
2876 my %file = (orig => $c, changes => 0);
2878 # temporarily remove C comments from the code
2884 (?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
2886 (?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
2890 \*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
2895 defined $2 and push @ccom, $2;
2896 defined $1 ? $1 : "$ccs$#ccom$cce";
2899 $file{ccom} = \@ccom;
2901 $file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
2905 for $func (keys %API) {
2907 $match .= "|$revreplace{$func}" if exists $revreplace{$func};
2908 if ($c =~ /\b(?:Perl_)?($match)\b/) {
2909 $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
2910 $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
2911 if (exists $API{$func}{provided}) {
2912 if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
2913 $file{uses}{$func}++;
2914 push @{$global{uses}{$func}}, $filename;
2915 my @deps = rec_depend($func);
2917 $file{uses_deps}{$func} = \@deps;
2919 $file{uses}{$_} = 0 unless exists $file{uses}{$_};
2920 push @{$global{uses}{$_}}, $filename;
2923 for ($func, @deps) {
2924 if (exists $need{$_}) {
2925 $file{needs}{$_} = 'static';
2926 push @{$global{needs}{$_}}, $filename;
2931 if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
2932 if ($c =~ /\b$func\b/) {
2933 $file{uses_todo}{$func}++;
2934 push @{$global{uses_todo}{$func}}, $filename;
2940 while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
2941 if (exists $need{$2}) {
2942 $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
2943 push @{$global{defined $3 ? 'needed_global' : 'needed_static'}{$2}}, $filename;
2946 warning("Possibly wrong #define $1 in $filename");
2950 $files{$filename} = \%file;
2953 # Globally resolve NEED_'s
2955 for $need (keys %{$global{needs}}) {
2956 if (@{$global{needs}{$need}} > 1) {
2957 my @targets = @{$global{needs}{$need}};
2958 my @t = grep $files{$_}{needed_global}{$need}, @targets;
2959 @targets = @t if @t;
2960 @t = grep /\.xs$/i, @targets;
2961 @targets = @t if @t;
2962 my $target = shift @targets;
2963 $files{$target}{needs}{$need} = 'global';
2964 for (@{$global{needs}{$need}}) {
2965 $files{$_}{needs}{$need} = 'extern' if $_ ne $target;
2970 for $filename (@files) {
2971 exists $files{$filename} or next;
2973 info("=== Analyzing $filename ===");
2975 my %file = %{$files{$filename}};
2977 my $c = $file{code};
2979 for $func (sort keys %{$file{uses_Perl}}) {
2980 if ($API{$func}{varargs}) {
2981 my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
2982 { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
2984 warning("Doesn't pass interpreter argument aTHX to Perl_$func");
2985 $file{changes} += $changes;
2989 warning("Uses Perl_$func instead of $func");
2990 $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
2995 for $func (sort keys %{$file{uses_replace}}) {
2996 warning("Uses $func instead of $replace{$func}");
2997 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3000 for $func (sort keys %{$file{uses}}) {
3001 next unless $file{uses}{$func}; # if it's only a dependency
3002 if (exists $file{uses_deps}{$func}) {
3003 diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
3005 elsif (exists $replace{$func}) {
3006 warning("Uses $func instead of $replace{$func}");
3007 $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
3015 for $func (sort keys %{$file{uses_todo}}) {
3016 warning("Uses $func, which may not be portable below perl ",
3017 format_version($API{$func}{todo}));
3020 for $func (sort keys %{$file{needed_static}}) {
3022 if (not exists $file{uses}{$func}) {
3023 $message = "No need to define NEED_$func if $func is never used";
3025 elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
3026 $message = "No need to define NEED_$func when already needed globally";
3030 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
3034 for $func (sort keys %{$file{needed_global}}) {
3036 if (not exists $global{uses}{$func}) {
3037 $message = "No need to define NEED_${func}_GLOBAL if $func is never used";
3039 elsif (exists $file{needs}{$func}) {
3040 if ($file{needs}{$func} eq 'extern') {
3041 $message = "No need to define NEED_${func}_GLOBAL when already needed globally";
3043 elsif ($file{needs}{$func} eq 'static') {
3044 $message = "No need to define NEED_${func}_GLOBAL when only used in this file";
3049 $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
3053 $file{needs_inc_ppport} = keys %{$file{uses}};
3055 if ($file{needs_inc_ppport}) {
3058 for $func (sort keys %{$file{needs}}) {
3059 my $type = $file{needs}{$func};
3060 next if $type eq 'extern';
3061 my $suffix = $type eq 'global' ? '_GLOBAL' : '';
3062 unless (exists $file{"needed_$type"}{$func}) {
3063 if ($type eq 'global') {
3064 diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
3067 diag("File needs $func, adding static request");
3069 $pp .= "#define NEED_$func$suffix\n";
3073 if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
3078 unless ($file{has_inc_ppport}) {
3079 diag("Needs to include '$ppport'");
3080 $pp .= qq(#include "$ppport"\n)
3084 $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
3085 || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
3086 || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
3087 || ($c =~ s/^/$pp/);
3091 if ($file{has_inc_ppport}) {
3092 diag("No need to include '$ppport'");
3093 $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
3097 # put back in our C comments
3100 my @ccom = @{$file{ccom}};
3101 for $ix (0 .. $#ccom) {
3102 if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
3104 $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
3107 $c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
3112 my $s = $cppc != 1 ? 's' : '';
3113 warning("Uses $cppc C++ style comment$s, which is not portable");
3116 if ($file{changes}) {
3117 if (exists $opt{copy}) {
3118 my $newfile = "$filename$opt{copy}";
3120 error("'$newfile' already exists, refusing to write copy of '$filename'");
3124 if (open F, ">$newfile") {
3125 info("Writing copy of '$filename' with changes to '$newfile'");
3130 error("Cannot open '$newfile' for writing: $!");
3134 elsif (exists $opt{patch} || $opt{changes}) {
3135 if (exists $opt{patch}) {
3136 unless ($patch_opened) {
3137 if (open PATCH, ">$opt{patch}") {
3141 error("Cannot open '$opt{patch}' for writing: $!");
3147 mydiff(\*PATCH, $filename, $c);
3151 info("Suggested changes:");
3152 mydiff(\*STDOUT, $filename, $c);
3156 my $s = $file{changes} == 1 ? '' : 's';
3157 info("$file{changes} potentially required change$s detected");
3165 close PATCH if $patch_opened;
3173 my($file, $str) = @_;
3176 if (exists $opt{diff}) {
3177 $diff = run_diff($opt{diff}, $file, $str);
3180 if (!defined $diff and can_use('Text::Diff')) {
3181 $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
3182 $diff = <<HEADER . $diff;
3188 if (!defined $diff) {
3189 $diff = run_diff('diff -u', $file, $str);
3192 if (!defined $diff) {
3193 $diff = run_diff('diff', $file, $str);
3196 if (!defined $diff) {
3197 error("Cannot generate a diff. Please install Text::Diff or use --copy.");
3207 my($prog, $file, $str) = @_;
3208 my $tmp = 'dppptemp';
3213 while (-e "$tmp.$suf") { $suf++ }
3216 if (open F, ">$tmp") {
3220 if (open F, "$prog $file $tmp |") {
3222 s/\Q$tmp\E/$file.patched/;
3233 error("Cannot open '$tmp' for writing: $!");
3248 return () unless exists $depends{$func};
3249 map { ($_, rec_depend($_)) } @{$depends{$func}};
3256 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
3257 return ($1, $2, $3);
3259 elsif ($ver !~ /^\d+\.[\d_]+$/) {
3260 die "cannot parse version '$ver'\n";
3264 $ver =~ s/$/000000/;
3266 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3271 if ($r < 5 || ($r == 5 && $v < 6)) {
3273 die "cannot parse version '$ver'\n";
3277 return ($r, $v, $s);
3284 $ver =~ s/$/000000/;
3285 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
3290 if ($r < 5 || ($r == 5 && $v < 6)) {
3292 die "invalid version '$ver'\n";
3296 $ver = sprintf "%d.%03d", $r, $v;
3297 $s > 0 and $ver .= sprintf "_%02d", $s;
3302 return sprintf "%d.%d.%d", $r, $v, $s;
3307 $opt{quiet} and return;
3313 $opt{quiet} and return;
3314 $opt{diag} and print @_, "\n";
3319 $opt{quiet} and return;
3320 print "*** ", @_, "\n";
3325 print "*** ERROR: ", @_, "\n";
3331 $opt{quiet} and return;
3332 $opt{hints} or return;
3334 exists $hints{$func} or return;
3335 $given_hints{$func}++ and return;
3336 my $hint = $hints{$func};
3338 print " --- hint for $func ---\n", $hint;
3343 my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
3344 my %M = ( 'I' => '*' );
3345 $usage =~ s/^\s*perl\s+\S+/$^X $0/;
3346 $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
3352 See perldoc $0 for details.
3362 #ifndef _P_P_PORTABILITY_H_
3363 #define _P_P_PORTABILITY_H_
3365 #ifndef DPPP_NAMESPACE
3366 # define DPPP_NAMESPACE DPPP_
3369 #define DPPP_CAT2(x,y) CAT2(x,y)
3370 #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name)
3372 #ifndef PERL_REVISION
3373 # ifndef __PATCHLEVEL_H_INCLUDED__
3374 # define PERL_PATCHLEVEL_H_IMPLICIT
3375 # include <patchlevel.h>
3377 # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
3378 # include <could_not_find_Perl_patchlevel.h>
3380 # ifndef PERL_REVISION
3381 # define PERL_REVISION (5)
3383 # define PERL_VERSION PATCHLEVEL
3384 # define PERL_SUBVERSION SUBVERSION
3385 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
3390 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
3392 /* It is very unlikely that anyone will try to use this with Perl 6
3393 (or greater), but who knows.
3395 #if PERL_REVISION != 5
3396 # error ppport.h only works with Perl version 5
3397 #endif /* PERL_REVISION != 5 */
3400 # include <limits.h>
3403 #ifndef PERL_UCHAR_MIN
3404 # define PERL_UCHAR_MIN ((unsigned char)0)
3407 #ifndef PERL_UCHAR_MAX
3409 # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
3412 # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
3414 # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
3419 #ifndef PERL_USHORT_MIN
3420 # define PERL_USHORT_MIN ((unsigned short)0)
3423 #ifndef PERL_USHORT_MAX
3425 # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
3428 # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
3431 # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
3433 # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
3439 #ifndef PERL_SHORT_MAX
3441 # define PERL_SHORT_MAX ((short)SHORT_MAX)
3443 # ifdef MAXSHORT /* Often used in <values.h> */
3444 # define PERL_SHORT_MAX ((short)MAXSHORT)
3447 # define PERL_SHORT_MAX ((short)SHRT_MAX)
3449 # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
3455 #ifndef PERL_SHORT_MIN
3457 # define PERL_SHORT_MIN ((short)SHORT_MIN)
3460 # define PERL_SHORT_MIN ((short)MINSHORT)
3463 # define PERL_SHORT_MIN ((short)SHRT_MIN)
3465 # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
3471 #ifndef PERL_UINT_MAX
3473 # define PERL_UINT_MAX ((unsigned int)UINT_MAX)
3476 # define PERL_UINT_MAX ((unsigned int)MAXUINT)
3478 # define PERL_UINT_MAX (~(unsigned int)0)
3483 #ifndef PERL_UINT_MIN
3484 # define PERL_UINT_MIN ((unsigned int)0)
3487 #ifndef PERL_INT_MAX
3489 # define PERL_INT_MAX ((int)INT_MAX)
3491 # ifdef MAXINT /* Often used in <values.h> */
3492 # define PERL_INT_MAX ((int)MAXINT)
3494 # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
3499 #ifndef PERL_INT_MIN
3501 # define PERL_INT_MIN ((int)INT_MIN)
3504 # define PERL_INT_MIN ((int)MININT)
3506 # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
3511 #ifndef PERL_ULONG_MAX
3513 # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
3516 # define PERL_ULONG_MAX ((unsigned long)MAXULONG)
3518 # define PERL_ULONG_MAX (~(unsigned long)0)
3523 #ifndef PERL_ULONG_MIN
3524 # define PERL_ULONG_MIN ((unsigned long)0L)
3527 #ifndef PERL_LONG_MAX
3529 # define PERL_LONG_MAX ((long)LONG_MAX)
3532 # define PERL_LONG_MAX ((long)MAXLONG)
3534 # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
3539 #ifndef PERL_LONG_MIN
3541 # define PERL_LONG_MIN ((long)LONG_MIN)
3544 # define PERL_LONG_MIN ((long)MINLONG)
3546 # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
3551 #if defined(HAS_QUAD) && (defined(convex) || defined(uts))
3552 # ifndef PERL_UQUAD_MAX
3553 # ifdef ULONGLONG_MAX
3554 # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
3556 # ifdef MAXULONGLONG
3557 # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
3559 # define PERL_UQUAD_MAX (~(unsigned long long)0)
3564 # ifndef PERL_UQUAD_MIN
3565 # define PERL_UQUAD_MIN ((unsigned long long)0L)
3568 # ifndef PERL_QUAD_MAX
3569 # ifdef LONGLONG_MAX
3570 # define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
3573 # define PERL_QUAD_MAX ((long long)MAXLONGLONG)
3575 # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
3580 # ifndef PERL_QUAD_MIN
3581 # ifdef LONGLONG_MIN
3582 # define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
3585 # define PERL_QUAD_MIN ((long long)MINLONGLONG)
3587 # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
3593 /* This is based on code from 5.003 perl.h */
3601 # define IV_MIN PERL_INT_MIN
3605 # define IV_MAX PERL_INT_MAX
3609 # define UV_MIN PERL_UINT_MIN
3613 # define UV_MAX PERL_UINT_MAX
3618 # define IVSIZE INTSIZE
3623 # if defined(convex) || defined(uts)
3625 # define IVTYPE long long
3629 # define IV_MIN PERL_QUAD_MIN
3633 # define IV_MAX PERL_QUAD_MAX
3637 # define UV_MIN PERL_UQUAD_MIN
3641 # define UV_MAX PERL_UQUAD_MAX
3644 # ifdef LONGLONGSIZE
3646 # define IVSIZE LONGLONGSIZE
3652 # define IVTYPE long
3656 # define IV_MIN PERL_LONG_MIN
3660 # define IV_MAX PERL_LONG_MAX
3664 # define UV_MIN PERL_ULONG_MIN
3668 # define UV_MAX PERL_ULONG_MAX
3673 # define IVSIZE LONGSIZE
3683 #ifndef PERL_QUAD_MIN
3684 # define PERL_QUAD_MIN IV_MIN
3687 #ifndef PERL_QUAD_MAX
3688 # define PERL_QUAD_MAX IV_MAX
3691 #ifndef PERL_UQUAD_MIN
3692 # define PERL_UQUAD_MIN UV_MIN
3695 #ifndef PERL_UQUAD_MAX
3696 # define PERL_UQUAD_MAX UV_MAX
3701 # define IVTYPE long
3705 # define IV_MIN PERL_LONG_MIN
3709 # define IV_MAX PERL_LONG_MAX
3713 # define UV_MIN PERL_ULONG_MIN
3717 # define UV_MAX PERL_ULONG_MAX
3724 # define IVSIZE LONGSIZE
3726 # define IVSIZE 4 /* A bold guess, but the best we can make. */
3730 # define UVTYPE unsigned IVTYPE
3734 # define UVSIZE IVSIZE
3738 # define sv_setuv(sv, uv) \
3741 if (TeMpUv <= IV_MAX) \
3742 sv_setiv(sv, TeMpUv); \
3744 sv_setnv(sv, (double)TeMpUv); \
3749 # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
3752 # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
3756 # define SvUVX(sv) ((UV)SvIVX(sv))
3760 # define SvUVXx(sv) SvUVX(sv)
3764 # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
3768 # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
3772 * Always use the SvUVx() macro instead of sv_uv().
3775 # define sv_uv(sv) SvUVx(sv)
3778 # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
3782 # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
3785 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
3788 # define PL_compiling compiling
3789 # define PL_copline copline
3790 # define PL_curcop curcop
3791 # define PL_curstash curstash
3792 # define PL_defgv defgv
3793 # define PL_dirty dirty
3794 # define PL_dowarn dowarn
3795 # define PL_hints hints
3797 # define PL_perldb perldb
3798 # define PL_rsfp_filters rsfp_filters
3799 # define PL_rsfp rsfp
3800 # define PL_stdingv stdingv
3801 # define PL_sv_no sv_no
3802 # define PL_sv_undef sv_undef
3803 # define PL_sv_yes sv_yes
3804 # define PL_hexdigit hexdigit
3809 # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
3810 # define PERL_UNUSED_DECL
3812 # define PERL_UNUSED_DECL __attribute__((unused))
3815 # define PERL_UNUSED_DECL
3818 # define NOOP (void)0
3822 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
3826 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
3827 # define NVTYPE long double
3829 # define NVTYPE double
3836 # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
3838 # define INT2PTR(any,d) (any)(d)
3840 # if PTRSIZE == LONGSIZE
3841 # define PTRV unsigned long
3843 # define PTRV unsigned
3845 # define INT2PTR(any,d) (any)(PTRV)(d)
3848 # define NUM2PTR(any,d) (any)(PTRV)(d)
3849 # define PTR2IV(p) INT2PTR(IV,p)
3850 # define PTR2UV(p) INT2PTR(UV,p)
3851 # define PTR2NV(p) NUM2PTR(NV,p)
3853 # if PTRSIZE == LONGSIZE
3854 # define PTR2ul(p) (unsigned long)(p)
3856 # define PTR2ul(p) INT2PTR(unsigned long,p)
3859 #endif /* !INT2PTR */
3861 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
3864 /* DEFSV appears first in 5.004_56 */
3866 # define DEFSV GvSV(PL_defgv)
3870 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
3873 /* Older perls (<=5.003) lack AvFILLp */
3875 # define AvFILLp AvFILL
3878 # define ERRSV get_sv("@",FALSE)
3881 # define newSVpvn(data,len) ((data) \
3882 ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
3886 /* Hint: gv_stashpvn
3887 * This function's backport doesn't support the length parameter, but
3888 * rather ignores it. Portability can only be ensured if the length
3889 * parameter is used for speed reasons, but the length can always be
3890 * correctly computed from the string argument.
3893 # define gv_stashpvn(str,len,create) gv_stashpv(str,create)
3898 # define get_cv perl_get_cv
3902 # define get_sv perl_get_sv
3906 # define get_av perl_get_av
3910 # define get_hv perl_get_hv
3917 # define memNE(s1,s2,l) (memcmp(s1,s2,l))
3921 # define memEQ(s1,s2,l) (!memcmp(s1,s2,l))
3926 # define memNE(s1,s2,l) (bcmp(s1,s2,l))
3930 # define memEQ(s1,s2,l) (!bcmp(s1,s2,l))
3935 # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
3939 # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
3944 # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
3949 # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
3954 # define Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
3957 # define dUNDERBAR dNOOP
3961 # define UNDERBAR DEFSV
3964 # define dAX I32 ax = MARK - PL_stack_base + 1
3968 # define dITEMS I32 items = SP - MARK
3978 # define dTHXa(x) dNOOP
3996 # define dTHXoa(x) dTHXa(x)
3999 # define PUSHmortal PUSHs(sv_newmortal())
4003 # define mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
4007 # define mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
4011 # define mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
4015 # define mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
4018 # define XPUSHmortal XPUSHs(sv_newmortal())
4022 # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
4026 # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
4030 # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
4034 # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
4039 # define call_sv perl_call_sv
4043 # define call_pv perl_call_pv
4047 # define call_argv perl_call_argv
4051 # define call_method perl_call_method
4054 # define eval_sv perl_eval_sv
4059 /* Replace perl_eval_pv with eval_pv */
4060 /* eval_pv depends on eval_sv */
4063 #if defined(NEED_eval_pv)
4064 static SV* DPPP_(eval_pv)(char *p, I32 croak_on_error);
4067 extern SV* DPPP_(eval_pv)(char *p, I32 croak_on_error);
4073 #define eval_pv(a,b) DPPP_(eval_pv)(aTHX_ a,b)
4074 #define Perl_eval_pv DPPP_(eval_pv)
4076 #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
4079 DPPP_(eval_pv)(char *p, I32 croak_on_error)
4082 SV* sv = newSVpv(p, 0);
4085 eval_sv(sv, G_SCALAR);
4092 if (croak_on_error && SvTRUE(GvSV(errgv)))
4093 croak(SvPVx(GvSV(errgv), na));
4101 # define newRV_inc(sv) newRV(sv) /* Replace */
4105 #if defined(NEED_newRV_noinc)
4106 static SV * DPPP_(newRV_noinc)(SV *sv);
4109 extern SV * DPPP_(newRV_noinc)(SV *sv);
4115 #define newRV_noinc(a) DPPP_(newRV_noinc)(aTHX_ a)
4116 #define Perl_newRV_noinc DPPP_(newRV_noinc)
4118 #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL)
4120 DPPP_(newRV_noinc)(SV *sv)
4122 SV *rv = (SV *)newRV(sv);
4129 /* Hint: newCONSTSUB
4130 * Returns a CV* as of perl-5.7.1. This return value is not supported
4134 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
4135 #if ((PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))) && ((PERL_VERSION != 4) || (PERL_SUBVERSION != 5))
4136 #if defined(NEED_newCONSTSUB)
4137 static void DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv);
4140 extern void DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv);
4146 #define newCONSTSUB(a,b,c) DPPP_(newCONSTSUB)(aTHX_ a,b,c)
4147 #define Perl_newCONSTSUB DPPP_(newCONSTSUB)
4149 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
4152 DPPP_(newCONSTSUB)(HV *stash, char *name, SV *sv)
4154 U32 oldhints = PL_hints;
4155 HV *old_cop_stash = PL_curcop->cop_stash;
4156 HV *old_curstash = PL_curstash;
4157 line_t oldline = PL_curcop->cop_line;
4158 PL_curcop->cop_line = PL_copline;
4160 PL_hints &= ~HINT_BLOCK_SCOPE;
4162 PL_curstash = PL_curcop->cop_stash = stash;
4166 #if ((PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22)))
4168 #elif ((PERL_VERSION == 3) && (PERL_SUBVERSION == 22))
4170 #else /* 5.003_23 onwards */
4171 start_subparse(FALSE, 0),
4174 newSVOP(OP_CONST, 0, newSVpv(name,0)),
4175 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
4176 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
4179 PL_hints = oldhints;
4180 PL_curcop->cop_stash = old_cop_stash;
4181 PL_curstash = old_curstash;
4182 PL_curcop->cop_line = oldline;
4187 #ifndef START_MY_CXT
4190 * Boilerplate macros for initializing and accessing interpreter-local
4191 * data from C. All statics in extensions should be reworked to use
4192 * this, if you want to make the extension thread-safe. See ext/re/re.xs
4193 * for an example of the use of these macros.
4195 * Code that uses these macros is responsible for the following:
4196 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
4197 * 2. Declare a typedef named my_cxt_t that is a structure that contains
4198 * all the data that needs to be interpreter-local.
4199 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
4200 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
4201 * (typically put in the BOOT: section).
4202 * 5. Use the members of the my_cxt_t structure everywhere as
4204 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
4208 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
4209 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
4211 /* This must appear in all extensions that define a my_cxt_t structure,
4212 * right after the definition (i.e. at file scope). The non-threads
4213 * case below uses it to declare the data as static. */
4214 #define START_MY_CXT
4216 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
4217 /* Fetches the SV that keeps the per-interpreter data. */
4218 #define dMY_CXT_SV \
4219 SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
4220 #else /* >= perl5.004_68 */
4221 #define dMY_CXT_SV \
4222 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
4223 sizeof(MY_CXT_KEY)-1, TRUE)
4224 #endif /* < perl5.004_68 */
4226 /* This declaration should be used within all functions that use the
4227 * interpreter-local data. */
4230 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
4232 /* Creates and zeroes the per-interpreter data.
4233 * (We allocate my_cxtp in a Perl SV so that it will be released when
4234 * the interpreter goes away.) */
4235 #define MY_CXT_INIT \
4237 /* newSV() allocates one more than needed */ \
4238 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
4239 Zero(my_cxtp, 1, my_cxt_t); \
4240 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
4242 /* This macro must be used to access members of the my_cxt_t structure.
4243 * e.g. MYCXT.some_data */
4244 #define MY_CXT (*my_cxtp)
4246 /* Judicious use of these macros can reduce the number of times dMY_CXT
4247 * is used. Use is similar to pTHX, aTHX etc. */
4248 #define pMY_CXT my_cxt_t *my_cxtp
4249 #define pMY_CXT_ pMY_CXT,
4250 #define _pMY_CXT ,pMY_CXT
4251 #define aMY_CXT my_cxtp
4252 #define aMY_CXT_ aMY_CXT,
4253 #define _aMY_CXT ,aMY_CXT
4255 #else /* single interpreter */
4257 #define START_MY_CXT static my_cxt_t my_cxt;
4258 #define dMY_CXT_SV dNOOP
4259 #define dMY_CXT dNOOP
4260 #define MY_CXT_INIT NOOP
4261 #define MY_CXT my_cxt
4263 #define pMY_CXT void
4272 #endif /* START_MY_CXT */
4275 # if IVSIZE == LONGSIZE
4282 # if IVSIZE == INTSIZE
4293 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
4294 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
4295 # define NVef PERL_PRIeldbl
4296 # define NVff PERL_PRIfldbl
4297 # define NVgf PERL_PRIgldbl
4307 #if defined(NEED_sv_2pv_nolen)
4308 static char * DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv);
4311 extern char * DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv);
4315 # undef sv_2pv_nolen
4317 #define sv_2pv_nolen(a) DPPP_(sv_2pv_nolen)(aTHX_ a)
4318 #define Perl_sv_2pv_nolen DPPP_(sv_2pv_nolen)
4320 #if defined(NEED_sv_2pv_nolen) || defined(NEED_sv_2pv_nolen_GLOBAL)
4323 DPPP_(sv_2pv_nolen)(pTHX_ register SV *sv)
4326 return sv_2pv(sv, &n_a);
4331 /* Hint: sv_2pv_nolen
4332 * Use the SvPV_nolen() macro instead of sv_2pv_nolen().
4335 /* SvPV_nolen depends on sv_2pv_nolen */
4336 #define SvPV_nolen(sv) \
4337 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
4338 ? SvPVX(sv) : sv_2pv_nolen(sv))
4345 * Does not work in perl-5.6.1, ppport.h implements a version
4346 * borrowed from perl-5.7.3.
4349 #if ((PERL_VERSION < 7) || ((PERL_VERSION == 7) && (PERL_SUBVERSION < 0)))
4351 #if defined(NEED_sv_2pvbyte)
4352 static char * DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4355 extern char * DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp);
4361 #define sv_2pvbyte(a,b) DPPP_(sv_2pvbyte)(aTHX_ a,b)
4362 #define Perl_sv_2pvbyte DPPP_(sv_2pvbyte)
4364 #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL)
4367 DPPP_(sv_2pvbyte)(pTHX_ register SV *sv, STRLEN *lp)
4369 sv_utf8_downgrade(sv,0);
4370 return SvPV(sv,*lp);
4376 * Use the SvPVbyte() macro instead of sv_2pvbyte().
4381 /* SvPVbyte depends on sv_2pvbyte */
4382 #define SvPVbyte(sv, lp) \
4383 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
4384 ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
4390 # define SvPVbyte SvPV
4391 # define sv_2pvbyte sv_2pv
4395 /* sv_2pvbyte_nolen depends on sv_2pv_nolen */
4396 #ifndef sv_2pvbyte_nolen
4397 # define sv_2pvbyte_nolen sv_2pv_nolen
4401 * Always use the SvPV() macro instead of sv_pvn().
4404 # define sv_pvn(sv, len) SvPV(sv, len)
4408 * Always use the SvPV_force() macro instead of sv_pvn_force().
4410 #ifndef sv_pvn_force
4411 # define sv_pvn_force(sv, len) SvPV_force(sv, len)
4414 # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
4416 #ifndef PERL_MAGIC_sv
4417 # define PERL_MAGIC_sv '\0'
4420 #ifndef PERL_MAGIC_overload
4421 # define PERL_MAGIC_overload 'A'
4424 #ifndef PERL_MAGIC_overload_elem
4425 # define PERL_MAGIC_overload_elem 'a'
4428 #ifndef PERL_MAGIC_overload_table
4429 # define PERL_MAGIC_overload_table 'c'
4432 #ifndef PERL_MAGIC_bm
4433 # define PERL_MAGIC_bm 'B'
4436 #ifndef PERL_MAGIC_regdata
4437 # define PERL_MAGIC_regdata 'D'
4440 #ifndef PERL_MAGIC_regdatum
4441 # define PERL_MAGIC_regdatum 'd'
4444 #ifndef PERL_MAGIC_env
4445 # define PERL_MAGIC_env 'E'
4448 #ifndef PERL_MAGIC_envelem
4449 # define PERL_MAGIC_envelem 'e'
4452 #ifndef PERL_MAGIC_fm
4453 # define PERL_MAGIC_fm 'f'
4456 #ifndef PERL_MAGIC_regex_global
4457 # define PERL_MAGIC_regex_global 'g'
4460 #ifndef PERL_MAGIC_isa
4461 # define PERL_MAGIC_isa 'I'
4464 #ifndef PERL_MAGIC_isaelem
4465 # define PERL_MAGIC_isaelem 'i'
4468 #ifndef PERL_MAGIC_nkeys
4469 # define PERL_MAGIC_nkeys 'k'
4472 #ifndef PERL_MAGIC_dbfile
4473 # define PERL_MAGIC_dbfile 'L'
4476 #ifndef PERL_MAGIC_dbline
4477 # define PERL_MAGIC_dbline 'l'
4480 #ifndef PERL_MAGIC_mutex
4481 # define PERL_MAGIC_mutex 'm'
4484 #ifndef PERL_MAGIC_shared
4485 # define PERL_MAGIC_shared 'N'
4488 #ifndef PERL_MAGIC_shared_scalar
4489 # define PERL_MAGIC_shared_scalar 'n'
4492 #ifndef PERL_MAGIC_collxfrm
4493 # define PERL_MAGIC_collxfrm 'o'
4496 #ifndef PERL_MAGIC_tied
4497 # define PERL_MAGIC_tied 'P'
4500 #ifndef PERL_MAGIC_tiedelem
4501 # define PERL_MAGIC_tiedelem 'p'
4504 #ifndef PERL_MAGIC_tiedscalar
4505 # define PERL_MAGIC_tiedscalar 'q'
4508 #ifndef PERL_MAGIC_qr
4509 # define PERL_MAGIC_qr 'r'
4512 #ifndef PERL_MAGIC_sig
4513 # define PERL_MAGIC_sig 'S'
4516 #ifndef PERL_MAGIC_sigelem
4517 # define PERL_MAGIC_sigelem 's'
4520 #ifndef PERL_MAGIC_taint
4521 # define PERL_MAGIC_taint 't'
4524 #ifndef PERL_MAGIC_uvar
4525 # define PERL_MAGIC_uvar 'U'
4528 #ifndef PERL_MAGIC_uvar_elem
4529 # define PERL_MAGIC_uvar_elem 'u'
4532 #ifndef PERL_MAGIC_vstring
4533 # define PERL_MAGIC_vstring 'V'
4536 #ifndef PERL_MAGIC_vec
4537 # define PERL_MAGIC_vec 'v'
4540 #ifndef PERL_MAGIC_utf8
4541 # define PERL_MAGIC_utf8 'w'
4544 #ifndef PERL_MAGIC_substr
4545 # define PERL_MAGIC_substr 'x'
4548 #ifndef PERL_MAGIC_defelem
4549 # define PERL_MAGIC_defelem 'y'
4552 #ifndef PERL_MAGIC_glob
4553 # define PERL_MAGIC_glob '*'
4556 #ifndef PERL_MAGIC_arylen
4557 # define PERL_MAGIC_arylen '#'
4560 #ifndef PERL_MAGIC_pos
4561 # define PERL_MAGIC_pos '.'
4564 #ifndef PERL_MAGIC_backref
4565 # define PERL_MAGIC_backref '<'
4568 #ifndef PERL_MAGIC_ext
4569 # define PERL_MAGIC_ext '~'
4572 /* That's the best we can do... */
4573 #ifndef SvPV_force_nomg
4574 # define SvPV_force_nomg SvPV_force
4578 # define SvPV_nomg SvPV
4581 #ifndef sv_catpvn_nomg
4582 # define sv_catpvn_nomg sv_catpvn
4585 #ifndef sv_catsv_nomg
4586 # define sv_catsv_nomg sv_catsv
4589 #ifndef sv_setsv_nomg
4590 # define sv_setsv_nomg sv_setsv
4594 # define sv_pvn_nomg sv_pvn
4598 # define SvIV_nomg SvIV
4602 # define SvUV_nomg SvUV
4606 # define sv_catpv_mg(sv, ptr) \
4609 sv_catpv(TeMpSv,ptr); \
4610 SvSETMAGIC(TeMpSv); \
4614 #ifndef sv_catpvn_mg
4615 # define sv_catpvn_mg(sv, ptr, len) \
4618 sv_catpvn(TeMpSv,ptr,len); \
4619 SvSETMAGIC(TeMpSv); \
4624 # define sv_catsv_mg(dsv, ssv) \
4627 sv_catsv(TeMpSv,ssv); \
4628 SvSETMAGIC(TeMpSv); \
4633 # define sv_setiv_mg(sv, i) \
4636 sv_setiv(TeMpSv,i); \
4637 SvSETMAGIC(TeMpSv); \
4642 # define sv_setnv_mg(sv, num) \
4645 sv_setnv(TeMpSv,num); \
4646 SvSETMAGIC(TeMpSv); \
4651 # define sv_setpv_mg(sv, ptr) \
4654 sv_setpv(TeMpSv,ptr); \
4655 SvSETMAGIC(TeMpSv); \
4659 #ifndef sv_setpvn_mg
4660 # define sv_setpvn_mg(sv, ptr, len) \
4663 sv_setpvn(TeMpSv,ptr,len); \
4664 SvSETMAGIC(TeMpSv); \
4669 # define sv_setsv_mg(dsv, ssv) \
4672 sv_setsv(TeMpSv,ssv); \
4673 SvSETMAGIC(TeMpSv); \
4678 # define sv_setuv_mg(sv, i) \
4681 sv_setuv(TeMpSv,i); \
4682 SvSETMAGIC(TeMpSv); \
4686 #ifndef sv_usepvn_mg
4687 # define sv_usepvn_mg(sv, ptr, len) \
4690 sv_usepvn(TeMpSv,ptr,len); \
4691 SvSETMAGIC(TeMpSv); \
4697 # define CopFILE(c) ((c)->cop_file)
4701 # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
4705 # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
4709 # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
4713 # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
4717 # define CopSTASHPV(c) ((c)->cop_stashpv)
4720 #ifndef CopSTASHPV_set
4721 # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
4725 # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
4728 #ifndef CopSTASH_set
4729 # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
4733 # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
4734 || (CopSTASHPV(c) && HvNAME(hv) \
4735 && strEQ(CopSTASHPV(c), HvNAME(hv)))))
4740 # define CopFILEGV(c) ((c)->cop_filegv)
4743 #ifndef CopFILEGV_set
4744 # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
4748 # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
4752 # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
4756 # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
4760 # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
4764 # define CopSTASH(c) ((c)->cop_stash)
4767 #ifndef CopSTASH_set
4768 # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
4772 # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
4775 #ifndef CopSTASHPV_set
4776 # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
4780 # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
4783 #endif /* USE_ITHREADS */
4784 #ifndef IN_PERL_COMPILETIME
4785 # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
4788 #ifndef IN_LOCALE_RUNTIME
4789 # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
4792 #ifndef IN_LOCALE_COMPILETIME
4793 # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
4797 # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
4799 #ifndef IS_NUMBER_IN_UV
4800 # define IS_NUMBER_IN_UV 0x01
4803 #ifndef IS_NUMBER_GREATER_THAN_UV_MAX
4804 # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
4807 #ifndef IS_NUMBER_NOT_INT
4808 # define IS_NUMBER_NOT_INT 0x04
4811 #ifndef IS_NUMBER_NEG
4812 # define IS_NUMBER_NEG 0x08
4815 #ifndef IS_NUMBER_INFINITY
4816 # define IS_NUMBER_INFINITY 0x10
4819 #ifndef IS_NUMBER_NAN
4820 # define IS_NUMBER_NAN 0x20
4823 /* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
4824 #ifndef GROK_NUMERIC_RADIX
4825 # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
4827 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
4828 # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
4831 #ifndef PERL_SCAN_SILENT_ILLDIGIT
4832 # define PERL_SCAN_SILENT_ILLDIGIT 0x04
4835 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
4836 # define PERL_SCAN_ALLOW_UNDERSCORES 0x01
4839 #ifndef PERL_SCAN_DISALLOW_PREFIX
4840 # define PERL_SCAN_DISALLOW_PREFIX 0x02
4843 #ifndef grok_numeric_radix
4844 #if defined(NEED_grok_numeric_radix)
4845 static bool DPPP_(grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
4848 extern bool DPPP_(grok_numeric_radix)(pTHX_ const char ** sp, const char * send);
4851 #ifdef grok_numeric_radix
4852 # undef grok_numeric_radix
4854 #define grok_numeric_radix(a,b) DPPP_(grok_numeric_radix)(aTHX_ a,b)
4855 #define Perl_grok_numeric_radix DPPP_(grok_numeric_radix)
4857 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL)
4859 DPPP_(grok_numeric_radix)(pTHX_ const char **sp, const char *send)
4861 #ifdef USE_LOCALE_NUMERIC
4862 #ifdef PL_numeric_radix_sv
4863 if (PL_numeric_radix_sv && IN_LOCALE) {
4865 char* radix = SvPV(PL_numeric_radix_sv, len);
4866 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4872 /* older perls don't have PL_numeric_radix_sv so the radix
4873 * must manually be requested from locale.h
4876 dTHR; /* needed for older threaded perls */
4877 struct lconv *lc = localeconv();
4878 char *radix = lc->decimal_point;
4879 if (radix && IN_LOCALE) {
4880 STRLEN len = strlen(radix);
4881 if (*sp + len <= send && memEQ(*sp, radix, len)) {
4886 #endif /* PERL_VERSION */
4887 #endif /* USE_LOCALE_NUMERIC */
4888 /* always try "." if numeric radix didn't match because
4889 * we may have data from different locales mixed */
4890 if (*sp < send && **sp == '.') {
4899 /* grok_number depends on grok_numeric_radix */
4902 #if defined(NEED_grok_number)
4903 static int DPPP_(grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4906 extern int DPPP_(grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep);
4912 #define grok_number(a,b,c) DPPP_(grok_number)(aTHX_ a,b,c)
4913 #define Perl_grok_number DPPP_(grok_number)
4915 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL)
4917 DPPP_(grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep)
4920 const char *send = pv + len;
4921 const UV max_div_10 = UV_MAX / 10;
4922 const char max_mod_10 = UV_MAX % 10;
4927 while (s < send && isSPACE(*s))
4931 } else if (*s == '-') {
4933 numtype = IS_NUMBER_NEG;
4941 /* next must be digit or the radix separator or beginning of infinity */
4943 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
4945 UV value = *s - '0';
4946 /* This construction seems to be more optimiser friendly.
4947 (without it gcc does the isDIGIT test and the *s - '0' separately)
4948 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
4949 In theory the optimiser could deduce how far to unroll the loop
4950 before checking for overflow. */
4952 int digit = *s - '0';
4953 if (digit >= 0 && digit <= 9) {
4954 value = value * 10 + digit;
4957 if (digit >= 0 && digit <= 9) {
4958 value = value * 10 + digit;
4961 if (digit >= 0 && digit <= 9) {
4962 value = value * 10 + digit;
4965 if (digit >= 0 && digit <= 9) {
4966 value = value * 10 + digit;
4969 if (digit >= 0 && digit <= 9) {
4970 value = value * 10 + digit;
4973 if (digit >= 0 && digit <= 9) {
4974 value = value * 10 + digit;
4977 if (digit >= 0 && digit <= 9) {
4978 value = value * 10 + digit;
4981 if (digit >= 0 && digit <= 9) {
4982 value = value * 10 + digit;
4984 /* Now got 9 digits, so need to check
4985 each time for overflow. */
4987 while (digit >= 0 && digit <= 9
4988 && (value < max_div_10
4989 || (value == max_div_10
4990 && digit <= max_mod_10))) {
4991 value = value * 10 + digit;
4997 if (digit >= 0 && digit <= 9
4999 /* value overflowed.
5000 skip the remaining digits, don't
5001 worry about setting *valuep. */
5004 } while (s < send && isDIGIT(*s));
5006 IS_NUMBER_GREATER_THAN_UV_MAX;
5026 numtype |= IS_NUMBER_IN_UV;
5031 if (GROK_NUMERIC_RADIX(&s, send)) {
5032 numtype |= IS_NUMBER_NOT_INT;
5033 while (s < send && isDIGIT(*s)) /* optional digits after the radix */
5037 else if (GROK_NUMERIC_RADIX(&s, send)) {
5038 numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
5039 /* no digits before the radix means we need digits after it */
5040 if (s < send && isDIGIT(*s)) {
5043 } while (s < send && isDIGIT(*s));
5045 /* integer approximation is valid - it's 0. */
5051 } else if (*s == 'I' || *s == 'i') {
5052 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5053 s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
5054 s++; if (s < send && (*s == 'I' || *s == 'i')) {
5055 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5056 s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
5057 s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
5058 s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
5062 } else if (*s == 'N' || *s == 'n') {
5063 /* XXX TODO: There are signaling NaNs and quiet NaNs. */
5064 s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
5065 s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
5072 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5073 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
5074 } else if (sawnan) {
5075 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
5076 numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
5077 } else if (s < send) {
5078 /* we can have an optional exponent part */
5079 if (*s == 'e' || *s == 'E') {
5080 /* The only flag we keep is sign. Blow away any "it's UV" */
5081 numtype &= IS_NUMBER_NEG;
5082 numtype |= IS_NUMBER_NOT_INT;
5084 if (s < send && (*s == '-' || *s == '+'))
5086 if (s < send && isDIGIT(*s)) {
5089 } while (s < send && isDIGIT(*s));
5095 while (s < send && isSPACE(*s))
5099 if (len == 10 && memEQ(pv, "0 but true", 10)) {
5102 return IS_NUMBER_IN_UV;
5110 * The grok_* routines have been modified to use warn() instead of
5111 * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
5112 * which is why the stack variable has been renamed to 'xdigit'.
5116 #if defined(NEED_grok_bin)
5117 static UV DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5120 extern UV DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5126 #define grok_bin(a,b,c,d) DPPP_(grok_bin)(aTHX_ a,b,c,d)
5127 #define Perl_grok_bin DPPP_(grok_bin)
5129 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL)
5131 DPPP_(grok_bin)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5133 const char *s = start;
5134 STRLEN len = *len_p;
5138 const UV max_div_2 = UV_MAX / 2;
5139 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5140 bool overflowed = FALSE;
5142 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5143 /* strip off leading b or 0b.
5144 for compatibility silently suffer "b" and "0b" as valid binary
5151 else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
5158 for (; len-- && *s; s++) {
5160 if (bit == '0' || bit == '1') {
5161 /* Write it in this wonky order with a goto to attempt to get the
5162 compiler to make the common case integer-only loop pretty tight.
5163 With gcc seems to be much straighter code than old scan_bin. */
5166 if (value <= max_div_2) {
5167 value = (value << 1) | (bit - '0');
5170 /* Bah. We're just overflowed. */
5171 warn("Integer overflow in binary number");
5173 value_nv = (NV) value;
5176 /* If an NV has not enough bits in its mantissa to
5177 * represent a UV this summing of small low-order numbers
5178 * is a waste of time (because the NV cannot preserve
5179 * the low-order bits anyway): we could just remember when
5180 * did we overflow and in the end just multiply value_nv by the
5182 value_nv += (NV)(bit - '0');
5185 if (bit == '_' && len && allow_underscores && (bit = s[1])
5186 && (bit == '0' || bit == '1'))
5192 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5193 warn("Illegal binary digit '%c' ignored", *s);
5197 if ( ( overflowed && value_nv > 4294967295.0)
5199 || (!overflowed && value > 0xffffffff )
5202 warn("Binary number > 0b11111111111111111111111111111111 non-portable");
5209 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5218 #if defined(NEED_grok_hex)
5219 static UV DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5222 extern UV DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5228 #define grok_hex(a,b,c,d) DPPP_(grok_hex)(aTHX_ a,b,c,d)
5229 #define Perl_grok_hex DPPP_(grok_hex)
5231 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL)
5233 DPPP_(grok_hex)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5235 const char *s = start;
5236 STRLEN len = *len_p;
5240 const UV max_div_16 = UV_MAX / 16;
5241 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5242 bool overflowed = FALSE;
5245 if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
5246 /* strip off leading x or 0x.
5247 for compatibility silently suffer "x" and "0x" as valid hex numbers.
5254 else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
5261 for (; len-- && *s; s++) {
5262 xdigit = strchr((char *) PL_hexdigit, *s);
5264 /* Write it in this wonky order with a goto to attempt to get the
5265 compiler to make the common case integer-only loop pretty tight.
5266 With gcc seems to be much straighter code than old scan_hex. */
5269 if (value <= max_div_16) {
5270 value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
5273 warn("Integer overflow in hexadecimal number");
5275 value_nv = (NV) value;
5278 /* If an NV has not enough bits in its mantissa to
5279 * represent a UV this summing of small low-order numbers
5280 * is a waste of time (because the NV cannot preserve
5281 * the low-order bits anyway): we could just remember when
5282 * did we overflow and in the end just multiply value_nv by the
5283 * right amount of 16-tuples. */
5284 value_nv += (NV)((xdigit - PL_hexdigit) & 15);
5287 if (*s == '_' && len && allow_underscores && s[1]
5288 && (xdigit = strchr((char *) PL_hexdigit, s[1])))
5294 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5295 warn("Illegal hexadecimal digit '%c' ignored", *s);
5299 if ( ( overflowed && value_nv > 4294967295.0)
5301 || (!overflowed && value > 0xffffffff )
5304 warn("Hexadecimal number > 0xffffffff non-portable");
5311 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5320 #if defined(NEED_grok_oct)
5321 static UV DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5324 extern UV DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result);
5330 #define grok_oct(a,b,c,d) DPPP_(grok_oct)(aTHX_ a,b,c,d)
5331 #define Perl_grok_oct DPPP_(grok_oct)
5333 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL)
5335 DPPP_(grok_oct)(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
5337 const char *s = start;
5338 STRLEN len = *len_p;
5342 const UV max_div_8 = UV_MAX / 8;
5343 bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
5344 bool overflowed = FALSE;
5346 for (; len-- && *s; s++) {
5347 /* gcc 2.95 optimiser not smart enough to figure that this subtraction
5348 out front allows slicker code. */
5349 int digit = *s - '0';
5350 if (digit >= 0 && digit <= 7) {
5351 /* Write it in this wonky order with a goto to attempt to get the
5352 compiler to make the common case integer-only loop pretty tight.
5356 if (value <= max_div_8) {
5357 value = (value << 3) | digit;
5360 /* Bah. We're just overflowed. */
5361 warn("Integer overflow in octal number");
5363 value_nv = (NV) value;
5366 /* If an NV has not enough bits in its mantissa to
5367 * represent a UV this summing of small low-order numbers
5368 * is a waste of time (because the NV cannot preserve
5369 * the low-order bits anyway): we could just remember when
5370 * did we overflow and in the end just multiply value_nv by the
5371 * right amount of 8-tuples. */
5372 value_nv += (NV)digit;
5375 if (digit == ('_' - '0') && len && allow_underscores
5376 && (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
5382 /* Allow \octal to work the DWIM way (that is, stop scanning
5383 * as soon as non-octal characters are seen, complain only iff
5384 * someone seems to want to use the digits eight and nine). */
5385 if (digit == 8 || digit == 9) {
5386 if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
5387 warn("Illegal octal digit '%c' ignored", *s);
5392 if ( ( overflowed && value_nv > 4294967295.0)
5394 || (!overflowed && value > 0xffffffff )
5397 warn("Octal number > 037777777777 non-portable");
5404 *flags = PERL_SCAN_GREATER_THAN_UV_MAX;
5412 #endif /* _P_P_PORTABILITY_H_ */
5414 /* End of File ppport.h */
projects / p5sagit/p5-mst-13.2.git / blob