From 28c620fd502b210b4b9431b48dd29e135a4676de Mon Sep 17 00:00:00 2001 From: DongHun Kwak Date: Wed, 28 Jun 2017 10:34:55 +0900 Subject: [PATCH] Imported Upstream version 5.21.4 Change-Id: I98436d2d36304c790b3f9fe4aef9903374e37300 Signed-off-by: DongHun Kwak --- .gitignore | 9 + AUTHORS | 5 +- Configure | 3838 +++++++++++--------- Cross/config.sh-arm-linux | 54 +- Cross/config.sh-arm-linux-n770 | 40 +- INSTALL | 50 +- MANIFEST | 17 +- META.json | 2 +- META.yml | 2 +- Makefile.SH | 44 +- NetWare/Makefile | 4 +- NetWare/config.wc | 14 + NetWare/config_H.wc | 10 +- Porting/Glossary | 65 +- Porting/Maintainers.pl | 59 +- Porting/bisect-runner.pl | 2 +- Porting/bisect.pl | 2 +- Porting/cmpVERSION.pl | 2 +- Porting/config.sh | 56 +- Porting/config_H | 18 +- Porting/epigraphs.pod | 130 + Porting/perldelta_template.pod | 2 +- Porting/release_announcement_template.txt | 6 +- Porting/release_schedule.pod | 19 +- Porting/todo.pod | 21 +- README.haiku | 4 +- README.macosx | 8 +- README.os2 | 2 +- README.vms | 4 +- TestInit.pm | 11 +- cflags.SH | 15 + config_h.SH | 111 +- configpm | 18 + configure.com | 30 +- cpan/Archive-Tar/lib/Archive/Tar.pm | 2 +- cpan/Archive-Tar/lib/Archive/Tar/Constant.pm | 2 +- cpan/Archive-Tar/lib/Archive/Tar/File.pm | 2 +- cpan/Archive-Tar/t/08_ptargrep.t | 8 +- .../lib/CPAN/Meta/Requirements.pm | 59 +- cpan/Digest-SHA/src/sdf.c | 100 + cpan/ExtUtils-Install/Changes | 352 -- cpan/ExtUtils-Install/lib/ExtUtils/Install.pm | 4 +- cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm | 2 +- cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm | 2 +- .../ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm | 8 +- cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm | 6 +- cpan/ExtUtils-Manifest/t/Manifest.t | 18 +- cpan/HTTP-Tiny/lib/HTTP/Tiny.pm | 77 +- cpan/HTTP-Tiny/t/140_proxy.t | 2 + cpan/HTTP-Tiny/t/Util.pm | 2 + cpan/IO-Socket-IP/lib/IO/Socket/IP.pm | 105 +- cpan/IO-Socket-IP/t/02local-server-v4.t | 1 + cpan/IO-Socket-IP/t/03local-cross-v4.t | 1 + cpan/IO-Socket-IP/t/05local-server-v6.t | 1 + cpan/IO-Socket-IP/t/06local-cross-v6.t | 1 + cpan/IO-Socket-IP/t/15io-socket.t | 2 + cpan/IO-Socket-IP/t/16v6only.t | 4 + cpan/IO-Socket-IP/t/22timeout.t | 29 + cpan/Locale-Codes/lib/Locale/Codes.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Changes.pod | 4 +- cpan/Locale-Codes/lib/Locale/Codes/Constants.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Country.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Country.pod | 8 +- .../Locale-Codes/lib/Locale/Codes/Country_Codes.pm | 4 +- .../lib/Locale/Codes/Country_Retired.pm | 4 +- cpan/Locale-Codes/lib/Locale/Codes/Currency.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Currency.pod | 8 +- .../lib/Locale/Codes/Currency_Codes.pm | 14 +- .../lib/Locale/Codes/Currency_Retired.pm | 6 +- cpan/Locale-Codes/lib/Locale/Codes/LangExt.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/LangExt.pod | 8 +- .../Locale-Codes/lib/Locale/Codes/LangExt_Codes.pm | 4 +- .../lib/Locale/Codes/LangExt_Retired.pm | 4 +- cpan/Locale-Codes/lib/Locale/Codes/LangFam.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/LangFam.pod | 8 +- .../Locale-Codes/lib/Locale/Codes/LangFam_Codes.pm | 4 +- .../lib/Locale/Codes/LangFam_Retired.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/LangVar.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/LangVar.pod | 8 +- .../Locale-Codes/lib/Locale/Codes/LangVar_Codes.pm | 4 +- .../lib/Locale/Codes/LangVar_Retired.pm | 4 +- cpan/Locale-Codes/lib/Locale/Codes/Language.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Language.pod | 8 +- .../lib/Locale/Codes/Language_Codes.pm | 4 +- .../lib/Locale/Codes/Language_Retired.pm | 4 +- cpan/Locale-Codes/lib/Locale/Codes/Script.pm | 2 +- cpan/Locale-Codes/lib/Locale/Codes/Script.pod | 8 +- cpan/Locale-Codes/lib/Locale/Codes/Script_Codes.pm | 4 +- .../lib/Locale/Codes/Script_Retired.pm | 4 +- cpan/Locale-Codes/lib/Locale/Country.pm | 2 +- cpan/Locale-Codes/lib/Locale/Country.pod | 8 +- cpan/Locale-Codes/lib/Locale/Currency.pm | 2 +- cpan/Locale-Codes/lib/Locale/Currency.pod | 8 +- cpan/Locale-Codes/lib/Locale/Language.pm | 2 +- cpan/Locale-Codes/lib/Locale/Language.pod | 8 +- cpan/Locale-Codes/lib/Locale/Script.pm | 2 +- cpan/Locale-Codes/lib/Locale/Script.pod | 8 +- cpan/Pod-Perldoc/lib/Pod/Perldoc.pm | 11 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/BaseTo.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToANSI.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToChecker.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToNroff.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToPod.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToRtf.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTerm.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToText.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm | 2 +- cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm | 2 +- cpan/Scalar-List-Utils/ListUtil.xs | 206 +- cpan/Scalar-List-Utils/lib/List/Util.pm | 112 +- cpan/Scalar-List-Utils/lib/List/Util/XS.pm | 2 +- cpan/Scalar-List-Utils/lib/Scalar/Util.pm | 83 +- cpan/Scalar-List-Utils/lib/Sub/Util.pm | 149 + cpan/Scalar-List-Utils/t/prototype.t | 40 + cpan/Scalar-List-Utils/t/reduce.t | 5 +- .../t/{proto.t => scalarutil-proto.t} | 0 cpan/Scalar-List-Utils/t/subname.t | 81 + cpan/Test-Harness/lib/App/Prove.pm | 4 +- cpan/Test-Harness/lib/App/Prove/State.pm | 4 +- cpan/Test-Harness/lib/App/Prove/State/Result.pm | 4 +- .../lib/App/Prove/State/Result/Test.pm | 4 +- cpan/Test-Harness/lib/TAP/Base.pm | 4 +- cpan/Test-Harness/lib/TAP/Formatter/Base.pm | 4 +- cpan/Test-Harness/lib/TAP/Formatter/Color.pm | 4 +- cpan/Test-Harness/lib/TAP/Formatter/Console.pm | 4 +- .../lib/TAP/Formatter/Console/ParallelSession.pm | 4 +- .../lib/TAP/Formatter/Console/Session.pm | 4 +- cpan/Test-Harness/lib/TAP/Formatter/File.pm | 6 +- .../Test-Harness/lib/TAP/Formatter/File/Session.pm | 4 +- cpan/Test-Harness/lib/TAP/Formatter/Session.pm | 4 +- cpan/Test-Harness/lib/TAP/Harness.pm | 4 +- cpan/Test-Harness/lib/TAP/Harness/Env.pm | 34 +- cpan/Test-Harness/lib/TAP/Object.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Grammar.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Iterator.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm | 4 +- .../lib/TAP/Parser/Iterator/Process.pm | 4 +- .../Test-Harness/lib/TAP/Parser/Iterator/Stream.pm | 4 +- .../Test-Harness/lib/TAP/Parser/IteratorFactory.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm | 6 +- cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm | 4 +- .../lib/TAP/Parser/Scheduler/Spinner.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/Source.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm | 4 +- .../lib/TAP/Parser/SourceHandler/Executable.pm | 4 +- .../lib/TAP/Parser/SourceHandler/File.pm | 4 +- .../lib/TAP/Parser/SourceHandler/Handle.pm | 4 +- .../lib/TAP/Parser/SourceHandler/Perl.pm | 4 +- .../lib/TAP/Parser/SourceHandler/RawTAP.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm | 4 +- cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm | 4 +- cpan/Test-Harness/lib/Test/Harness.pm | 4 +- cpan/Test-Simple/lib/Test/Builder.pm | 41 +- cpan/Test-Simple/lib/Test/Builder/Module.pm | 42 +- cpan/Test-Simple/lib/Test/Builder/Tester.pm | 38 +- cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm | 2 +- cpan/Test-Simple/lib/Test/More.pm | 141 +- cpan/Test-Simple/lib/Test/Simple.pm | 18 +- cpan/Test-Simple/lib/Test/Tutorial.pod | 38 +- cpan/Test-Simple/t/dont_overwrite_die_handler.t | 1 + cpan/Test-Simple/t/subtest/args.t | 19 + cpan/Time-HiRes/t/itimer.t | 6 +- cpan/Time-Piece/Piece.pm | 2 +- cpan/Time-Piece/Seconds.pm | 4 +- cpan/Time-Piece/t/02core.t | 9 +- cpan/experimental/lib/experimental.pm | 37 +- cpan/experimental/t/basic.t | 18 + cpan/version/lib/version.pm | 2 +- cpan/version/lib/version/regex.pm | 2 +- cpan/version/lib/version/vpp.pm | 2 +- cpan/version/t/00impl-pp.t | 2 +- cpan/version/t/01base.t | 2 +- cpan/version/t/02derived.t | 2 +- cpan/version/t/03require.t | 2 +- cpan/version/t/05sigdie.t | 2 +- cpan/version/t/06noop.t | 2 +- cpan/version/t/07locale.t | 2 +- cpan/version/t/08_corelist.t | 2 +- cpan/version/t/09_list_util.t | 2 +- cv.h | 21 +- dist/Attribute-Handlers/lib/Attribute/Handlers.pm | 12 +- dist/Data-Dumper/Dumper.pm | 27 +- dist/Data-Dumper/Dumper.xs | 32 +- dist/Data-Dumper/t/recurse.t | 45 + dist/ExtUtils-CBuilder/Changes | 19 + dist/ExtUtils-CBuilder/Makefile.PL | 9 +- dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm | 6 +- .../lib/ExtUtils/CBuilder/Base.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Unix.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/VMS.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Windows.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm | 7 +- .../lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/aix.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/android.pm | 6 +- .../lib/ExtUtils/CBuilder/Platform/cygwin.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/darwin.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/dec_osf.pm | 5 +- .../lib/ExtUtils/CBuilder/Platform/os2.pm | 5 +- dist/ExtUtils-CBuilder/t/00-have-compiler.t | 1 + dist/ExtUtils-ParseXS/lib/perlxs.pod | 92 + dist/IO/IO.pm | 2 +- dist/IO/IO.xs | 4 + dist/IO/t/io_linenum.t | 30 +- dist/Math-BigInt/lib/Math/BigFloat.pm | 2 +- dist/Math-BigInt/lib/Math/BigInt.pm | 24 +- dist/Math-BigInt/lib/Math/BigInt/Calc.pm | 2 +- dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm | 2 +- dist/Module-CoreList/Changes | 6 + dist/Module-CoreList/lib/Module/CoreList.pm | 252 +- dist/Module-CoreList/lib/Module/CoreList.pod | 3 +- .../lib/Module/CoreList/TieHashDelta.pm | 2 +- dist/Module-CoreList/lib/Module/CoreList/Utils.pm | 16 +- dist/Module-CoreList/t/corevers.t | 21 - dist/PathTools/Cwd.pm | 4 +- dist/PathTools/Cwd.xs | 2 +- dist/PathTools/lib/File/Spec.pm | 2 +- dist/PathTools/lib/File/Spec/Cygwin.pm | 2 +- dist/PathTools/lib/File/Spec/Epoc.pm | 2 +- dist/PathTools/lib/File/Spec/Functions.pm | 2 +- dist/PathTools/lib/File/Spec/Mac.pm | 2 +- dist/PathTools/lib/File/Spec/OS2.pm | 2 +- dist/PathTools/lib/File/Spec/Unix.pm | 4 +- dist/PathTools/lib/File/Spec/VMS.pm | 2 +- dist/PathTools/lib/File/Spec/Win32.pm | 2 +- dist/Safe/t/safeops.t | 1 - dist/Term-ReadLine/lib/Term/ReadLine.pm | 6 +- dist/bignum/lib/bigint.pm | 5 +- dist/bignum/lib/bignum.pm | 5 +- dist/bignum/lib/bigrat.pm | 5 +- dist/bignum/t/bn_lite.t | 3 +- dist/bignum/t/br_lite.t | 3 +- dist/bignum/t/option_l.t | 14 +- dist/constant/lib/constant.pm | 48 +- dist/constant/t/constant.t | 11 +- dist/threads/lib/threads.pm | 4 +- dist/threads/t/exit.t | 10 +- dist/threads/t/thread.t | 2 +- doop.c | 3 + dump.c | 378 +- embed.fnc | 57 +- embed.h | 36 +- embedvar.h | 3 + ext/B/B.pm | 21 +- ext/B/B.xs | 87 +- ext/B/B/Concise.pm | 162 +- ext/B/Makefile.PL | 1 + ext/B/t/b.t | 44 +- ext/B/t/concise-xs.t | 19 +- ext/B/t/f_map.t | 4 +- ext/B/t/optree_concise.t | 6 +- ext/B/t/optree_samples.t | 20 +- ext/B/t/optree_specials.t | 36 +- ext/Devel-Peek/t/Peek.t | 32 +- ext/File-Find/lib/File/Find.pm | 43 +- ext/File-Find/t/find.t | 42 +- ext/POSIX/Makefile.PL | 24 +- ext/POSIX/POSIX.xs | 1432 +++++++- ext/POSIX/lib/POSIX.pm | 22 +- ext/POSIX/lib/POSIX.pod | 312 +- ext/POSIX/t/export.t | 170 +- ext/POSIX/t/math.t | 97 + ext/POSIX/t/posix.t | 18 +- ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 7 + ext/XS-APItest/t/clone-with-stack.t | 15 +- ext/XS-APItest/t/cv_name.t | 29 + ext/XS-APItest/t/grok.t | 6 +- ext/XS-APItest/t/locale.t | 12 +- ext/XS-APItest/t/printf.t | 8 + ext/attributes/attributes.pm | 2 +- ext/attributes/attributes.xs | 2 +- ext/re/t/regop.t | 10 +- globvar.sym | 5 + gv.c | 180 +- gv.h | 22 +- handy.h | 28 +- hints/aix.sh | 104 +- hints/catamount.sh | 4 +- hints/darwin.sh | 20 +- hints/hpux.sh | 15 + hints/linux-android.sh | 12 +- inline.h | 8 + intrpvar.h | 12 +- l1_char_class_tab.h | 56 +- lib/.gitignore | 1 + lib/B/Deparse.pm | 103 +- lib/B/Deparse.t | 23 +- lib/B/Op_private.pm | 700 ++++ lib/Getopt/Std.pm | 6 +- lib/_charnames.pm | 4 +- lib/diagnostics.t | 2 +- lib/locale.t | 55 +- lib/overload.pm | 4 +- lib/overload.t | 19 +- lib/utf8_heavy.pl | 6 +- locale.c | 4 +- make_ext.pl | 6 +- makedef.pl | 5 + mathoms.c | 7 + metaconfig.h | 17 +- mg.c | 21 +- mg.h | 1 + mro.c | 14 +- numeric.c | 379 +- op.c | 559 ++- op.h | 232 +- opcode.h | 1354 +++++++ pad.c | 170 +- pad.h | 2 +- parser.h | 2 +- patchlevel.h | 4 +- perl.c | 13 +- perl.h | 695 +++- perly.act | 1096 +++--- perly.h | 64 +- perly.tab | 990 +++-- perly.y | 89 +- plan9/config.plan9 | 10 +- plan9/config_sh.sample | 52 +- pod/.gitignore | 2 +- pod/perl.pod | 2 + pod/perl5201delta.pod | 410 +++ pod/perl5213delta.pod | 422 +++ pod/perldata.pod | 5 +- pod/perldebguts.pod | 35 +- pod/perldelta.pod | 623 +++- pod/perldiag.pod | 88 +- pod/perlfork.pod | 2 +- pod/perlfunc.pod | 54 +- pod/perlgit.pod | 2 +- pod/perlguts.pod | 3 + pod/perlhist.pod | 7 +- pod/perllocale.pod | 14 +- pod/perlop.pod | 12 +- pod/perlpacktut.pod | 21 +- pod/perlpolicy.pod | 8 + pod/perlrecharclass.pod | 78 +- pod/perlsec.pod | 42 +- pod/perlsub.pod | 31 +- pod/perlsyn.pod | 15 +- pp.c | 137 +- pp.h | 3 +- pp_ctl.c | 116 +- pp_hot.c | 86 +- pp_pack.c | 19 +- pp_sort.c | 1 - pp_sys.c | 157 +- proto.h | 120 +- regcomp.c | 1373 ++++--- regcomp.h | 103 +- regcomp.sym | 35 +- regen/mk_PL_charclass.pl | 4 + regen/op_private | 716 ++++ regen/opcode.pl | 801 +++- regen/opcodes | 18 +- regen/regcomp.pl | 22 +- regen/regen_lib.pl | 20 + regen/unicode_constants.pl | 9 + regexec.c | 163 +- regnodes.h | 405 +-- scope.c | 34 +- scope.h | 4 +- sv.c | 901 +++-- sv.h | 15 +- symbian/config.sh | 14 + t/base/lex.t | 12 +- t/comp/fold.t | 11 +- t/comp/hints.t | 9 +- t/comp/proto.t | 4 +- t/comp/require.t | 2 +- t/harness | 9 + t/io/fs.t | 5 +- t/io/open.t | 36 +- t/lib/strict/subs | 4 +- t/lib/strict/vars | 82 +- t/lib/warnings/mg | 23 + t/lib/warnings/regcomp | 25 +- t/lib/warnings/sv | 4 +- t/lib/warnings/toke | 24 +- t/op/anonsub.t | 20 + t/op/avhv.t | 4 +- t/op/blocks.t | 2 +- t/op/caller.t | 4 +- t/op/chdir.t | 11 +- t/op/closure.t | 2 +- t/op/coreamp.t | 2 +- t/op/coresubs.t | 3 + t/op/eval.t | 2 +- t/op/exp.t | 94 +- t/op/filetest.t | 2 +- t/op/gv.t | 39 +- t/op/hash.t | 2 +- t/op/hexfp.t | 16 +- t/op/inc.t | 3 +- t/op/inccode.t | 2 +- t/op/index.t | 5 +- t/op/infnan.t | 194 + t/op/kvaslice.t | 2 +- t/op/kvhslice.t | 2 +- t/op/lc.t | 6 +- t/op/length.t | 2 +- t/op/lexsub.t | 180 +- t/op/magic.t | 5 +- t/op/method.t | 2 +- t/op/mkdir.t | 16 +- t/op/my_stash.t | 2 +- t/op/override.t | 2 +- t/op/pack.t | 2 +- t/op/packagev.t | 2 +- t/op/push.t | 2 +- t/op/readline.t | 2 +- t/op/reverse.t | 2 +- t/op/smartkve.t | 2 +- t/op/smartmatch.t | 2 +- t/op/sort.t | 4 +- t/op/split.t | 9 +- t/op/sprintf.t | 2 +- t/op/sprintf2.t | 113 +- t/op/stash.t | 11 +- t/op/sub.t | 16 +- t/op/substr.t | 5 +- t/op/symbolcache.t | 2 +- t/op/taint.t | 21 +- t/op/tie.t | 2 + t/op/tie_fetch_count.t | 2 +- t/op/tiehandle.t | 4 +- t/op/tr.t | 2 +- t/op/undef.t | 19 +- t/op/universal.t | 3 +- t/op/utftaint.t | 10 +- t/op/vec.t | 4 +- t/op/warn.t | 2 +- t/op/write.t | 2 +- t/op/yadayada.t | 31 +- t/opbasic/arith.t | 10 +- t/porting/corelist.t | 19 +- t/porting/customized.dat | 6 +- t/porting/diag.t | 3 +- t/porting/dual-life.t | 2 +- t/porting/known_pod_issues.dat | 4 +- t/porting/libperl.t | 34 +- t/porting/readme.t | 12 +- t/porting/regen.t | 2 +- t/re/charset.t | 2 +- t/re/overload.t | 2 +- t/re/pat.t | 30 +- t/re/pat_advanced.t | 5 +- t/re/pat_re_eval.t | 2 +- t/re/reg_eval_scope.t | 2 +- t/re/reg_mesg.t | 109 +- t/re/regex_sets.t | 3 +- t/re/regexp.t | 7 +- t/re/rt122747.t | 29 + t/re/rxcode.t | 2 +- t/re/subst.t | 4 +- t/re/uniprops.t | 13 +- t/run/fresh_perl.t | 2 + t/run/runenv.t | 4 +- t/run/switchM.t | 6 +- t/run/switches.t | 7 +- t/test.pl | 13 + t/uni/cache.t | 5 +- t/uni/case.pl | 6 +- t/uni/class.t | 5 +- t/uni/fold.t | 5 +- t/uni/gv.t | 7 +- t/uni/labels.t | 3 +- t/uni/lex_utf8.t | 9 +- t/uni/lower.t | 3 +- t/uni/method.t | 2 +- t/uni/opcroak.t | 4 +- t/uni/parser.t | 8 +- t/uni/readline.t | 2 +- t/uni/stash.t | 2 +- t/uni/title.t | 3 +- t/uni/universal.t | 2 +- t/uni/upper.t | 3 +- t/uni/variables.t | 1 + t/win32/runenv.t | 4 +- time64.c | 19 +- toke.c | 325 +- uconfig.h | 115 +- uconfig.sh | 14 + uconfig64.sh | 14 + unicode_constants.h | 12 + universal.c | 10 +- utf8.c | 26 +- utf8.h | 3 +- util.c | 173 +- vms/descrip_mms.template | 2 +- vms/vmsish.h | 2 +- win32/Makefile | 7 +- win32/config.ce | 14 + win32/config.gc | 14 + win32/config.vc | 14 + win32/config_H.gc | 255 +- win32/config_H.vc | 255 +- win32/config_sh.PL | 26 +- win32/makefile.mk | 19 +- win32/pod.mak | 8 + 517 files changed, 19999 insertions(+), 8247 deletions(-) create mode 100644 cpan/Digest-SHA/src/sdf.c delete mode 100644 cpan/ExtUtils-Install/Changes create mode 100644 cpan/IO-Socket-IP/t/22timeout.t create mode 100644 cpan/Scalar-List-Utils/lib/Sub/Util.pm create mode 100644 cpan/Scalar-List-Utils/t/prototype.t rename cpan/Scalar-List-Utils/t/{proto.t => scalarutil-proto.t} (100%) create mode 100644 cpan/Scalar-List-Utils/t/subname.t create mode 100644 dist/Data-Dumper/t/recurse.t delete mode 100644 dist/Module-CoreList/t/corevers.t create mode 100644 ext/XS-APItest/t/cv_name.t create mode 100644 lib/B/Op_private.pm create mode 100644 pod/perl5201delta.pod create mode 100644 pod/perl5213delta.pod create mode 100644 regen/op_private create mode 100644 t/op/infnan.t create mode 100644 t/re/rt122747.t diff --git a/.gitignore b/.gitignore index cee08f6..93ac2ac 100644 --- a/.gitignore +++ b/.gitignore @@ -181,3 +181,12 @@ MANIFEST.new # generated by the top level install.html target. XXX Why does it need this? /vms/README_vms.pod + +# ctags +tags +TAGS +# gtags +GPATH +GRPATH +GRTAGS +GTAGS diff --git a/AUTHORS b/AUTHORS index 934c50c..bc8aad5 100644 --- a/AUTHORS +++ b/AUTHORS @@ -48,6 +48,7 @@ Albert Chin-A-Young Albert Dvornik Alberto Simões Alessandro Forghieri +Alexandre (Midnite) Jousset Alexander Alekseev Alexander Hartmaier Alexander Voronov @@ -101,6 +102,7 @@ Andy Dougherty Andy Lester Anno Siegel Anthony David +Anthony Heading Anton Berezin Anton Nikishaev Anton Tagunov @@ -204,7 +206,7 @@ Charles F. Randall Charles Lane Charles Randall Charles Wilson -Charlie Gonzalez +Charlie Gonzalez Chas. Owens Chaskiel M Grundman Chia-liang Kao @@ -1126,6 +1128,7 @@ Sven Strickroth Sven Verdoolaege syber SynaptiCAD, Inc. +Tadeusz Sośnierz Takis Psarogiannakopoulos Taro KAWAGISHI Tassilo von Parseval diff --git a/Configure b/Configure index aab3f03..343e062 100755 --- a/Configure +++ b/Configure @@ -372,6 +372,7 @@ cppstdin='' d__fwalk='' d_access='' d_accessx='' +d_acosh='' d_aintl='' d_alarm='' asctime_r_proto='' @@ -461,6 +462,7 @@ d_fcntl_can_lock='' d_fd_macros='' d_fd_set='' d_fds_bits='' +d_fegetround='' d_fgetpos='' d_finite='' d_finitel='' @@ -469,9 +471,12 @@ d_flock='' d_flockproto='' d_fork='' d_fp_class='' +d_fp_classl='' d_fpclass='' +d_fp_classify='' d_fpclassify='' d_fpclassl='' +d_fpgetround='' d_fpos64_t='' d_frexpl='' d_fs_data_s='' @@ -579,13 +584,16 @@ d_int64_t='' d_isascii='' d_isblank='' d_isfinite='' +d_isfinitel='' d_isinf='' +d_isinfl='' d_isnan='' d_isnanl='' +d_j0='' +d_j0l='' d_killpg='' d_lchown='' d_ldbl_dig='' -d_ldexpl='' d_libm_lib_version='' d_link='' d_localtime_r='' @@ -593,6 +601,7 @@ d_localtime_r_needs_tzset='' localtime_r_proto='' d_locconv='' d_lockf='' +d_ldexpl='' d_longdbl='' longdblkind='' longdblsize='' @@ -826,6 +835,7 @@ d_times='' d_tmpnam_r='' tmpnam_r_proto='' d_truncate='' +d_truncl='' d_ttyname_r='' ttyname_r_proto='' d_tzname='' @@ -904,6 +914,7 @@ i_dirent='' i_dlfcn='' i_execinfo='' i_fcntl='' +i_fenv='' i_float='' i_fp='' i_fp_class='' @@ -946,10 +957,12 @@ d_pwgecos='' d_pwpasswd='' d_pwquota='' i_pwd='' +i_quadmath='' i_shadow='' i_socks='' i_stdbool='' i_stddef='' +i_stdint='' i_stdlib='' i_string='' strings='' @@ -1247,6 +1260,7 @@ libswanted_uselargefiles='' uselargefiles='' uselongdouble='' usemorebits='' +usequadmath='' usemultiplicity='' nm_opt='' nm_so_opt='' @@ -2651,11 +2665,11 @@ EOM # The most common problem is -D_REENTRANT for threads. # This heuristic catches that case, but gets false positives # if -Dusethreads was not actually specified. Better to - # bail out here with a useful message than fail + # bail out here with a useful message than fail # mysteriously later. Should we perhaps just try to # re-invoke Configure -Dcc=gcc config_args ? if $test -f usethreads.cbu; then - $cat >&4 <&4 <&2 exit 1 fi - fi + fi case "$ans" in [yY]*) cc=gcc; ccname=gcc; ccflags=''; despair=no; esac @@ -2693,9 +2707,9 @@ cat <checkcc $startsh EOS cat <<'EOSC' >>checkcc -case "$cc" in +case "$cc" in '') ;; -*) $rm -f try try.* +*) $rm -f try try.* $cat >try.c <&4 fi - $cat >&4 <&4 </dev/null|sed -n '$p'` $test -f "$xxx" && eval $libscheck $test -f "$xxx" && libstyle=shared + xxx=`ls $thisdir/lib$thislib.[0-9].$so 2>/dev/null|sed -n '$p'` + $test -f "$xxx" && eval $libscheck + $test -f "$xxx" && libstyle=shared fi if test ! -f "$xxx"; then xxx=$thisdir/lib$thislib.$so @@ -5369,8 +5399,15 @@ default|recommended) # as that way the compiler can do the right implementation dependant # thing. (NWC) case "$gccversion" in - ?*) set stack-protector -fstack-protector + ?*) set stack-protector-strong -fstack-protector-strong eval $checkccflag + case "$dflt" in + *-fstack-protector-strong*) ;; # It got added. + *) # Try the plain/older -fstack-protector. + set stack-protector -fstack-protector + eval $checkccflag + ;; + esac ;; esac ;; @@ -5513,6 +5550,12 @@ case "$ldflags" in esac # See note above about -fstack-protector case "$ccflags" in +*-fstack-protector-strong*) + case "$dflt" in + *-fstack-protector-strong*) ;; # Don't add it again + *) dflt="$dflt -fstack-protector-strong" ;; + esac + ;; *-fstack-protector*) case "$dflt" in *-fstack-protector*) ;; # Don't add it again @@ -6192,1858 +6235,1958 @@ EOF ;; esac -: check for length of double +: Check if we are using the GNU C library echo " " -case "$doublesize" in -'') - echo "Checking to see how big your double precision numbers are..." >&4 - $cat >try.c <&4 +cat >try.c <<'EOCP' +/* Find out version of GNU C library. __GLIBC__ and __GLIBC_MINOR__ + alone are insufficient to distinguish different versions, such as + 2.0.6 and 2.0.7. The function gnu_get_libc_version() appeared in + libc version 2.1.0. A. Dougherty, June 3, 2002. +*/ #include -#$i_stdlib I_STDLIB -#ifdef I_STDLIB -#include -#endif -int main() +int main(void) { - printf("%d\n", (int)sizeof(double)); - exit(0); +#ifdef __GLIBC__ +# ifdef __GLIBC_MINOR__ +# if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && !defined(__cplusplus) +# include + printf("%s\n", gnu_get_libc_version()); +# else + printf("%d.%d\n", __GLIBC__, __GLIBC_MINOR__); +# endif +# else + printf("%d\n", __GLIBC__); +# endif + return 0; +#else + return 1; +#endif } EOCP - set try - if eval $compile_ok; then - doublesize=`$run ./try` - echo "Your double is $doublesize bytes long." - else - dflt='8' - echo "(I can't seem to compile the test program. Guessing...)" - rp="What is the size of a double precision number (in bytes)?" - . ./myread - doublesize="$ans" - fi - ;; -esac -$rm_try - -: check for long doubles -echo " " -echo "Checking to see if you have long double..." >&4 -echo 'int main() { long double x = 7.0; }' > try.c set try -if eval $compile; then +if eval $compile_ok && $run ./try > glibc.ver; then val="$define" - echo "You have long double." + gnulibc_version=`$cat glibc.ver` + echo "You are using the GNU C Library version $gnulibc_version" else val="$undef" - echo "You do not have long double." + gnulibc_version='' + echo "You are not using the GNU C Library" fi -$rm_try -set d_longdbl +$rm_try glibc.ver +set d_gnulibc eval $setvar -: check for length of long double -case "${d_longdbl}${longdblsize}" in -$define) - echo " " - echo "Checking to see how big your long doubles are..." >&4 - $cat >try.c <<'EOCP' -#include -int main() -{ - printf("%d\n", sizeof(long double)); -} -EOCP - set try - set try - if eval $compile; then - longdblsize=`$run ./try` - echo "Your long doubles are $longdblsize bytes long." - else - dflt='8' +: see if nm is to be used to determine whether a symbol is defined or not +case "$usenm" in +'') + dflt='' + case "$d_gnulibc" in + "$define") echo " " - echo "(I can't seem to compile the test program. Guessing...)" >&4 - rp="What is the size of a long double (in bytes)?" - . ./myread - longdblsize="$ans" - fi - if $test "X$doublesize" = "X$longdblsize"; then - echo "That isn't any different from an ordinary double." - echo "I'll keep your setting anyway, but you may see some" - echo "harmless compilation warnings." - fi + echo "nm probably won't work on the GNU C Library." >&4 + dflt=n + ;; + esac + case "$dflt" in + '') + if $test "$osname" = aix -a "X$PASE" != "Xdefine" -a ! -f /lib/syscalls.exp; then + echo " " + echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4 + echo "'nm' won't be sufficient on this system." >&4 + dflt=n + fi + ;; + esac + case "$dflt" in + '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` + if $test $dflt -gt 20; then + dflt=y + else + dflt=n + fi + ;; + esac ;; -esac -$rm_try - -: determine the architecture name -echo " " -if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then - tarch=`arch`"-$osname" -elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then - if uname -m > tmparch 2>&1 ; then - tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \ - -e 's/$/'"-$osname/" tmparch` - else - tarch="$osname" - fi - $rm -f tmparch -else - tarch="$osname" -fi -case "$myarchname" in -''|"$tarch") ;; *) - echo "(Your architecture name used to be $myarchname.)" - archname='' + case "$usenm" in + true|$define) dflt=y;; + *) dflt=n;; + esac ;; esac -case "$targetarch" in -'') ;; -*) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;; -esac -myarchname="$tarch" -case "$archname" in -'') dflt="$tarch";; -*) dflt="$archname";; -esac -rp='What is your architecture name' -. ./myread -archname="$ans" +$cat <&4 - ;; - *) - archname="$archname-$api_versionstring" - echo "...setting architecture name to $archname." >&4 - ;; - esac - ;; + +runnm=$usenm +case "$reuseval" in +true) runnm=false;; esac -case "$usethreads" in -$define) - echo "Threads selected." >&4 - case "$archname" in - *-thread*) echo "...and architecture name already has -thread." >&4 - ;; - *) archname="$archname-thread" - echo "...setting architecture name to $archname." >&4 - ;; - esac +: nm options which may be necessary +case "$nm_opt" in +'') if $test -f /mach_boot; then + nm_opt='' # Mach + elif $test -d /usr/ccs/lib; then + nm_opt='-p' # Solaris (and SunOS?) + elif $test -f /dgux; then + nm_opt='-p' # DG-UX + elif $test -f /lib64/rld; then + nm_opt='-p' # 64-bit Irix + else + nm_opt='' + fi;; +esac + +: nm options which may be necessary for shared libraries but illegal +: for archive libraries. Thank you, Linux. +case "$nm_so_opt" in +'') case "$myuname" in + *linux*|gnu*) + if $nm --help | $grep 'dynamic' > /dev/null 2>&1; then + nm_so_opt='--dynamic' + fi + ;; + esac ;; esac -case "$usemultiplicity" in -$define) - echo "Multiplicity selected." >&4 - case "$archname" in - *-multi*) echo "...and architecture name already has -multi." >&4 - ;; - *) archname="$archname-multi" - echo "...setting architecture name to $archname." >&4 - ;; - esac - ;; -esac -case "$use64bitint$use64bitall" in -*"$define"*) - case "$archname64" in - '') - echo "This architecture is naturally 64-bit, not changing architecture name." >&4 - ;; - *) - case "$use64bitint" in - "$define") echo "64 bit integers selected." >&4 ;; - esac - case "$use64bitall" in - "$define") echo "Maximal 64 bitness selected." >&4 ;; - esac - case "$archname" in - *-$archname64*) echo "...and architecture name already has $archname64." >&4 - ;; - *) archname="$archname-$archname64" - echo "...setting architecture name to $archname." >&4 - ;; - esac - ;; + +: Figure out where the libc is located +case "$runnm" in +true) +: get list of predefined functions in a handy place +echo " " +case "$libc" in +'') libc=unknown + case "$libs" in + *-lc_s*) libc=`./loc libc_s$_a $libc $libpth` esac + ;; esac -case "$uselongdouble" in -$define) - echo "Long doubles selected." >&4 - case "$longdblsize" in - $doublesize) - echo "...but long doubles are equal to doubles, not changing architecture name." >&4 +case "$libs" in +'') ;; +*) for thislib in $libs; do + case "$thislib" in + -lc|-lc_s) + : Handle C library specially below. ;; - *) - case "$archname" in - *-ld*) echo "...and architecture name already has -ld." >&4 - ;; - *) archname="$archname-ld" - echo "...setting architecture name to $archname." >&4 - ;; - esac + -l*) + thislib=`echo $thislib | $sed -e 's/^-l//'` + if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then + : + elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc $thislib X $libpth`; $test -f "$try"; then + : + elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then + : + else + try='' + fi + libnames="$libnames $try" ;; + *) libnames="$libnames $thislib" ;; esac + done ;; esac -if $test -f archname.cbu; then - echo "Your platform has some specific hints for architecture name, using them..." - . ./archname.cbu -fi - -: set the prefixit variable, to compute a suitable default value -prefixit='case "$3" in -""|none) - case "$oldprefix" in - "") eval "$1=\"\$$2\"";; - *) - case "$3" in - "") eval "$1=";; - none) - eval "tp=\"\$$2\""; - case "$tp" in - ""|" ") eval "$1=\"\$$2\"";; - *) eval "$1=";; - esac;; - esac;; - esac;; +xxx=normal +case "$libc" in +unknown) + set /lib/libc.$so + for xxx in $libpth; do + $test -r $1 || set $xxx/libc.$so + : The messy sed command sorts on library version numbers. + $test -r $1 || \ + set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \ + tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e ' + h + s/[0-9][0-9]*/0000&/g + s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g + G + s/\n/ /' | \ + $sort | $sed -e 's/^.* //'` + eval set \$$# + done + $test -r $1 || set $sysroot/usr/ccs/lib/libc.$so + $test -r $1 || set $sysroot/lib/libsys_s$_a + ;; *) - eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\""; - case "$tp" in - --|/*--|\~*--) eval "$1=\"$prefix/$3\"";; - /*-$oldprefix/*|\~*-$oldprefix/*) - eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";; - *) eval "$1=\"\$$2\"";; - esac;; -esac' - -: determine installation style -: For now, try to deduce it from prefix unless it is already set. -: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7. -case "$installstyle" in -'') case "$prefix" in - *perl*) dflt='lib';; - *) dflt='lib/perl5' ;; - esac + set blurfl ;; -*) dflt="$installstyle" ;; esac -: Probably not worth prompting for this since we prompt for all -: the directories individually, and the prompt would be too long and -: confusing anyway. -installstyle=$dflt - -: determine where public executables go -echo " " -set dflt bin bin -eval $prefixit -fn=d~ -rp='Pathname where the public executables will reside?' -. ./getfile -if $test "X$ansexp" != "X$binexp"; then - installbin='' +if $test -r "$1"; then + echo "Your (shared) C library seems to be in $1." + libc="$1" +elif $test -r /lib/libc && $test -r /lib/clib; then + echo "Your C library seems to be in both /lib/clib and /lib/libc." + xxx=apollo + libc='/lib/clib /lib/libc' + if $test -r /lib/syslib; then + echo "(Your math library is in /lib/syslib.)" + libc="$libc /lib/syslib" + fi +elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + echo "Your C library seems to be in $libc, as you said before." +elif $test -r $incpath/usr/lib/libc$_a; then + libc=$incpath/usr/lib/libc$_a; + echo "Your C library seems to be in $libc. That's fine." +elif $test -r /lib/libc$_a; then + libc=/lib/libc$_a; + echo "Your C library seems to be in $libc. You're normal." +else + if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then + : + elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then + libnames="$libnames "`./loc clib blurfl/dyick $libpth` + elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then + : + elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then + : + elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then + : + else + tans=`./loc Llibc$_a blurfl/dyick $xlibpth` + fi + if $test -r "$tans"; then + echo "Your C library seems to be in $tans, of all places." + libc=$tans + else + libc='blurfl' + fi fi -prefixvar=bin -: XXX Bug? -- ignores Configure -Dinstallprefix setting. -: XXX If this is fixed, also fix the "start perl" hunk below, which relies on -: this via initialinstalllocation -. ./setprefixvar +if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then + dflt="$libc" + cat < libpath + cat >&4 < libnames +set X `cat libnames` +shift +xxx=files +case $# in 1) xxx=file; esac +echo "Extracting names from the following $xxx for later perusal:" >&4 +echo " " +$sed 's/^/ /' libnames >&4 +echo " " +$echo $n "This may take a while...$c" >&4 -$spackage contains architecture-dependent library files. If you are -sharing libraries in a heterogeneous environment, you might store -these files in a separate location. Otherwise, you can just include -them with the rest of the public library files. +for file in $*; do + case $file in + *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;; + *) $nm $nm_opt $file 2>/dev/null;; + esac +done >libc.tmp -EOM -fn=$binexp -fn=d+~ -rp='Where do you want to put the public architecture-dependent libraries?' -. ./getfile -prefixvar=archlib -. ./setprefixvar -if $test X"$archlib" = X"$privlib"; then - d_archlib="$undef" +$echo $n ".$c" +$grep fprintf libc.tmp > libc.ptf +xscan='eval "libc.list"; $echo $n ".$c" >&4' +xrun='eval "libc.list"; echo "done." >&4' +xxx='[ADTSIWi]' +if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ + -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun +elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ + eval $xscan;\ + $contains '^fprintf$' libc.list >/dev/null 2>&1; then + eval $xrun else - d_archlib="$define" -fi - -: see if setuid scripts can be secure -$cat <reflect - chmod +x,u+s reflect - ./reflect >flect 2>&1 - if $contains "/dev/fd" flect >/dev/null; then - echo "Congratulations, your kernel has secure setuid scripts!" >&4 - val="$define" + $nm -p $* 2>/dev/null >libc.tmp + $grep fprintf libc.tmp > libc.ptf + if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\ + eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1 + then + nm_opt='-p' + eval $xrun else - $cat <&4 - dflt=n;; - "$undef") - echo "Well, the $hint value is *not* secure." >&4 - dflt=n;; - *) echo "Well, the $hint value *is* secure." >&4 - dflt=y;; - esac - ;; - *) - $rm -f reflect flect - echo "#!$ls" >reflect - chmod +x,u+s reflect - echo >flect - chmod a+w flect - echo '"su" will (probably) prompt you for '"$ans's password." - su $ans -c './reflect >flect' - if $contains "/dev/fd" flect >/dev/null; then - echo "Okay, it looks like setuid scripts are secure." >&4 - dflt=y + echo " " + echo "$nm didn't seem to work right. Trying $ar instead..." >&4 + com='' + if $ar t $libc > libc.tmp && \ + $contains '^fprintf$' libc.tmp >/dev/null 2>&1 + then + for thisname in $libnames $libc; do + $ar t $thisname >>libc.tmp + done + $sed -e "s/\\$_o\$//" < libc.tmp > libc.list + echo "Ok." >&4 + elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then + for thisname in $libnames $libc; do + $ar tv $thisname >>libc.tmp + emximp -o tmp.imp $thisname \ + 2>/dev/null && \ + $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \ + < tmp.imp >>libc.tmp + $rm -f tmp.imp + done + $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list + echo "Ok." >&4 + else + echo "$ar didn't seem to work right." >&4 + echo "Maybe this is a Cray...trying bld instead..." >&4 + if bld t $libc | \ + $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list && + $test -s libc.list + then + for thisname in $libnames; do + bld t $libnames | \ + $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list + $ar t $thisname >>libc.tmp + done + echo "Ok." >&4 else - echo "I don't think setuid scripts are secure." >&4 - dflt=n + echo "That didn't work either. Giving up." >&4 + exit 1 fi - ;; - esac - rp='Does your kernel have *secure* setuid scripts?' - . ./myread - case "$ans" in - [yY]*) val="$define";; - *) val="$undef";; - esac + fi fi -else - echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 - echo "(That's for file descriptors, not floppy disks.)" - val="$undef" fi -set d_suidsafe -eval $setvar - -$rm -f reflect flect - -: now see if they want to do setuid emulation -if $test $patchlevel -lt 11; then -echo " " -val="$undef" -case "$d_suidsafe" in -"$define") - val="$undef" - echo "No need to emulate SUID scripts since they are secure here." >&4 - ;; -*) - $cat <&4 </dev/null 2>&1; then - perl5=$tdir/perl - break; - elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then - perl5=$tdir/perl5 - break; - fi - done - ;; -*) perl5="$perl5" - ;; +nm_extract="$com" +case "$PASE" in +define) + echo " " + echo "Since you are compiling for PASE, extracting more symbols from libc.a ...">&4 + dump -Tv /lib/libc.a | awk '$7 == "/unix" {print $5 " " $8}' | grep "^SV" | awk '{print $2}' >> libc.list + ;; +*) if $test -f /lib/syscalls.exp; then + echo " " + echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 + $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' \ + /lib/syscalls.exp >>libc.list + fi + ;; esac -case "$perl5" in -'') echo "None found. That's ok.";; -*) echo "Using $perl5." ;; +;; esac +$rm -f libnames libpath -: Set the siteprefix variables -$cat <&4 +$cat >try.c <<'EOCP' +#include +int main(void) +{ +#ifdef __cplusplus + return 0; +#else + return 1; +#endif +} +EOCP +set try +if eval $compile_ok && $run ./try; then + val="$define" + echo "You are using a C++ compiler." +else + val="$undef" + echo "You are not using a C++ compiler." +fi +$rm_try cplusplus$$ +set d_cplusplus +eval $setvar -: determine where site specific libraries go. -: Usual default is /usr/local/lib/perl5/site_perl/$version -: The default "style" setting is made in installstyle.U -: XXX No longer works with Prefixit stuff. -prog=`echo $package | $sed 's/-*[0-9.]*$//'` -case "$sitelib" in -'') case "$installstyle" in - *lib/perl5*) dflt=$siteprefix/lib/$package/site_$prog/$version ;; - *) dflt=$siteprefix/lib/site_$prog/$version ;; - esac +: is a C symbol defined? +csym='tlook=$1; +case "$3" in +-v) tf=libc.tmp; tdc="";; +-a) tf=libc.tmp; tdc="[]";; +*) tlook="^$1\$"; tf=libc.list; tdc="()";; +esac; +case "$d_cplusplus" in + $define) extern_C="extern \"C\"" ;; + *) extern_C="extern" ;; +esac; +tx=yes; +case "$reuseval-$4" in +true-) ;; +true-*) tx=no; eval "tval=\$$4"; case "$tval" in "") tx=yes;; esac;; +esac; +case "$tx" in +yes) + tval=false; + if $test "$runnm" = true; then + if $contains $tlook $tf >/dev/null 2>&1; then + tval=true; + elif $test "$mistrustnm" = compile -o "$mistrustnm" = run; then + echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c; + $cc -o try $optimize $ccflags $ldflags try.c >/dev/null 2>&1 $libs && tval=true; + $test "$mistrustnm" = run -a -x try && { $run ./try$_exe >/dev/null 2>&1 || tval=false; }; + $rm_try; + fi; + else + echo "$extern_C void *$1$tdc; void *(*(p()))$tdc { return &$1; } int main() { if(p() && p() != (void *)main) return(0); else return(1); }"> try.c; + $cc -o try $optimize $ccflags $ldflags try.c $libs >/dev/null 2>&1 && tval=true; + $rm_try; + fi; ;; -*) dflt="$sitelib" +*) + case "$tval" in + $define) tval=true;; + *) tval=false;; + esac; ;; -esac -$cat < getverlist <> getverlist <<'EOPL' -# The list found is store twice for each entry: the original name, and -# the binary broken down version as pack "sss", so sorting is easy and -# unambiguous. This will work for all versions that have a maximum of -# three digit groups, separate by '.'s or '_'s. Names are extended with -# ".0.0" to ensure at least three elements for the pack. -# -- H.Merijn Brand (m)'06 23-10-2006 - -# Can't have leading @ because metaconfig interprets it as a command! -;@inc_version_list=(); -# XXX Redo to do opendir/readdir? -if (-d $stem) { - chdir($stem); - ;@candidates = map { - [ $_, pack "sss", split m/[._]/, "$_.0.0" ] } glob("5.*"); - ;@candidates = sort { $a->[1] cmp $b->[1]} @candidates; -} -else { - ;@candidates = (); -} +esac; +eval "$2=$tval"' -($pversion, $aversion, $vsn5005) = map { - pack "sss", split m/[._]/, "$_.0.0" } $version, $api_versionstring, "5.005"; -foreach $d (@candidates) { - if ($d->[1] lt $pversion) { - if ($d->[1] ge $aversion) { - unshift(@inc_version_list, grep { -d } $d->[0]."/$archname", $d->[0]); - } - elsif ($d->[1] ge $vsn5005) { - unshift(@inc_version_list, grep { -d } $d->[0]); - } - } - else { - # Skip newer version. I.e. don't look in - # 5.7.0 if we're installing 5.6.1. - } -} +: define an is-in-libc? function +inlibc='echo " "; td=$define; tu=$undef; +sym=$1; var=$2; eval "was=\$$2"; +tx=yes; +case "$reuseval$was" in +true) ;; +true*) tx=no;; +esac; +case "$tx" in +yes) + set $sym tres -f; + eval $csym; + case "$tres" in + true) + echo "$sym() found." >&4; + case "$was" in $undef) . ./whoa; esac; eval "$var=\$td";; + *) + echo "$sym() NOT found." >&4; + case "$was" in $define) . ./whoa; esac; eval "$var=\$tu";; + esac;; +*) + case "$was" in + $define) echo "$sym() found." >&4;; + *) echo "$sym() NOT found." >&4;; + esac;; +esac' -if (@inc_version_list) { - print join(' ', @inc_version_list); -} -else { - # Blank space to preserve value for next Configure run. - print " "; +: check for length of double +echo " " +case "$doublesize" in +'') + echo "Checking to see how big your double precision numbers are..." >&4 + $cat >try.c < +#$i_stdlib I_STDLIB +#ifdef I_STDLIB +#include +#endif +int main() +{ + printf("%d\n", (int)sizeof(double)); + exit(0); } -EOPL -chmod +x getverlist -case "$inc_version_list" in -'') if test -x "$perl5$exe_ext"; then - dflt=`$perl5 getverlist` +EOCP + set try + if eval $compile_ok; then + doublesize=`$run ./try` + echo "Your double is $doublesize bytes long." else - dflt='none' + dflt='8' + echo "(I can't seem to compile the test program. Guessing...)" + rp="What is the size of a double precision number (in bytes)?" + . ./myread + doublesize="$ans" fi ;; -$undef) dflt='none' ;; -*) eval dflt=\"$inc_version_list\" ;; -esac -case "$dflt" in -''|' ') dflt=none ;; -esac -case "$dflt" in -5.005) dflt=none ;; -esac -$cat <try.c < -#include -#$i_mallocmalloc I_MALLOCMALLOC -#ifdef I_MALLOCMALLOC -# include -#endif - -int main () { return 0; } -EOCP +echo "Checking to see if you have long double..." >&4 +echo 'int main() { long double x = 7.0; }' > try.c set try if eval $compile; then - echo " found." >&4 - val="$define" + val="$define" + echo "You have long double." else - echo " NOT found." >&4 - val="$undef" + val="$undef" + echo "You do not have long double." fi $rm_try -set i_malloc +set d_longdbl eval $setvar -: check for length of pointer -echo " " -case "$ptrsize" in -'') - echo "Checking to see how big your pointers are..." >&4 - $cat >>try.c <&4 + $cat >try.c <<'EOCP' #include -#$i_stdlib I_STDLIB -#ifdef I_STDLIB -#include -#endif int main() { - printf("%d\n", (int)sizeof(void *)); - exit(0); + printf("%d\n", sizeof(long double)); } EOCP set try - if eval $compile_ok; then - ptrsize=`$run ./try` - echo "Your pointers are $ptrsize bytes long." + set try + if eval $compile; then + longdblsize=`$run ./try` + echo "Your long doubles are $longdblsize bytes long." else - dflt='4' + dflt='8' + echo " " echo "(I can't seem to compile the test program. Guessing...)" >&4 - rp="What is the size of a pointer (in bytes)?" + rp="What is the size of a long double (in bytes)?" . ./myread - ptrsize="$ans" + longdblsize="$ans" + fi + if $test "X$doublesize" = "X$longdblsize"; then + echo "That isn't any different from an ordinary double." + echo "I'll keep your setting anyway, but you may see some" + echo "harmless compilation warnings." + fi + ;; +esac +$rm_try + +$echo "Checking the kind of long doubles you have..." >&4 +case "$d_longdbl" in +define) +$cat <try.c +#$i_float I_FLOAT +#$i_stdlib I_STDLIB +#define LONGDBLSIZE $longdblsize +#ifdef I_FLOAT +#include +#endif +#ifdef I_STDLIB +#include +#endif +#$usequadmath USE_QUADMATH +#$i_quadmath I_QUADMATH +#if defined(USE_QUADMATH) && defined(I_QUADMATH) +#include +static const __float128 d = -0.1Q; +#else +static const long double d = -0.1L; +#endif +#include +int main() { + unsigned const char* b = (unsigned const char*)(&d); +#if (LDBL_MANT_DIG == 113 || FLT128_MANT_DIG == 113) && LONGDBLSIZE == 16 + if (b[0] == 0x9A && b[1] == 0x99 && b[15] == 0xBF) { + /* IEEE 754 128-bit little-endian */ + printf("1\n"); + exit(0); + } + if (b[0] == 0xBF && b[14] == 0x99 && b[15] == 0x9A) { + /* IEEE 128-bit big-endian, e.g. solaris sparc */ + printf("2\n"); + exit(0); + } +#endif +#if LDBL_MANT_DIG == 64 && (LONGDBLSIZE == 16 || LONGDBLSIZE == 12) + if (b[0] == 0xCD && b[9] == 0xBF && b[10] == 0x00) { + /* x86 80-bit little-endian, sizeof 12 (ILP32, Solaris x86) + * or 16 (LP64, Linux and OS X), 4 or 6 bytes of padding. + * Also known as "extended precision". */ + printf("3\n"); + exit(0); + } + if (b[0] == 0xBF && b[9] == 0xCD && b[10] == 0x00) { + /* is there ever big-endian 80-bit, really? */ + printf("4\n"); + exit(0); + } +#endif +#if LDBL_MANT_DIG == 106 && LONGDBLSIZE == 16 + /* software "double double", the 106 is 53+53 */ + if (b[0] == 0x9A && b[7] == 0x3C && b[8] == 0x9A && b[15] == 0xBF) { + /* double double 128-bit little-endian, + * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */ + printf("5\n"); + exit(0); + } + if (b[0] == 0xBF && b[7] == 0x9A && b[8] == 0x3C && b[15] == 0x9A) { + /* double double 128-bit big-endian, e.g. PPC/Power and MIPS: + * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a */ + printf("6\n"); + exit(0); + } +#endif + printf("-1\n"); /* unknown */ + exit(0); +} +EOP +set try +if eval $compile; then + longdblkind=`$run ./try` +else + longdblkind=-1 +fi +;; +*) longdblkind=0 ;; +esac +case "$longdblkind" in +0) echo "Your long doubles are doubles." >&4 ;; +1) echo "You have IEEE 754 128-bit little endian long doubles." >&4 ;; +2) echo "You have IEEE 754 128-bit big endian long doubles." >&4 ;; +3) echo "You have x86 80-bit little endian long doubles." >& 4 ;; +*) echo "Cannot figure out your long double." >&4 ;; +esac +$rm_try + + +: determine the architecture name +echo " " +if xxx=`./loc arch blurfl $pth`; $test -f "$xxx"; then + tarch=`arch`"-$osname" +elif xxx=`./loc uname blurfl $pth`; $test -f "$xxx" ; then + if uname -m > tmparch 2>&1 ; then + tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \ + -e 's/$/'"-$osname/" tmparch` + else + tarch="$osname" fi + $rm -f tmparch +else + tarch="$osname" +fi +case "$myarchname" in +''|"$tarch") ;; +*) + echo "(Your architecture name used to be $myarchname.)" + archname='' ;; esac -$rm_try -case "$use64bitall" in -"$define"|true|[yY]*) - case "$ptrsize" in - 4) cat <&4 +case "$targetarch" in +'') ;; +*) archname=`echo $targetarch|sed 's,^[^-]*-,,'` ;; +esac +myarchname="$tarch" +case "$archname" in +'') dflt="$tarch";; +*) dflt="$archname";; +esac +rp='What is your architecture name' +. ./myread +archname="$ans" + +: optionally add API version to the architecture for versioned archlibs +case "$useversionedarchname" in +$define|true|[yY]*) dflt='y';; +*) dflt='n';; +esac +rp='Add the Perl API version to your archname?' +. ./myread +case "$ans" in +y|Y) useversionedarchname="$define" ;; +*) useversionedarchname="$undef" ;; +esac +case "$useversionedarchname" in +$define) + case "$archname" in + *-$api_versionstring) + echo "...and architecture name already has -$api_versionstring" >&4 + ;; + *) + archname="$archname-$api_versionstring" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; +esac -*** You have chosen a maximally 64-bit build, -*** but your pointers are only 4 bytes wide. -*** Please rerun Configure without -Duse64bitall. -EOM - case "$d_quad" in - define) - cat <&4 -*** Since you have quads, you could possibly try with -Duse64bitint. -EOM - ;; +case "$usethreads" in +$define) + echo "Threads selected." >&4 + case "$archname" in + *-thread*) echo "...and architecture name already has -thread." >&4 + ;; + *) archname="$archname-thread" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; +esac +case "$usemultiplicity" in +$define) + echo "Multiplicity selected." >&4 + case "$archname" in + *-multi*) echo "...and architecture name already has -multi." >&4 + ;; + *) archname="$archname-multi" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; +esac +case "$use64bitint$use64bitall" in +*"$define"*) + case "$archname64" in + '') + echo "This architecture is naturally 64-bit, not changing architecture name." >&4 + ;; + *) + case "$use64bitint" in + "$define") echo "64 bit integers selected." >&4 ;; esac - cat <&4 -*** Cannot continue, aborting. - -EOM - - exit 1 + case "$use64bitall" in + "$define") echo "Maximal 64 bitness selected." >&4 ;; + esac + case "$archname" in + *-$archname64*) echo "...and architecture name already has $archname64." >&4 + ;; + *) archname="$archname-$archname64" + echo "...setting architecture name to $archname." >&4 + ;; + esac + ;; + esac +esac +case "$uselongdouble" in +$define) + echo "Long doubles selected." >&4 + case "$longdblsize" in + $doublesize) + echo "...but long doubles are equal to doubles, not changing architecture name." >&4 + ;; + *) + case "$archname" in + *-ld*) echo "...and architecture name already has -ld." >&4 + ;; + *) archname="$archname-ld" + echo "...setting architecture name to $archname." >&4 + ;; + esac ;; esac ;; esac +if $test -f archname.cbu; then + echo "Your platform has some specific hints for architecture name, using them..." + . ./archname.cbu +fi +: set the prefixit variable, to compute a suitable default value +prefixit='case "$3" in +""|none) + case "$oldprefix" in + "") eval "$1=\"\$$2\"";; + *) + case "$3" in + "") eval "$1=";; + none) + eval "tp=\"\$$2\""; + case "$tp" in + ""|" ") eval "$1=\"\$$2\"";; + *) eval "$1=";; + esac;; + esac;; + esac;; +*) + eval "tp=\"$oldprefix-\$$2-\""; eval "tp=\"$tp\""; + case "$tp" in + --|/*--|\~*--) eval "$1=\"$prefix/$3\"";; + /*-$oldprefix/*|\~*-$oldprefix/*) + eval "$1=\`echo \$$2 | sed \"s,^$oldprefix,$prefix,\"\`";; + *) eval "$1=\"\$$2\"";; + esac;; +esac' -: determine whether to use malloc wrapping -echo " " -case "$usemallocwrap" in -[yY]*|true|$define) dflt='y' ;; -[nN]*|false|$undef) dflt='n' ;; -*) case "$usedevel" in - [yY]*|true|$define) dflt='y' ;; - *) dflt='n' ;; +: determine installation style +: For now, try to deduce it from prefix unless it is already set. +: Reproduce behavior of 5.005 and earlier, maybe drop that in 5.7. +case "$installstyle" in +'') case "$prefix" in + *perl*) dflt='lib';; + *) dflt='lib/perl5' ;; esac ;; +*) dflt="$installstyle" ;; esac -rp="Do you wish to wrap malloc calls to protect against potential overflows?" -. ./myread -usemallocwrap="$ans" -case "$ans" in -y*|true) - usemallocwrap="$define" ;; -*) - usemallocwrap="$undef" ;; -esac +: Probably not worth prompting for this since we prompt for all +: the directories individually, and the prompt would be too long and +: confusing anyway. +installstyle=$dflt -: determine which malloc to compile in +: determine where public executables go echo " " -case "$usemymalloc" in -[yY]*|true|$define) dflt='y' ;; -[nN]*|false|$undef) dflt='n' ;; -*) case "$ptrsize" in - 4) dflt='y' ;; - *) dflt='n' ;; - esac - if test "$useithreads" = "$define"; then dflt='n'; fi - ;; +set dflt bin bin +eval $prefixit +fn=d~ +rp='Pathname where the public executables will reside?' +. ./getfile +if $test "X$ansexp" != "X$binexp"; then + installbin='' +fi +prefixvar=bin +: XXX Bug? -- ignores Configure -Dinstallprefix setting. +: XXX If this is fixed, also fix the "start perl" hunk below, which relies on +: this via initialinstalllocation +. ./setprefixvar + +case "$userelocatableinc" in +$define|true|[yY]*) dflt='y' ;; +*) dflt='n' ;; esac -rp="Do you wish to attempt to use the malloc that comes with $package?" +cat <&4 - set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'` - shift - libs="$*" - echo "libs = $libs" >&4 - ;; - esac - ;; -*) - usemymalloc='n' - mallocsrc='' - mallocobj='' - d_mymalloc="$undef" - ;; +y|Y) val="$define" ;; +*) val="$undef" ;; esac +set userelocatableinc +eval $setvar -: compute the return types of malloc and free -echo " " -$cat >malloc.c < -#include -#ifdef I_MALLOC -#include -#endif -#ifdef I_STDLIB -#include -#endif -#ifdef TRY_MALLOC -void *malloc(); -#endif -#ifdef TRY_FREE -void free(); -#endif -END -case "$malloctype" in -'') - if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then - malloctype='void *' - else - malloctype='char *' - fi - ;; +initialinstalllocation="$binexp" +: Default prefix is now "up one level from where the binaries are" +case "$userelocatableinc" in +$define|true|[yY]*) + bin=".../" + binexp=".../" + prefix=".../.." + prefixexp=".../.." + installprefixexp=".../.." + ;; esac -echo "Your system wants malloc to return '$malloctype', it would seem." >&4 -case "$freetype" in -'') - if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then - freetype='void' - else - freetype='int' - fi - ;; -esac -echo "Your system uses $freetype free(), it would seem." >&4 -$rm -f malloc.[co] -: determine where site specific architecture-dependent libraries go. -: sitelib default is /usr/local/lib/perl5/site_perl/$version -: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname -: sitelib may have an optional trailing /share. -case "$sitearch" in -'') dflt=`echo $sitelib | $sed 's,/share$,,'` - dflt="$dflt/$archname" - ;; -*) dflt="$sitearch" - ;; +: determine where private library files go +: Usual default is /usr/local/lib/perl5/$version. +: Also allow things like /opt/perl/lib/$version, since +: /opt/perl/lib/perl5... would be redundant. +: The default "style" setting is made in installstyle.U +case "$installstyle" in +*lib/perl5*) set dflt privlib lib/$package/$version ;; +*) set dflt privlib lib/$version ;; esac -set sitearch sitearch none eval $prefixit $cat <reflect + chmod +x,u+s reflect + ./reflect >flect 2>&1 + if $contains "/dev/fd" flect >/dev/null; then + echo "Congratulations, your kernel has secure setuid scripts!" >&4 + val="$define" + else + $cat <&4 + dflt=n;; + "$undef") + echo "Well, the $hint value is *not* secure." >&4 + dflt=n;; + *) echo "Well, the $hint value *is* secure." >&4 + dflt=y;; + esac + ;; + *) + $rm -f reflect flect + echo "#!$ls" >reflect + chmod +x,u+s reflect + echo >flect + chmod a+w flect + echo '"su" will (probably) prompt you for '"$ans's password." + su $ans -c './reflect >flect' + if $contains "/dev/fd" flect >/dev/null; then + echo "Okay, it looks like setuid scripts are secure." >&4 + dflt=y + else + echo "I don't think setuid scripts are secure." >&4 + dflt=n + fi + ;; + esac + rp='Does your kernel have *secure* setuid scripts?' + . ./myread + case "$ans" in + [yY]*) val="$define";; + *) val="$undef";; + esac + fi +else + echo "I don't think setuid scripts are secure (no /dev/fd directory)." >&4 + echo "(That's for file descriptors, not floppy disks.)" + val="$undef" +fi +set d_suidsafe +eval $setvar + +$rm -f reflect flect + +: now see if they want to do setuid emulation +if $test $patchlevel -lt 11; then +echo " " +val="$undef" +case "$d_suidsafe" in +"$define") + val="$undef" + echo "No need to emulate SUID scripts since they are secure here." >&4 ;; -esac -. ./myread -case "$ans" in -[yY]*) fn=d~+ - rp='Installation prefix to use for vendor-supplied add-ons?' - case "$vendorprefix" in - '') dflt="$prefix" ;; - *) dflt=$vendorprefix ;; +*) + $cat <&4 </dev/null 2>&1; then + perl5=$tdir/perl + break; + elif $test -x $tdir/perl5$exe_ext && $tdir/perl5 -Mless -e 'use 5.005;' >/dev/null 2>&1; then + perl5=$tdir/perl5 + break; + fi + done + ;; +*) perl5="$perl5" ;; esac +case "$perl5" in +'') echo "None found. That's ok.";; +*) echo "Using $perl5." ;; +esac -: Set the vendorlib variables -case "$vendorprefix" in -'') d_vendorlib="$undef" - vendorlib='' - vendorlibexp='' - ;; -*) d_vendorlib="$define" - : determine where vendor-supplied modules go. - : Usual default is /usr/local/lib/perl5/vendor_perl/$version - case "$vendorlib" in - '') - prog=`echo $package | $sed 's/-*[0-9.]*$//'` - case "$installstyle" in - *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;; - *) dflt=$vendorprefix/lib/vendor_$prog/$version ;; - esac - ;; - *) dflt="$vendorlib" - ;; +: Set the siteprefix variables +$cat < getverlist <> getverlist <<'EOPL' +# The list found is store twice for each entry: the original name, and +# the binary broken down version as pack "sss", so sorting is easy and +# unambiguous. This will work for all versions that have a maximum of +# three digit groups, separate by '.'s or '_'s. Names are extended with +# ".0.0" to ensure at least three elements for the pack. +# -- H.Merijn Brand (m)'06 23-10-2006 + +# Can't have leading @ because metaconfig interprets it as a command! +;@inc_version_list=(); +# XXX Redo to do opendir/readdir? +if (-d $stem) { + chdir($stem); + ;@candidates = map { + [ $_, pack "sss", split m/[._]/, "$_.0.0" ] } glob("5.*"); + ;@candidates = sort { $a->[1] cmp $b->[1]} @candidates; +} +else { + ;@candidates = (); +} + +($pversion, $aversion, $vsn5005) = map { + pack "sss", split m/[._]/, "$_.0.0" } $version, $api_versionstring, "5.005"; +foreach $d (@candidates) { + if ($d->[1] lt $pversion) { + if ($d->[1] ge $aversion) { + unshift(@inc_version_list, grep { -d } $d->[0]."/$archname", $d->[0]); + } + elsif ($d->[1] ge $vsn5005) { + unshift(@inc_version_list, grep { -d } $d->[0]); + } + } + else { + # Skip newer version. I.e. don't look in + # 5.7.0 if we're installing 5.6.1. + } +} + +if (@inc_version_list) { + print join(' ', @inc_version_list); +} +else { + # Blank space to preserve value for next Configure run. + print " "; +} +EOPL +chmod +x getverlist +case "$inc_version_list" in +'') if test -x "$perl5$exe_ext"; then + dflt=`$perl5 getverlist` + else + dflt='none' + fi + ;; +$undef) dflt='none' ;; +*) eval dflt=\"$inc_version_list\" ;; +esac +case "$dflt" in +''|' ') dflt=none ;; +esac +case "$dflt" in +5.005) dflt=none ;; esac $cat <try.c < +#include +#$i_mallocmalloc I_MALLOCMALLOC +#ifdef I_MALLOCMALLOC +# include +#endif + +int main () { return 0; } +EOCP +set try +if eval $compile; then + echo " found." >&4 + val="$define" +else + echo " NOT found." >&4 + val="$undef" +fi +$rm_try +set i_malloc eval $setvar -: Cruising for prototypes +: check for length of pointer echo " " -echo "Checking out function prototypes..." >&4 -$cat >prototype.c <&4 + $cat >>try.c < #$i_stdlib I_STDLIB #ifdef I_STDLIB #include #endif -int main(int argc, char *argv[]) { - exit(0);} +int main() +{ + printf("%d\n", (int)sizeof(void *)); + exit(0); +} EOCP -if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then - echo "Your C compiler appears to support function prototypes." - val="$define" -else - echo "Your C compiler doesn't seem to understand function prototypes." - val="$undef" -fi -set prototype -eval $setvar -$rm -f prototype* - -: Check if ansi2knr is required -case "$prototype" in -"$define") ;; -*) ansi2knr='ansi2knr' - echo " " - cat <&4 - -$me: FATAL ERROR: -This version of $package can only be compiled by a compiler that -understands function prototypes. Unfortunately, your C compiler - $cc $ccflags -doesn't seem to understand them. Sorry about that. - -If GNU cc is available for your system, perhaps you could try that instead. - -Eventually, we hope to support building Perl with pre-ANSI compilers. -If you would like to help in that effort, please contact . - -Aborting Configure now. -EOM - exit 2 + set try + if eval $compile_ok; then + ptrsize=`$run ./try` + echo "Your pointers are $ptrsize bytes long." + else + dflt='4' + echo "(I can't seem to compile the test program. Guessing...)" >&4 + rp="What is the size of a pointer (in bytes)?" + . ./myread + ptrsize="$ans" + fi ;; esac +$rm_try +case "$use64bitall" in +"$define"|true|[yY]*) + case "$ptrsize" in + 4) cat <&4 -: DTrace support -dflt_dtrace='/usr/sbin/dtrace' -$test -x /usr/bin/dtrace && dflt_dtrace='/usr/bin/dtrace' - -cat </dev/null 2>&1 \ - && rm -f perldtrace.tmp - then - echo " " - echo "Good: your $dtrace knows about the -h flag." - else - cat >&2 <&4 +*** Since you have quads, you could possibly try with -Duse64bitint. EOM - exit 1 - fi - break; - fi - - case "$fastread" in - yes) - cat >&2 <&4 +*** Cannot continue, aborting. EOM + exit 1 ;; - *) - echo "*** $dtrace was not found." - echo " " - ;; esac -done - -: See if we want extra modules installed -echo " " -case "$extras" in -'') dflt='n';; -*) dflt='y';; + ;; esac -cat <&4 + set `echo X $libs | $sed -e 's/-lmalloc / /' -e 's/-lmalloc$//'` + shift + libs="$*" + echo "libs = $libs" >&4 + ;; + esac + ;; +*) + usemymalloc='n' + mallocsrc='' + mallocobj='' + d_mymalloc="$undef" + ;; +esac + +: compute the return types of malloc and free +echo " " +$cat >malloc.c < +#include +#ifdef I_MALLOC +#include +#endif +#ifdef I_STDLIB +#include +#endif +#ifdef TRY_MALLOC +void *malloc(); +#endif +#ifdef TRY_FREE +void free(); +#endif +END +case "$malloctype" in +'') + if $cc $ccflags -c -DTRY_MALLOC malloc.c >/dev/null 2>&1; then + malloctype='void *' + else + malloctype='char *' + fi + ;; +esac +echo "Your system wants malloc to return '$malloctype', it would seem." >&4 -Please list any extra modules or bundles to be installed from CPAN, -with spaces between the names. The names can be in any format the -'install' command of CPAN.pm will understand. (Answer 'none', -without the quotes, to install no extra modules or bundles.) -EOM - rp='Extras?' - dflt="$extras" - . ./myread - extras="$ans" +case "$freetype" in +'') + if $cc $ccflags -c -DTRY_FREE malloc.c >/dev/null 2>&1; then + freetype='void' + else + freetype='int' + fi + ;; esac -case "$extras" in -''|'none') - val='' - $rm -f ../extras.lst +echo "Your system uses $freetype free(), it would seem." >&4 +$rm -f malloc.[co] +: determine where site specific architecture-dependent libraries go. +: sitelib default is /usr/local/lib/perl5/site_perl/$version +: sitearch default is /usr/local/lib/perl5/site_perl/$version/$archname +: sitelib may have an optional trailing /share. +case "$sitearch" in +'') dflt=`echo $sitelib | $sed 's,/share$,,'` + dflt="$dflt/$archname" ;; -*) echo "(Saving the list of extras for later...)" - echo "$extras" > ../extras.lst - val="'$extras'" +*) dflt="$sitearch" ;; esac -set extras -eval $setvar -echo " " - -: determine where html pages for programs go -set html1dir html1dir none +set sitearch sitearch none eval $prefixit $cat <&4 -cat >try.c <<'EOCP' -/* Find out version of GNU C library. __GLIBC__ and __GLIBC_MINOR__ - alone are insufficient to distinguish different versions, such as - 2.0.6 and 2.0.7. The function gnu_get_libc_version() appeared in - libc version 2.1.0. A. Dougherty, June 3, 2002. -*/ -#include -int main(void) -{ -#ifdef __GLIBC__ -# ifdef __GLIBC_MINOR__ -# if __GLIBC__ >= 2 && __GLIBC_MINOR__ >= 1 && !defined(__cplusplus) -# include - printf("%s\n", gnu_get_libc_version()); -# else - printf("%d.%d\n", __GLIBC__, __GLIBC_MINOR__); -# endif -# else - printf("%d\n", __GLIBC__); -# endif - return 0; -#else - return 1; -#endif -} -EOCP -set try -if eval $compile_ok && $run ./try > glibc.ver; then - val="$define" - gnulibc_version=`$cat glibc.ver` - echo "You are using the GNU C Library version $gnulibc_version" -else - val="$undef" - gnulibc_version='' - echo "You are not using the GNU C Library" -fi -$rm_try glibc.ver -set d_gnulibc -eval $setvar - -: see if nm is to be used to determine whether a symbol is defined or not -case "$usenm" in -'') - dflt='' - case "$d_gnulibc" in - "$define") - echo " " - echo "nm probably won't work on the GNU C Library." >&4 - dflt=n + ;; +esac +. ./myread +case "$ans" in +[yY]*) fn=d~+ + rp='Installation prefix to use for vendor-supplied add-ons?' + case "$vendorprefix" in + '') dflt="$prefix" ;; + *) dflt=$vendorprefix ;; + esac + . ./getfile + : XXX Prefixit unit does not yet support siteprefix and vendorprefix + oldvendorprefix='' + case "$vendorprefix" in + '') ;; + *) case "$ans" in + "$prefix") ;; + *) oldvendorprefix="$prefix";; + esac ;; esac - case "$dflt" in - '') - if $test "$osname" = aix -a "X$PASE" != "Xdefine" -a ! -f /lib/syscalls.exp; then - echo " " - echo "Whoops! This is an AIX system without /lib/syscalls.exp!" >&4 - echo "'nm' won't be sufficient on this system." >&4 - dflt=n - fi + usevendorprefix="$define" + vendorprefix="$ans" + vendorprefixexp="$ansexp" + ;; +*) usevendorprefix="$undef" + vendorprefix='' + vendorprefixexp='' + ;; +esac + +: Set the vendorlib variables +case "$vendorprefix" in +'') d_vendorlib="$undef" + vendorlib='' + vendorlibexp='' + ;; +*) d_vendorlib="$define" + : determine where vendor-supplied modules go. + : Usual default is /usr/local/lib/perl5/vendor_perl/$version + case "$vendorlib" in + '') + prog=`echo $package | $sed 's/-*[0-9.]*$//'` + case "$installstyle" in + *lib/perl5*) dflt=$vendorprefix/lib/$package/vendor_$prog/$version ;; + *) dflt=$vendorprefix/lib/vendor_$prog/$version ;; + esac ;; - esac - case "$dflt" in - '') dflt=`$egrep 'inlibc|csym' $rsrc/Configure | wc -l 2>/dev/null` - if $test $dflt -gt 20; then - dflt=y - else - dflt=n - fi + *) dflt="$vendorlib" ;; esac + fn=d~+ + rp='Pathname for the vendor-supplied library files?' + . ./getfile + vendorlib="$ans" + vendorlibexp="$ansexp" ;; -*) - case "$usenm" in - true|$define) dflt=y;; - *) dflt=n;; +esac +vendorlib_stem=`echo "$vendorlibexp" | sed "s,/$version$,,"` +prefixvar=vendorlib +. ./installprefix + +: Set the vendorarch variables +case "$vendorprefix" in +'') d_vendorarch="$undef" + vendorarch='' + vendorarchexp='' + ;; +*) d_vendorarch="$define" + : determine where vendor-supplied architecture-dependent libraries go. + : vendorlib default is /usr/local/lib/perl5/vendor_perl/$version + : vendorarch default is /usr/local/lib/perl5/vendor_perl/$version/$archname + : vendorlib may have an optional trailing /share. + case "$vendorarch" in + '') dflt=`echo $vendorlib | $sed 's,/share$,,'` + dflt="$dflt/$archname" + ;; + *) dflt="$vendorarch" ;; esac + fn=d~+ + rp='Pathname for vendor-supplied architecture-dependent files?' + . ./getfile + vendorarch="$ans" + vendorarchexp="$ansexp" ;; esac -$cat < /dev/null 2>&1; then - nm_so_opt='--dynamic' - fi - ;; - esac - ;; +case "$otherlibdirs" in +' ') val=$undef ;; +*) val=$define ;; esac +set d_perl_otherlibdirs +eval $setvar -: Figure out where the libc is located -case "$runnm" in -true) -: get list of predefined functions in a handy place +: Cruising for prototypes echo " " -case "$libc" in -'') libc=unknown - case "$libs" in - *-lc_s*) libc=`./loc libc_s$_a $libc $libpth` - esac - ;; -esac -case "$libs" in -'') ;; -*) for thislib in $libs; do - case "$thislib" in - -lc|-lc_s) - : Handle C library specially below. - ;; - -l*) - thislib=`echo $thislib | $sed -e 's/^-l//'` - if try=`./loc lib$thislib.$so.'*' X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib$_a X $libpth`; $test -f "$try"; then - : - elif try=`./loc $thislib$_a X $libpth`; $test -f "$try"; then - : - elif try=`./loc lib$thislib X $libpth`; $test -f "$try"; then - : - elif try=`./loc $thislib X $libpth`; $test -f "$try"; then - : - elif try=`./loc Slib$thislib$_a X $xlibpth`; $test -f "$try"; then - : - else - try='' - fi - libnames="$libnames $try" - ;; - *) libnames="$libnames $thislib" ;; - esac - done - ;; -esac -xxx=normal -case "$libc" in -unknown) - set /lib/libc.$so - for xxx in $libpth; do - $test -r $1 || set $xxx/libc.$so - : The messy sed command sorts on library version numbers. - $test -r $1 || \ - set `echo blurfl; echo $xxx/libc.$so.[0-9]* | \ - tr ' ' $trnl | egrep -v '\.[A-Za-z]*$' | $sed -e ' - h - s/[0-9][0-9]*/0000&/g - s/0*\([0-9][0-9][0-9][0-9][0-9]\)/\1/g - G - s/\n/ /' | \ - $sort | $sed -e 's/^.* //'` - eval set \$$# - done - $test -r $1 || set $sysroot/usr/ccs/lib/libc.$so - $test -r $1 || set $sysroot/lib/libsys_s$_a - ;; -*) - set blurfl - ;; -esac -if $test -r "$1"; then - echo "Your (shared) C library seems to be in $1." - libc="$1" -elif $test -r /lib/libc && $test -r /lib/clib; then - echo "Your C library seems to be in both /lib/clib and /lib/libc." - xxx=apollo - libc='/lib/clib /lib/libc' - if $test -r /lib/syslib; then - echo "(Your math library is in /lib/syslib.)" - libc="$libc /lib/syslib" - fi -elif $test -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - echo "Your C library seems to be in $libc, as you said before." -elif $test -r $incpath/usr/lib/libc$_a; then - libc=$incpath/usr/lib/libc$_a; - echo "Your C library seems to be in $libc. That's fine." -elif $test -r /lib/libc$_a; then - libc=/lib/libc$_a; - echo "Your C library seems to be in $libc. You're normal." +echo "Checking out function prototypes..." >&4 +$cat >prototype.c < +#endif +int main(int argc, char *argv[]) { + exit(0);} +EOCP +if $cc $ccflags -c prototype.c >prototype.out 2>&1 ; then + echo "Your C compiler appears to support function prototypes." + val="$define" else - if tans=`./loc libc$_a blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc libc blurfl/dyick $libpth`; $test -r "$tans"; then - libnames="$libnames "`./loc clib blurfl/dyick $libpth` - elif tans=`./loc clib blurfl/dyick $libpth`; $test -r "$tans"; then - : - elif tans=`./loc Slibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - elif tans=`./loc Mlibc$_a blurfl/dyick $xlibpth`; $test -r "$tans"; then - : - else - tans=`./loc Llibc$_a blurfl/dyick $xlibpth` - fi - if $test -r "$tans"; then - echo "Your C library seems to be in $tans, of all places." - libc=$tans - else - libc='blurfl' - fi -fi -if $test $xxx = apollo -o -r "$libc" || (test -h "$libc") >/dev/null 2>&1; then - dflt="$libc" - cat <&4 -EOM -else - dflt='' - echo $libpth | $tr ' ' $trnl | $sort | $uniq > libpath - cat >&4 <. +Aborting Configure now. EOM - $sed 's/^/ /' libpath - cat < libnames -set X `cat libnames` -shift -xxx=files -case $# in 1) xxx=file; esac -echo "Extracting names from the following $xxx for later perusal:" >&4 -echo " " -$sed 's/^/ /' libnames >&4 -echo " " -$echo $n "This may take a while...$c" >&4 +while $test 1 ; do + case "$usedtrace" in + $define|true|[yY]*) + dflt='y' + ;; + ?*) + dflt='y' + dflt_dtrace=$usedtrace + ;; + *) + dflt='n' + ;; + esac -for file in $*; do - case $file in - *$so*) $nm $nm_so_opt $nm_opt $file 2>/dev/null;; - *) $nm $nm_opt $file 2>/dev/null;; + rp='Support DTrace if available?' + . ./myread + case "$ans" in + y|Y) val="$define" ;; + *) val="$undef" ;; esac -done >libc.tmp + set usedtrace + eval $setvar -$echo $n ".$c" -$grep fprintf libc.tmp > libc.ptf -xscan='eval "libc.list"; $echo $n ".$c" >&4' -xrun='eval "libc.list"; echo "done." >&4' -xxx='[ADTSIWi]' -if com="$sed -n -e 's/__IO//' -e 's/^.* $xxx *//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^__*//' -e 's/^\([a-zA-Z_0-9$]*\).*xtern.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e '/|UNDEF/d' -e '/FUNC..GL/s/^.*|__*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.* D __*//p' -e 's/^.* D //p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^_//' -e 's/^\([a-zA-Z_0-9]*\).*xtern.*text.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$grep '|' | $sed -n -e '/|COMMON/d' -e '/|DATA/d' \ - -e '/ file/d' -e 's/^\([^ ]*\).*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|FUNC |GLOB .*|//p' -e 's/^.*|FUNC |WEAK .*|//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^__//' -e '/|Undef/d' -e '/|Proc/s/ .*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^.*|Proc .*|Text *| *//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e '/Def. Text/s/.* \([^ ]*\)\$/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/^[-0-9a-f ]*_\(.*\)=.*/\1/p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="$sed -n -e 's/.*\.text n\ \ \ \.//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -elif com="sed -n -e 's/^__.*//' -e 's/[ ]*D[ ]*[0-9]*.*//p'";\ - eval $xscan;\ - $contains '^fprintf$' libc.list >/dev/null 2>&1; then - eval $xrun -else - $nm -p $* 2>/dev/null >libc.tmp - $grep fprintf libc.tmp > libc.ptf - if com="$sed -n -e 's/^.* [ADTSIW] *_[_.]*//p' -e 's/^.* [ADTSIW] //p'";\ - eval $xscan; $contains '^fprintf$' libc.list >/dev/null 2>&1 + test "X$usedtrace" != "X$define" && break + + echo " " + rp='Where is the dtrace executable?' + dflt=$dflt_dtrace + . ./getfile + val="$ans" + set dtrace + eval $setvar + + if $test -f $dtrace then - nm_opt='-p' - eval $xrun - else - echo " " - echo "$nm didn't seem to work right. Trying $ar instead..." >&4 - com='' - if $ar t $libc > libc.tmp && \ - $contains '^fprintf$' libc.tmp >/dev/null 2>&1 + if $dtrace -h -s ../perldtrace.d \ + -o perldtrace.tmp >/dev/null 2>&1 \ + && rm -f perldtrace.tmp then - for thisname in $libnames $libc; do - $ar t $thisname >>libc.tmp - done - $sed -e "s/\\$_o\$//" < libc.tmp > libc.list - echo "Ok." >&4 - elif test "X$osname" = "Xos2" && $ar tv $libc > libc.tmp; then - for thisname in $libnames $libc; do - $ar tv $thisname >>libc.tmp - emximp -o tmp.imp $thisname \ - 2>/dev/null && \ - $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \ - < tmp.imp >>libc.tmp - $rm -f tmp.imp - done - $sed -e "s/\\$_o\$//" -e 's/^ \+//' < libc.tmp > libc.list - echo "Ok." >&4 + echo " " + echo "Good: your $dtrace knows about the -h flag." else - echo "$ar didn't seem to work right." >&4 - echo "Maybe this is a Cray...trying bld instead..." >&4 - if bld t $libc | \ - $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" > libc.list && - $test -s libc.list - then - for thisname in $libnames; do - bld t $libnames | \ - $sed -e 's/.*\///' -e "s/\\$_o:.*\$//" >>libc.list - $ar t $thisname >>libc.tmp - done - echo "Ok." >&4 - else - echo "That didn't work either. Giving up." >&4 - exit 1 - fi + cat >&2 <&4 - dump -Tv /lib/libc.a | awk '$7 == "/unix" {print $5 " " $8}' | grep "^SV" | awk '{print $2}' >> libc.list - ;; -*) if $test -f /lib/syscalls.exp; then - echo " " - echo "Also extracting names from /lib/syscalls.exp for good ole AIX..." >&4 - $sed -n 's/^\([^ ]*\)[ ]*syscall[0-9]*[ ]*$/\1/p' \ - /lib/syscalls.exp >>libc.list - fi - ;; + + case "$fastread" in + yes) + cat >&2 < ../extras.lst + val="'$extras'" + ;; esac -$rm -f libnames libpath +set extras +eval $setvar +echo " " + +: determine where html pages for programs go +set html1dir html1dir none +eval $prefixit +$cat <&4 -$cat >try.c <<'EOCP' -#include -int main(void) -{ -#ifdef __cplusplus - return 0; -#else - return 1; -#endif -} -EOCP -set try -if eval $compile_ok && $run ./try; then - val="$define" - echo "You are using a C++ compiler." +if $test -d /usr/bin -a "X$installbin" != X/usr/bin; then + $cat <dbl_dig.c <&4 +$cat >try.c < +#endif +int main() { return fpclassify(1.0) == FP_NORMAL ? 0 : 1; } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have fpclassify." +else + val="$undef" + echo "You do not have fpclassify." +fi +$rm_try +set d_fpclassify +eval $setvar + +: see if fp_classify exists +set fp_classify d_fp_classify eval $inlibc -: see if prototype for flock is available -echo " " -set d_flockproto flock $i_sysfile sys/file.h -eval $hasproto - -: see if fp_class exists -set fp_class d_fp_class +: see if fp_classl exists +set fp_classl d_fp_classl eval $inlibc : see if pathconf exists @@ -13612,14 +13798,14 @@ eval $inlibc set fpclass d_fpclass eval $inlibc -: see if fpclassify exists -set fpclassify d_fpclassify -eval $inlibc - : see if fpclassl exists set fpclassl d_fpclassl eval $inlibc +: see if fpgetround exists +set fpgetround d_fpgetround +eval $inlibc + : check for fpos64_t echo " " echo "Checking to see if you have fpos64_t..." >&4 @@ -15349,22 +15535,89 @@ set d_isblank eval $setvar $rm -f isblank* -: see if isfinite exists -set isfinite d_isfinite -eval $inlibc +: check for isfinite +echo "Checking to see if you have isfinite..." >&4 +$cat >try.c < +#endif +int main() { return isfinite(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isfinite." +else + val="$undef" + echo "You do not have isfinite." +fi +$rm_try +set d_isfinite +eval $setvar -: see if isinf exists -set isinf d_isinf +: see if isfinitel exists +set isfinitel d_isfinitel eval $inlibc -: see if isnan exists -set isnan d_isnan +: check for isinf +echo "Checking to see if you have isinf..." >&4 +$cat >try.c < +#endif +int main() { return isinf(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isinf." +else + val="$undef" + echo "You do not have isinf." +fi +$rm_try +set d_isinf +eval $setvar + +: see if isinfl exists +set isinfl d_isinfl eval $inlibc +: check for isnan +echo "Checking to see if you have isnan..." >&4 +$cat >try.c < +#endif +int main() { return isnan(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isnan." +else + val="$undef" + echo "You do not have isnan." +fi +$rm_try +set d_isnan +eval $setvar + : see if isnanl exists set isnanl d_isnanl eval $inlibc +: see if j0 exists +set j0 d_j0 +eval $inlibc + +: see if j0l exists +set j0l d_j0l +eval $inlibc + : see if killpg exists set killpg d_killpg eval $inlibc @@ -15428,14 +15681,6 @@ $rm -f ldbl_dig.? set d_ldbl_dig eval $setvar -: see if ldexpl exists -set ldexpl d_ldexpl -eval $inlibc - -: see if this is a math.h system -set math.h i_math -eval $inhdr - : check to see if math.h defines _LIB_VERSION d_libm_lib_version="$undef" case $i_math in @@ -15464,6 +15709,98 @@ EOCP esac +: check for fpclassify +echo " " +echo "Checking to see if you have fpclassify..." >&4 +$cat >try.c < +#endif +int main() { return fpclassify(1.0) == FP_NORMAL ? 0 : 1; } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have fpclassify." +else + val="$undef" + echo "You do not have fpclassify." +fi +$rm_try +set d_fpclassify +eval $setvar + +: check for isfinite +echo " " +echo "Checking to see if you have isfinite..." >&4 +$cat >try.c < +#endif +int main() { return isfinite(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isfinite." +else + val="$undef" + echo "You do not have isfinite." +fi +$rm_try +set d_isfinite +eval $setvar + +: check for isinf +echo " " +echo "Checking to see if you have isinf..." >&4 +$cat >try.c < +#endif +int main() { return isinf(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isinf." +else + val="$undef" + echo "You do not have isinf." +fi +$rm_try +set d_isinf +eval $setvar + +: check for isnan +echo " " +echo "Checking to see if you have isnan..." >&4 +$cat >try.c < +#endif +int main() { return isnan(0.0); } +EOCP +set try +if eval $compile; then + val="$define" + echo "You have isnan." +else + val="$undef" + echo "You do not have isnan." +fi +$rm_try +set d_isnan +eval $setvar + +: see if this is a quadmath.h system +set quadmath.h i_quadmath +eval $inhdr + : see if link exists set link d_link eval $inlibc @@ -15707,6 +16044,10 @@ eval $inlibc set scalbnl d_scalbnl eval $inlibc +: see if truncl exists +set truncl d_truncl +eval $inlibc + : see if modfl exists set modfl d_modfl eval $inlibc @@ -15785,10 +16126,14 @@ if $test "$uselongdouble" = "$define"; then message="$message sqrtl" fi if $test "$d_modfl" != "$define"; then - if $test "$d_aintl:$d_copysignl" = "$define:$define"; then - echo "You have both aintl and copysignl, so I can emulate modfl." + if $test "$d_truncl:$d_copysignl" = "$define:$define"; then + echo "You have both truncl and copysignl, so I can emulate modfl." else - message="$message modfl" + if $test "$d_aintl:$d_copysignl" = "$define:$define"; then + echo "You have both aintl and copysignl, so I can emulate modfl." + else + message="$message modfl" + fi fi fi if $test "$d_frexpl" != "$define"; then @@ -15963,95 +16308,52 @@ define:define) ;; esac +case "$usequadmath:$i_quadmath" in +define:define) + nvtype="__float128" + nvsize=16 + case "$libs" in + *quadmath*) ;; + *) $cat <&4 + +*** You requested the use of the quadmath library, but you +*** do not seem to have the quadmath library installed. +*** Cannot continue, aborting. +EOM + exit 1 + ;; + esac + ;; +define:*) $cat <&4 + +*** You requested the use of the quadmath library, but you +*** do not seem to have the required header, . +EOM + case "$gccversion" in + [23].*|4.[0-5]*) + $cat <&4 +*** Your gcc looks a bit old: +*** $gccversion +EOM + ;; + '') + $cat <&4 +*** You are not running a gcc. +EOM + ;; + esac + $cat <&4 +*** For the quadmath library you need at least gcc 4.6. +*** Cannot continue, aborting. +EOM + exit 1 + ;; +esac + $echo "(IV will be "$ivtype", $ivsize bytes)" $echo "(UV will be "$uvtype", $uvsize bytes)" $echo "(NV will be "$nvtype", $nvsize bytes)" -$echo "Checking the kind of long doubles you have..." >&4 -: volatile so that the compiler has to store it out to memory. -if test X"$d_volatile" = X"$define"; then - volatile=volatile -fi -case "$d_longdbl" in -define) -$cat <try.c -#$i_float I_FLOAT -#$i_stdlib I_STDLIB -#define LONGDBLSIZE $longdblsize -#ifdef I_FLOAT -#include -#endif -#ifdef I_STDLIB -#include -#endif -#include -static const long double d = -0.1L; -int main() { - unsigned const char* b = (unsigned const char*)(&d); -#if LDBL_MANT_DIG == 113 && LONGDBLSIZE == 16 - if (b[0] == 0x9A && b[1] == 0x99 && b[15] == 0xBF) { - /* IEEE 754 128-bit little-endian */ - printf("1\n"); - exit(0); - } - if (b[0] == 0xBF && b[14] == 0x99 && b[15] == 0x9A) { - /* IEEE 128-bit big-endian, e.g. solaris sparc */ - printf("2\n"); - exit(0); - } -#endif -#if LDBL_MANT_DIG == 64 && (LONGDBLSIZE == 16 || LONGDBLSIZE == 12) - if (b[0] == 0xCD && b[9] == 0xBF && b[10] == 0x00) { - /* x86 80-bit little-endian, sizeof 12 (ILP32, Solaris x86) - * or 16 (LP64, Linux and OS X), 4 or 6 bytes of padding. - * Also known as "extended precision". */ - printf("3\n"); - exit(0); - } - if (b[LONGDBLSIZE - 11] == 0x00 && b[LONGDBLSIZE - 10] == 0xBF && - b[LONGDBLSIZE - 1] == 0xCD) { - /* is there ever big-endian 80-bit, really? */ - printf("4\n"); - exit(0); - } -#endif -#if LDBL_MANT_DIG == 106 && LONGDBLSIZE == 16 - /* software "double double", the 106 is 53+53 */ - if (b[0] == 0x9A && b[7] == 0x3C && b[8] == 0x9A && b[15] == 0xBF) { - /* double double 128-bit little-endian, - * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */ - printf("5\n"); - exit(0); - } - if (b[0] == 0xBF && b[7] == 0x9A && b[8] == 0x3C && b[15] == 0x9A) { - /* double double 128-bit big-endian, e.g. PPC/Power and MIPS: - * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a */ - printf("6\n"); - exit(0); - } -#endif - printf("-1\n"); /* unknown */ - exit(0); -} -EOP -set try -if eval $compile; then - longdblkind=`$run ./try` -else - longdblkind=-1 -fi -;; -*) longdblkind=0 ;; -esac -case "$longdblkind" in -0) echo "Your long doubles are doubles." >&4 ;; -1) echo "You have IEEE 754 128-bit little endian long doubles." >&4 ;; -2) echo "You have IEEE 754 128-bit big endian long doubles." >&4 ;; -3) echo "You have x86 80-bit little endian long doubles." >& 4 ;; -*) echo "Cannot figure out your long double." >&4 ;; -esac -$rm_try - $cat >try.c <try.c < +#endif #include int main (int argc, char *argv[]) @@ -20346,20 +20651,29 @@ else fi fi -if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then +if $test X"$usequadmath" = X"$define"; then + nveformat='"Qe"' + nvfformat='"Qf"' + nvgformat='"Qg"' + nvEUformat='"QE"' + nvFUformat='"QF"' + nvGUformat='"QG"' +else + if $test X"$uselongdouble" = X"$define" -a X"$d_longdbl" = X"$define" -a X"$d_PRIgldbl" = X"$define"; then nveformat="$sPRIeldbl" nvfformat="$sPRIfldbl" nvgformat="$sPRIgldbl" nvEUformat="$sPRIEUldbl" nvFUformat="$sPRIFUldbl" nvGUformat="$sPRIGUldbl" -else + else nveformat='"e"' nvfformat='"f"' nvgformat='"g"' nvEUformat='"E"' nvFUformat='"F"' nvGUformat='"G"' + fi fi case "$ivdformat" in @@ -20532,7 +20846,7 @@ rp="What is the type used for the length parameter for string functions?" set size_t sizetype 'unsigned int' stdio.h sys/types.h eval $typedef_ask -: check for type of arguments to gethostbyaddr. +: check for type of arguments to gethostbyaddr. if test "X$netdb_host_type" = X -o "X$netdb_hlen_type" = X; then case "$d_gethbyaddr" in $define) @@ -20541,8 +20855,8 @@ if test "X$netdb_host_type" = X -o "X$netdb_hlen_type" = X; then Checking to see what type of arguments are accepted by gethostbyaddr(). EOM hdrs="$define sys/types.h - $d_socket sys/socket.h - $i_niin netinet/in.h + $d_socket sys/socket.h + $i_niin netinet/in.h $i_netdb netdb.h $i_unistd unistd.h" : The first arg can 'char *' or 'void *' @@ -20579,12 +20893,12 @@ EOM netdb_hlen_type="$sizetype" ;; esac - # Remove the "const" if needed. -- but then we'll have a + # Remove the "const" if needed. -- but then we'll have a # prototype clash! # netdb_host_type=`echo "$netdb_host_type" | sed 's/^const //'` fi -: check for type of argument to gethostbyname. +: check for type of argument to gethostbyname. if test "X$netdb_name_type" = X ; then case "$d_gethbyname" in $define) @@ -20593,8 +20907,8 @@ if test "X$netdb_name_type" = X ; then Checking to see what type of argument is accepted by gethostbyname(). EOM hdrs="$define sys/types.h - $d_socket sys/socket.h - $i_niin netinet/in.h + $d_socket sys/socket.h + $i_niin netinet/in.h $i_netdb netdb.h $i_unistd unistd.h" for xxx in "const char *" "char *"; do @@ -20622,7 +20936,7 @@ EOM esac fi -: check for type of 1st argument to getnetbyaddr. +: check for type of 1st argument to getnetbyaddr. if test "X$netdb_net_type" = X ; then case "$d_getnbyaddr" in $define) @@ -20631,8 +20945,8 @@ if test "X$netdb_net_type" = X ; then Checking to see what type of 1st argument is accepted by getnetbyaddr(). EOM hdrs="$define sys/types.h - $d_socket sys/socket.h - $i_niin netinet/in.h + $d_socket sys/socket.h + $i_niin netinet/in.h $i_netdb netdb.h $i_unistd unistd.h" for xxx in in_addr_t "unsigned long" long "unsigned int" int; do @@ -21996,6 +22310,10 @@ eval $inhdr set execinfo.h i_execinfo eval $inhdr +: see if this is a fenv.h system +set fenv.h i_fenv +eval $inhdr + : see if this is a fp.h system set fp.h i_fp eval $inhdr @@ -22418,6 +22736,10 @@ eval $setvar set stddef.h i_stddef eval $inhdr +: see if stdint is available +set stdint.h i_stdint +eval $inhdr + : see if sys/access.h is available set sys/access.h i_sysaccess eval $inhdr @@ -23123,6 +23445,7 @@ d_SCNfldbl='$d_SCNfldbl' d__fwalk='$d__fwalk' d_access='$d_access' d_accessx='$d_accessx' +d_acosh='$d_acosh' d_aintl='$d_aintl' d_alarm='$d_alarm' d_archlib='$d_archlib' @@ -23208,6 +23531,7 @@ d_fcntl_can_lock='$d_fcntl_can_lock' d_fd_macros='$d_fd_macros' d_fd_set='$d_fd_set' d_fds_bits='$d_fds_bits' +d_fegetround='$d_fegetround' d_fgetpos='$d_fgetpos' d_finite='$d_finite' d_finitel='$d_finitel' @@ -23216,10 +23540,13 @@ d_flock='$d_flock' d_flockproto='$d_flockproto' d_fork='$d_fork' d_fp_class='$d_fp_class' +d_fp_classify='$d_fp_classify' +d_fp_classl='$d_fp_classl' d_fpathconf='$d_fpathconf' d_fpclass='$d_fpclass' d_fpclassify='$d_fpclassify' d_fpclassl='$d_fpclassl' +d_fpgetround='$d_fpgetround' d_fpos64_t='$d_fpos64_t' d_frexpl='$d_frexpl' d_fs_data_s='$d_fs_data_s' @@ -23311,9 +23638,13 @@ d_ipv6_mreq_source='$d_ipv6_mreq_source' d_isascii='$d_isascii' d_isblank='$d_isblank' d_isfinite='$d_isfinite' +d_isfinitel='$d_isfinitel' d_isinf='$d_isinf' +d_isinfl='$d_isinfl' d_isnan='$d_isnan' d_isnanl='$d_isnanl' +d_j0='$d_j0' +d_j0l='$d_j0l' d_killpg='$d_killpg' d_lchown='$d_lchown' d_ldbl_dig='$d_ldbl_dig' @@ -23538,6 +23869,7 @@ d_tm_tm_gmtoff='$d_tm_tm_gmtoff' d_tm_tm_zone='$d_tm_tm_zone' d_tmpnam_r='$d_tmpnam_r' d_truncate='$d_truncate' +d_truncl='$d_truncl' d_ttyname_r='$d_ttyname_r' d_tzname='$d_tzname' d_u32align='$d_u32align' @@ -23677,6 +24009,7 @@ i_dirent='$i_dirent' i_dlfcn='$i_dlfcn' i_execinfo='$i_execinfo' i_fcntl='$i_fcntl' +i_fenv='$i_fenv' i_float='$i_float' i_fp='$i_fp' i_fp_class='$i_fp_class' @@ -23705,6 +24038,7 @@ i_poll='$i_poll' i_prot='$i_prot' i_pthread='$i_pthread' i_pwd='$i_pwd' +i_quadmath='$i_quadmath' i_rpcsvcdbm='$i_rpcsvcdbm' i_sgtty='$i_sgtty' i_shadow='$i_shadow' @@ -23712,6 +24046,7 @@ i_socks='$i_socks' i_stdarg='$i_stdarg' i_stdbool='$i_stdbool' i_stddef='$i_stddef' +i_stdint='$i_stdint' i_stdlib='$i_stdlib' i_string='$i_string' i_sunmath='$i_sunmath' @@ -24082,6 +24417,7 @@ usensgetexecutablepath='$usensgetexecutablepath' useopcode='$useopcode' useperlio='$useperlio' useposix='$useposix' +usequadmath='$usequadmath' usereentrant='$usereentrant' userelocatableinc='$userelocatableinc' useshrplib='$useshrplib' diff --git a/Cross/config.sh-arm-linux b/Cross/config.sh-arm-linux index abccb2c..ca36a55 100644 --- a/Cross/config.sh-arm-linux +++ b/Cross/config.sh-arm-linux @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='21' -api_versionstring='5.21.3' +api_versionstring='5.21.4' ar='ar' -archlib='/usr/lib/perl5/5.21.3/armv4l-linux' -archlibexp='/usr/lib/perl5/5.21.3/armv4l-linux' +archlib='/usr/lib/perl5/5.21.4/armv4l-linux' +archlibexp='/usr/lib/perl5/5.21.4/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -56,7 +56,7 @@ castflags='0' cat='cat' cc='cc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.3/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.4/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -106,6 +106,7 @@ d_SCNfldbl='define' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='define' d_aintl='undef' d_alarm='define' d_archlib='define' @@ -191,6 +192,7 @@ d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' d_fds_bits='undef' +d_fegetround='define' d_fgetpos='define' d_finite='define' d_finitel='define' @@ -199,10 +201,13 @@ d_flock='define' d_flockproto='define' d_fork='define' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='define' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='define' d_fs_data_s='undef' @@ -294,9 +299,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='define' +d_isinfl='define' d_isnan='define' d_isnanl='define' +d_j0='define' +d_j0l='define' d_killpg='define' d_lchown='define' d_ldbl_dig='define' @@ -519,6 +528,7 @@ d_tm_tm_gmtoff='define' d_tm_tm_zone='define' d_tmpnam_r='undef' d_truncate='define' +d_truncl='define' d_ttyname_r='undef' d_tzname='define' d_u32align='undef' @@ -654,6 +664,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='undef' +i_fenv='define' i_float='define' i_fp='undef' i_fp_class='undef' @@ -682,6 +693,7 @@ i_poll='define' i_prot='undef' i_pthread='define' i_pwd='define' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='define' @@ -689,6 +701,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='define' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -736,7 +749,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.21.3/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.21.4/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -744,13 +757,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.21.3' +installprivlib='./install_me_here/usr/lib/perl5/5.21.4' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.3' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.4' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -880,8 +893,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.21.3' -privlibexp='/usr/lib/perl5/5.21.3' +privlib='/usr/lib/perl5/5.21.4' +privlibexp='/usr/lib/perl5/5.21.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -946,17 +959,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.21.3' +sitelib='/usr/lib/perl5/site_perl/5.21.4' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.21.3' +sitelibexp='/usr/lib/perl5/site_perl/5.21.4' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -995,7 +1008,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' tail='' tar='' @@ -1050,6 +1063,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='define' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='true' @@ -1086,8 +1100,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.3' -version_patchlevel_string='version 21 subversion 3' +version='5.21.4' +version_patchlevel_string='version 21 subversion 4' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1101,9 +1115,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/Cross/config.sh-arm-linux-n770 b/Cross/config.sh-arm-linux-n770 index 19d9121..1f91767 100644 --- a/Cross/config.sh-arm-linux-n770 +++ b/Cross/config.sh-arm-linux-n770 @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='21' -api_versionstring='5.21.3' +api_versionstring='5.21.4' ar='ar' -archlib='/usr/lib/perl5/5.21.3/armv4l-linux' -archlibexp='/usr/lib/perl5/5.21.3/armv4l-linux' +archlib='/usr/lib/perl5/5.21.4/armv4l-linux' +archlibexp='/usr/lib/perl5/5.21.4/armv4l-linux' archname64='' archname='armv4l-linux' archobjs='' @@ -55,7 +55,7 @@ castflags='0' cat='cat' cc='arm-none-linux-gnueabi-gcc' cccdlflags='-fpic' -ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.3/armv4l-linux/CORE' +ccdlflags='-rdynamic -Wl,-rpath,/usr/lib/perl5/5.21.4/armv4l-linux/CORE' ccflags='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccflags_uselargefiles='-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64' ccname='arm-linux-gcc' @@ -699,7 +699,7 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='./install_me_here/usr/lib/perl5/5.21.3/armv4l-linux' +installarchlib='./install_me_here/usr/lib/perl5/5.21.4/armv4l-linux' installbin='./install_me_here/usr/bin' installhtml1dir='' installhtml3dir='' @@ -707,13 +707,13 @@ installman1dir='./install_me_here/usr/share/man/man1' installman3dir='./install_me_here/usr/share/man/man3' installprefix='./install_me_here/usr' installprefixexp='./install_me_here/usr' -installprivlib='./install_me_here/usr/lib/perl5/5.21.3' +installprivlib='./install_me_here/usr/lib/perl5/5.21.4' installscript='./install_me_here/usr/bin' -installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' +installsitearch='./install_me_here/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' installsitebin='./install_me_here/usr/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.3' +installsitelib='./install_me_here/usr/lib/perl5/site_perl/5.21.4' installsiteman1dir='./install_me_here/usr/share/man/man1' installsiteman3dir='./install_me_here/usr/share/man/man3' installsitescript='./install_me_here/usr/bin' @@ -841,8 +841,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/usr/lib/perl5/5.21.3' -privlibexp='/usr/lib/perl5/5.21.3' +privlib='/usr/lib/perl5/5.21.4' +privlibexp='/usr/lib/perl5/5.21.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -903,17 +903,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 6, 17, 29, 31, 0' sig_size='68' signal_t='void' -sitearch='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' -sitearchexp='/usr/lib/perl5/site_perl/5.21.3/armv4l-linux' +sitearch='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' +sitearchexp='/usr/lib/perl5/site_perl/5.21.4/armv4l-linux' sitebin='/usr/bin' sitebinexp='/usr/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/usr/lib/perl5/site_perl/5.21.3' +sitelib='/usr/lib/perl5/site_perl/5.21.4' sitelib_stem='/usr/lib/perl5/site_perl' -sitelibexp='/usr/lib/perl5/site_perl/5.21.3' +sitelibexp='/usr/lib/perl5/site_perl/5.21.4' siteman1dir='/usr/share/man/man1' siteman1direxp='/usr/share/man/man1' siteman3dir='/usr/share/man/man3' @@ -950,7 +950,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' tail='' tar='' @@ -1035,8 +1035,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.3' -version_patchlevel_string='version 21 subversion 3' +version='5.21.4' +version_patchlevel_string='version 21 subversion 4' versiononly='undef' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1050,9 +1050,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/INSTALL b/INSTALL index 378ed6f..3d0af04 100644 --- a/INSTALL +++ b/INSTALL @@ -329,11 +329,31 @@ range and precision of your double precision floating point numbers (that is, Perl's numbers). Use Configure -Duselongdouble to enable this support (if it is available). +Note that the exact format and range of long doubles varies: +the most common is the x86 80-bit (64 bits of mantissa) format, +but there are others, with different mantissa and exponent ranges. +In fact, the type may not be called "long double" at C level, and +therefore the C means "using floating point larger +than double". + =head3 "more bits" You can "Configure -Dusemorebits" to turn on both the 64-bit support and the long double support. +=head3 quadmath + +One option for long doubles is that gcc 4.6 and later have a library +called quadmath, which implements the IEEE 754 quadruple precision +(128-bit, 113 bits of mantissa) floating point numbers. The library +works at least on x86 and ia64 platforms. It may be part of your gcc +installation, or you may need to install it separately. + +With "Configure -Dusequadmath" you can try enabling its use, but note +the compiler dependency, you may need to also add "-Dcc=...". +This option also turns on -Duselongdouble. At C level the type is called +C<__float128> (note, not "long double"), but Perl source knows it as NV. + =head3 Algorithmic Complexity Attacks on Hashes Perl 5.18 reworked the measures used to secure its hash function @@ -563,7 +583,7 @@ The directories set up by Configure fall into three broad categories. =item Directories for the perl distribution -By default, Configure will use the following directories for 5.21.3. +By default, Configure will use the following directories for 5.21.4. $version is the full perl version number, including subversion, e.g. 5.12.3, and $archname is a string like sun4-sunos, determined by Configure. The full definitions of all Configure @@ -2416,7 +2436,7 @@ http://www.chiark.greenend.org.uk/~sgtatham/bugs.html =head1 Coexistence with earlier versions of perl 5 -Perl 5.21.3 is not binary compatible with earlier versions of Perl. +Perl 5.21.4 is not binary compatible with earlier versions of Perl. In other words, you will have to recompile your XS modules. In general, you can usually safely upgrade from one version of Perl (e.g. @@ -2490,9 +2510,9 @@ won't interfere with another version. (The defaults guarantee this for libraries after 5.6.0, but not for executables. TODO?) One convenient way to do this is by using a separate prefix for each version, such as - sh Configure -Dprefix=/opt/perl5.21.3 + sh Configure -Dprefix=/opt/perl5.21.4 -and adding /opt/perl5.21.3/bin to the shell PATH variable. Such users +and adding /opt/perl5.21.4/bin to the shell PATH variable. Such users may also wish to add a symbolic link /usr/local/bin/perl so that scripts can still start with #!/usr/local/bin/perl. @@ -2505,13 +2525,13 @@ seriously consider using a separate directory, since development subversions may not have all the compatibility wrinkles ironed out yet. -=head2 Upgrading from 5.21.1 or earlier +=head2 Upgrading from 5.21.3 or earlier -B Perl modules having binary parts (meaning that a C compiler is used) will have to be recompiled to be -used with 5.21.3. If you find you do need to rebuild an extension with -5.21.3, you may safely do so without disturbing the older +used with 5.21.4. If you find you do need to rebuild an extension with +5.21.4, you may safely do so without disturbing the older installations. (See L<"Coexistence with earlier versions of perl 5"> above.) @@ -2544,15 +2564,15 @@ Firstly, the bare minimum to run this script print("$f\n"); } -in Linux with perl-5.21.3 is as follows (under $Config{prefix}): +in Linux with perl-5.21.4 is as follows (under $Config{prefix}): ./bin/perl - ./lib/perl5/5.21.3/strict.pm - ./lib/perl5/5.21.3/warnings.pm - ./lib/perl5/5.21.3/i686-linux/File/Glob.pm - ./lib/perl5/5.21.3/feature.pm - ./lib/perl5/5.21.3/XSLoader.pm - ./lib/perl5/5.21.3/i686-linux/auto/File/Glob/Glob.so + ./lib/perl5/5.21.4/strict.pm + ./lib/perl5/5.21.4/warnings.pm + ./lib/perl5/5.21.4/i686-linux/File/Glob.pm + ./lib/perl5/5.21.4/feature.pm + ./lib/perl5/5.21.4/XSLoader.pm + ./lib/perl5/5.21.4/i686-linux/auto/File/Glob/Glob.so Secondly, for perl-5.10.1, the Debian perl-base package contains 591 files, (of which 510 are for lib/unicore) totaling about 3.5MB in its i386 version. diff --git a/MANIFEST b/MANIFEST index 8479f03..f5b5464 100644 --- a/MANIFEST +++ b/MANIFEST @@ -696,6 +696,7 @@ cpan/Digest-SHA/lib/Digest/SHA.pm Digest::SHA extension cpan/Digest-SHA/Makefile.PL Digest::SHA Makefile.PL cpan/Digest-SHA/shasum shasum script cpan/Digest-SHA/SHA.xs Digest::SHA extension +cpan/Digest-SHA/src/sdf.c Digest::SHA extension cpan/Digest-SHA/src/sha64bit.c Digest::SHA extension cpan/Digest-SHA/src/sha64bit.h Digest::SHA extension cpan/Digest-SHA/src/sha.c Digest::SHA extension @@ -947,7 +948,6 @@ cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm generate XS code for p cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm generate XS code to import C header constants cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm generate XS code to import C header constants cpan/ExtUtils-Constant/t/Constant.t See if ExtUtils::Constant works -cpan/ExtUtils-Install/Changes ExtUtils-Install change log cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm Information on installed extensions cpan/ExtUtils-Install/lib/ExtUtils/Install.pm Handles 'make install' on extensions cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm Manipulates .packlist files @@ -1338,6 +1338,7 @@ cpan/IO-Socket-IP/t/18fdopen.t IO::Socket::IP tests cpan/IO-Socket-IP/t/19no-addrs.t IO::Socket::IP tests cpan/IO-Socket-IP/t/20subclass.t IO::Socket::IP tests cpan/IO-Socket-IP/t/21as-inet.t IO::Socket::IP tests +cpan/IO-Socket-IP/t/22timeout.t cpan/IO-Socket-IP/t/30nonblocking-connect.t IO::Socket::IP tests cpan/IO-Socket-IP/t/31nonblocking-connect-internet.t IO::Socket::IP tests cpan/IO-Socket-IP/t/99pod.t IO::Socket::IP tests @@ -1967,6 +1968,7 @@ cpan/Pod-Usage/t/pod/usage.pod cpan/Scalar-List-Utils/lib/List/Util.pm List::Util cpan/Scalar-List-Utils/lib/List/Util/XS.pm List::Util cpan/Scalar-List-Utils/lib/Scalar/Util.pm Scalar::Util +cpan/Scalar-List-Utils/lib/Sub/Util.pm cpan/Scalar-List-Utils/ListUtil.xs Util extension cpan/Scalar-List-Utils/Makefile.PL Util extension cpan/Scalar-List-Utils/multicall.h Util extension @@ -1985,13 +1987,15 @@ cpan/Scalar-List-Utils/t/min.t List::Util cpan/Scalar-List-Utils/t/openhan.t Scalar::Util cpan/Scalar-List-Utils/t/pair.t cpan/Scalar-List-Utils/t/product.t List::Util -cpan/Scalar-List-Utils/t/proto.t Scalar::Util +cpan/Scalar-List-Utils/t/prototype.t cpan/Scalar-List-Utils/t/readonly.t Scalar::Util cpan/Scalar-List-Utils/t/reduce.t List::Util cpan/Scalar-List-Utils/t/refaddr.t Scalar::Util cpan/Scalar-List-Utils/t/reftype.t Scalar::Util +cpan/Scalar-List-Utils/t/scalarutil-proto.t cpan/Scalar-List-Utils/t/shuffle.t List::Util cpan/Scalar-List-Utils/t/stack-corruption.t List::Util +cpan/Scalar-List-Utils/t/subname.t cpan/Scalar-List-Utils/t/sum0.t cpan/Scalar-List-Utils/t/sum.t List::Util cpan/Scalar-List-Utils/t/tainted.t Scalar::Util @@ -2869,6 +2873,7 @@ dist/Data-Dumper/t/perl-74170.t Regression test for stack reallocation dist/Data-Dumper/t/purity_deepcopy_maxdepth.t See if three Data::Dumper functions work dist/Data-Dumper/t/qr.t See if Data::Dumper works with qr|/| dist/Data-Dumper/t/quotekeys.t See if Data::Dumper::Quotekeys works +dist/Data-Dumper/t/recurse.t See if Data::Dumper::Maxrecurse works dist/Data-Dumper/t/seen.t See if Data::Dumper::Seen works dist/Data-Dumper/t/sortkeys.t See if Data::Dumper::Sortkeys works dist/Data-Dumper/t/sparseseen.t See if Data::Dumper::Sparseseen works @@ -3160,7 +3165,6 @@ dist/Module-CoreList/Makefile.PL Module::CoreList dist/Module-CoreList/MANIFEST Module::CoreList dist/Module-CoreList/README Module::CoreList dist/Module-CoreList/t/corelist.t Module::CoreList tests -dist/Module-CoreList/t/corevers.t Module::CoreList tests dist/Module-CoreList/t/deprecated.t Module::CoreList tests dist/Module-CoreList/t/find_modules.t Module::CoreList tests dist/Module-CoreList/t/is_core.t Module::CoreList tests @@ -3791,6 +3795,7 @@ ext/XS-APItest/t/coplabel.t test cop_*_label ext/XS-APItest/t/copstash.t test alloccopstash ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API ext/XS-APItest/t/customop.t XS::APItest: tests for custom ops +ext/XS-APItest/t/cv_name.t test cv_name ext/XS-APItest/t/eval-filter.t Simple source filter/eval test ext/XS-APItest/t/exception.t XS::APItest extension ext/XS-APItest/t/fetch_pad_names.t Tests for UTF8 names in pad @@ -4005,6 +4010,7 @@ lib/Benchmark.pm Measure execution time lib/Benchmark.t See if Benchmark works lib/blib.pm For "use blib" lib/blib.t blib.pm test +lib/B/Op_private.pm Definitions of OP op_private flags lib/bytes_heavy.pl Support routines for byte pragma lib/bytes.pm Pragma to enable byte operations lib/bytes.t bytes.pm test @@ -4448,9 +4454,11 @@ pod/perl5180delta.pod Perl changes in version 5.18.0 pod/perl5181delta.pod Perl changes in version 5.18.1 pod/perl5182delta.pod Perl changes in version 5.18.2 pod/perl5200delta.pod Perl changes in version 5.20.0 +pod/perl5201delta.pod Perl changes in version 5.20.1 pod/perl5210delta.pod Perl changes in version 5.21.0 pod/perl5211delta.pod Perl changes in version 5.21.1 pod/perl5212delta.pod Perl changes in version 5.21.2 +pod/perl5213delta.pod Perl changes in version 5.21.3 pod/perl561delta.pod Perl changes in version 5.6.1 pod/perl56delta.pod Perl changes in version 5.6 pod/perl581delta.pod Perl changes in version 5.8.1 @@ -4692,6 +4700,7 @@ regen/mk_invlists.pl Generates charclass_invlists.h regen/mk_PL_charclass.pl Populate the PL_charclass table regen/opcode.pl Opcode header generator regen/opcodes Opcode data +regen/op_private Definitions of bits in an OP's op_private field regen/overload.pl generate overload.h regen_perly.pl generate perly.{act,h,tab} from perly.y regen.pl Run all scripts that (re)generate files @@ -5096,6 +5105,7 @@ t/op/incfilter.t See if the source filters in coderef-in-@INC work t/op/inc.t See if inc/dec of integers near 32 bit limit work t/op/index.t See if index works t/op/index_thr.t See if index works in another thread +t/op/infnan.t See if inf/nan work t/op/int.t See if int works t/op/join.t See if join works t/op/kill0_child Process tree script that is kill()ed @@ -5292,6 +5302,7 @@ t/re/reg_nc_tie.t Test the tied methods of Tie::Hash::NamedCapture t/re/reg_pmod.t See if regexp /p modifier works as expected t/re/reg_posixcc.t See if posix character classes behave consistently t/re/re_tests Regular expressions for regexp.t +t/re/rt122747.t Test rt122747 assert faile (requires DEBUGGING) t/re/rxcode.t See if /(?{ code })/ works t/re/subst_amp.t See if $&-related substitution works t/re/subst.t See if substitution works diff --git a/META.json b/META.json index 256c67d..852d29e 100644 --- a/META.json +++ b/META.json @@ -124,5 +124,5 @@ "url" : "http://perl5.git.perl.org/" } }, - "version" : "5.021003" + "version" : "5.021004" } diff --git a/META.yml b/META.yml index d0a211e..e964f49 100644 --- a/META.yml +++ b/META.yml @@ -111,4 +111,4 @@ resources: homepage: http://www.perl.org/ license: http://dev.perl.org/licenses/ repository: http://perl5.git.perl.org/ -version: '5.021003' +version: '5.021004' diff --git a/Makefile.SH b/Makefile.SH index cbeed00..6a2c6ce 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -489,7 +489,7 @@ mini_obj = $(minindt_obj) $(MINIDTRACE_O) ndt_obj = $(obj0) $(obj1) $(obj2) $(obj3) $(ARCHOBJS) obj = $(ndt_obj) $(DTRACE_O) -perltoc_pod_prereqs = extra.pods pod/perl5213delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod +perltoc_pod_prereqs = extra.pods pod/perl5214delta.pod pod/perlapi.pod pod/perlintern.pod pod/perlmodlib.pod pod/perluniprops.pod generated_pods = pod/perltoc.pod $(perltoc_pod_prereqs) generated_headers = uudmap.h bitcount.h mg_data.h @@ -555,11 +555,11 @@ splintfiles = $(c1) @echo `$(CCCMD)` $(PLDLFLAGS) $*.c @`$(CCCMD)` $(PLDLFLAGS) $*.c -.c.i: +.c.i: perl.h config.h @echo `$(CCCMDSRC)` -E $*.c \> $*.i @`$(CCCMDSRC)` -E $*.c > $*.i -.c.s: +.c.s: perl.h config.h @echo `$(CCCMDSRC)` -S $*.c @`$(CCCMDSRC)` -S $*.c @@ -999,9 +999,9 @@ pod/perlintern.pod: $(MINIPERL_EXE) autodoc.pl embed.fnc pod/perlmodlib.pod: $(MINIPERL_EXE) pod/perlmodlib.PL MANIFEST $(MINIPERL) pod/perlmodlib.PL -q -pod/perl5213delta.pod: pod/perldelta.pod - $(RMS) pod/perl5213delta.pod - $(LNS) perldelta.pod pod/perl5213delta.pod +pod/perl5214delta.pod: pod/perldelta.pod + $(RMS) pod/perl5214delta.pod + $(LNS) perldelta.pod pod/perl5214delta.pod extra.pods: $(MINIPERL_EXE) -@test ! -f extra.pods || rm -f `cat extra.pods` @@ -1302,21 +1302,21 @@ _cleaner2: -rmdir lib/TAP/Parser/Scheduler lib/TAP/Parser/Result -rmdir lib/TAP/Parser/Iterator lib/TAP/Parser lib/TAP/Harness -rmdir lib/TAP/Formatter/File lib/TAP/Formatter/Console - -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Search - -rmdir lib/Scalar lib/Pod/Text lib/Pod/Simple lib/Pod/Perldoc - -rmdir lib/PerlIO/via lib/PerlIO lib/Perl lib/Parse/CPAN lib/Parse - -rmdir lib/Params lib/Net/FTP lib/Module/Load lib/Module/CoreList - -rmdir lib/Module lib/Memoize lib/Math/BigInt lib/Math/BigFloat - -rmdir lib/Math lib/MIME lib/Locale/Maketext lib/Locale/Codes - -rmdir lib/Locale lib/List/Util lib/List lib/JSON/PP lib/JSON lib/IPC - -rmdir lib/IO/Uncompress/Adapter lib/IO/Uncompress lib/IO/Socket - -rmdir lib/IO/Compress/Zlib lib/IO/Compress/Zip lib/IO/Compress/Gzip - -rmdir lib/IO/Compress/Base lib/IO/Compress/Adapter lib/IO/Compress - -rmdir lib/IO lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash - -rmdir lib/HTTP lib/Filter/Util lib/Filter lib/File/Spec - -rmdir lib/ExtUtils/Typemaps lib/ExtUtils/ParseXS - -rmdir lib/ExtUtils/MakeMaker lib/ExtUtils/Liblist - -rmdir lib/ExtUtils/Constant lib/ExtUtils/Command + -rmdir lib/TAP/Formatter lib/TAP lib/Sys/Syslog lib/Sys lib/Sub + -rmdir lib/Search lib/Scalar lib/Pod/Text lib/Pod/Simple + -rmdir lib/Pod/Perldoc lib/PerlIO/via lib/PerlIO lib/Perl + -rmdir lib/Parse/CPAN lib/Parse lib/Params lib/Net/FTP lib/Module/Load + -rmdir lib/Module/CoreList lib/Module lib/Memoize lib/Math/BigInt + -rmdir lib/Math/BigFloat lib/Math lib/MIME lib/Locale/Maketext + -rmdir lib/Locale/Codes lib/Locale lib/List/Util lib/List lib/JSON/PP + -rmdir lib/JSON lib/IPC lib/IO/Uncompress/Adapter lib/IO/Uncompress + -rmdir lib/IO/Socket lib/IO/Compress/Zlib lib/IO/Compress/Zip + -rmdir lib/IO/Compress/Gzip lib/IO/Compress/Base + -rmdir lib/IO/Compress/Adapter lib/IO/Compress lib/IO + -rmdir lib/I18N/LangTags lib/I18N lib/Hash/Util lib/Hash lib/HTTP + -rmdir lib/Filter/Util lib/Filter lib/File/Spec lib/ExtUtils/Typemaps + -rmdir lib/ExtUtils/ParseXS lib/ExtUtils/MakeMaker + -rmdir lib/ExtUtils/Liblist lib/ExtUtils/Constant lib/ExtUtils/Command -rmdir lib/ExtUtils/CBuilder/Platform/Windows -rmdir lib/ExtUtils/CBuilder/Platform lib/ExtUtils/CBuilder -rmdir lib/Exporter lib/Encode/Unicode lib/Encode/MIME/Header @@ -1368,7 +1368,7 @@ done $spitshell >>$Makefile <<'!NO!SUBS!' .PHONY: depend -depend: makedepend $(DTRACE_H) +depend: makedepend $(DTRACE_H) $(generated_headers) sh ./makedepend MAKE="$(MAKE)" cflags .PHONY: test check test_prep test_prep_nodll test_prep_pre \ diff --git a/NetWare/Makefile b/NetWare/Makefile index 4eb3ca4..4ba4d3d 100644 --- a/NetWare/Makefile +++ b/NetWare/Makefile @@ -86,7 +86,7 @@ NLM_VERSION = 3,20,0 # Here comes the CW tools - TO BE FILLED TO BUILD WITH CW - -MODULE_DESC = "Perl 5.21.3 for NetWare" +MODULE_DESC = "Perl 5.21.4 for NetWare" CCTYPE = CodeWarrior C_COMPILER = mwccnlm -c CPP_COMPILER = mwccnlm @@ -462,7 +462,7 @@ INST_NW_TOP2 = $(INST_NW_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -INST_VER = \5.21.3 +INST_VER = \5.21.4 # # Comment this out if you DON'T want your perl installation to have diff --git a/NetWare/config.wc b/NetWare/config.wc index fde25b1..1407c44 100644 --- a/NetWare/config.wc +++ b/NetWare/config.wc @@ -93,6 +93,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='undef' d_archlib='define' @@ -179,6 +180,7 @@ d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' +d_fegetround='undef' d_fgetpos='define' d_finite='undef' d_finitel='undef' @@ -187,10 +189,13 @@ d_flock='define' d_flockproto='undef' d_fork='undef' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -283,9 +288,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='undef' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='define' @@ -509,6 +518,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='undef' @@ -636,6 +646,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -664,6 +675,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='define' i_sgtty='undef' i_shadow='undef' @@ -671,6 +683,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='define' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -1013,6 +1026,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='undef' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='true' diff --git a/NetWare/config_H.wc b/NetWare/config_H.wc index 803a549..40c0a47 100644 --- a/NetWare/config_H.wc +++ b/NetWare/config_H.wc @@ -1042,7 +1042,7 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "c:\\perl\\5.21.3\\lib\\NetWare-x86-multi-thread" /**/ +#define ARCHLIB "c:\\perl\\5.21.4\\lib\\NetWare-x86-multi-thread" /**/ /*#define ARCHLIB_EXP "" /**/ /* ARCHNAME: @@ -1073,8 +1073,8 @@ * This symbol is the filename expanded version of the BIN symbol, for * programs that do not want to deal with that at run-time. */ -#define BIN "c:\\perl\\5.21.3\\bin\\NetWare-x86-multi-thread" /**/ -#define BIN_EXP "c:\\perl\\5.21.3\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN "c:\\perl\\5.21.4\\bin\\NetWare-x86-multi-thread" /**/ +#define BIN_EXP "c:\\perl\\5.21.4\\bin\\NetWare-x86-multi-thread" /**/ /* BYTEORDER: * This symbol holds the hexadecimal constant defined in byteorder, @@ -3051,7 +3051,7 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "c:\\perl\\site\\5.21.3\\lib\\NetWare-x86-multi-thread" /**/ +#define SITEARCH "c:\\perl\\site\\5.21.4\\lib\\NetWare-x86-multi-thread" /**/ /*#define SITEARCH_EXP "" /**/ /* SITELIB: @@ -3074,7 +3074,7 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "c:\\perl\\site\\5.21.3\\lib" /**/ +#define SITELIB "c:\\perl\\site\\5.21.4\\lib" /**/ /*#define SITELIB_EXP "" /**/ #define SITELIB_STEM "" /**/ diff --git a/Porting/Glossary b/Porting/Glossary index eb50a61..e28bb56 100644 --- a/Porting/Glossary +++ b/Porting/Glossary @@ -405,6 +405,10 @@ d_accessx (d_accessx.U): This variable conditionally defines the HAS_ACCESSX symbol, which indicates to the C program that the accessx() routine is available. +d_acosh (d_acosh.U): + This variable conditionally defines the HAS_ACOSH symbol, which + indicates to the C program that the acosh() routine is available. + d_aintl (d_aintl.U): This variable conditionally defines the HAS_AINTL symbol, which indicates to the C program that the aintl() routine is available. @@ -804,6 +808,10 @@ d_fds_bits (d_fd_set.U): a half-fast job and neglected to provide the macros to manipulate an fd_set, HAS_FDS_BITS will let us know how to fix the gaffe. +d_fegetround (d_fegetround.U): + This variable conditionally defines HAS_FEGETROUND if fegetround() is + available to get the floating point rounding mode. + d_fgetpos (d_fgetpos.U): This variable conditionally defines HAS_FGETPOS if fgetpos() is available to get the file position indicator. @@ -838,6 +846,14 @@ d_fp_class (d_fp_class.U): This variable conditionally defines the HAS_FP_CLASS symbol, which indicates to the C program that the fp_class() routine is available. +d_fp_classify (d_fpclassify.U): + This variable conditionally defines the HAS_FP_CLASSIFY symbol, which + indicates to the C program that the fp_classify() routine is available. + +d_fp_classl (d_fp_classl.U): + This variable conditionally defines the HAS_FP_CLASSL symbol, which + indicates to the C program that the fp_classl() routine is available. + d_fpathconf (d_pathconf.U): This variable conditionally defines the HAS_FPATHCONF symbol, which indicates to the C program that the pathconf() routine is available @@ -856,6 +872,10 @@ d_fpclassl (d_fpclassl.U): This variable conditionally defines the HAS_FPCLASSL symbol, which indicates to the C program that the fpclassl() routine is available. +d_fpgetround (d_fpgetround.U): + This variable conditionally defines HAS_FPGETROUND if fpgetround() + is available to get the floating point rounding mode. + d_fpos64_t (d_fpos64_t.U): This symbol will be defined if the C compiler supports fpos64_t. @@ -1309,10 +1329,18 @@ d_isfinite (d_isfinite.U): This variable conditionally defines the HAS_ISFINITE symbol, which indicates to the C program that the isfinite() routine is available. +d_isfinitel (d_isfinitel.U): + This variable conditionally defines the HAS_ISFINITEL symbol, which + indicates to the C program that the isfinitel() routine is available. + d_isinf (d_isinf.U): This variable conditionally defines the HAS_ISINF symbol, which indicates to the C program that the isinf() routine is available. +d_isinfl (d_isinfl.U): + This variable conditionally defines the HAS_ISINFL symbol, which + indicates to the C program that the isinfl() routine is available. + d_isnan (d_isnan.U): This variable conditionally defines the HAS_ISNAN symbol, which indicates to the C program that the isnan() routine is available. @@ -1321,6 +1349,14 @@ d_isnanl (d_isnanl.U): This variable conditionally defines the HAS_ISNANL symbol, which indicates to the C program that the isnanl() routine is available. +d_j0 (d_j0.U): + This variable conditionally defines the HAS_J0 symbol, which + indicates to the C program that the j0() routine is available. + +d_j0l (d_j0.U): + This variable conditionally defines the HAS_J0L symbol, which + indicates to the C program that the j0l() routine is available. + d_killpg (d_killpg.U): This variable conditionally defines the HAS_KILLPG symbol, which indicates to the C program that the killpg() routine is available @@ -1336,7 +1372,7 @@ d_ldbl_dig (d_ldbl_dig.U): header files provide LDBL_DIG, which is the number of significant digits in a long double precision number. -d_ldexpl (d_ldexpl.U): +d_ldexpl (d_longdbl.U): This variable conditionally defines the HAS_LDEXPL symbol, which indicates to the C program that the ldexpl() routine is available. @@ -2413,6 +2449,12 @@ d_truncate (d_truncate.U): This variable conditionally defines HAS_TRUNCATE if truncate() is available to truncate files. +d_truncl (d_truncl.U): + This variable conditionally defines the HAS_TRUNCL symbol, which + indicates to the C program that the truncl() routine is available + to round long doubles towards zero. If copysignl is also present, + we can emulate modfl. + d_ttyname_r (d_ttyname_r.U): This variable conditionally defines the HAS_TTYNAME_R symbol, which indicates to the C program that the ttyname_r() @@ -3086,6 +3128,11 @@ i_fcntl (i_fcntl.U): This variable controls the value of I_FCNTL (which tells the C program to include ). +i_fenv (i_fenv.U): + This variable conditionally defines the I_FENV symbol, which + indicates to the C program that exists and should + be included. + i_float (i_float.U): This variable conditionally defines the I_FLOAT symbol, and indicates whether a C program may include to get symbols like DBL_MAX @@ -3208,6 +3255,10 @@ i_pwd (i_pwd.U): This variable conditionally defines I_PWD, which indicates to the C program that it should include . +i_quadmath (i_quadmath.U): + This variable conditionally defines I_QUADMATH, which indicates + to the C program that it should include . + i_rpcsvcdbm (i_dbm.U): This variable conditionally defines the I_RPCSVC_DBM symbol, which indicates to the C program that exists and should @@ -3241,6 +3292,11 @@ i_stddef (i_stddef.U): indicates to the C program that exists and should be included. +i_stdint (i_stdint.U): + This variable conditionally defines the I_STDINT symbol, which + indicates to the C program that exists and should + be included. + i_stdlib (i_stdlib.U): This variable conditionally defines the I_STDLIB symbol, which indicates to the C program that exists and should @@ -3800,7 +3856,7 @@ loclibpth (libpth.U): libraries. It is prepended to libpth, and is intended to be easily set from the command line. -longdblkind (longdblkind.U): +longdblkind (d_longdbl.U): This variable, if defined, encodes the type of a long double: 0 = double, 1 = IEEE 754 128-bit big little endian, 2 = IEEE 754 128-bit big big endian, 3 = x86 80-bit little endian, @@ -5192,6 +5248,11 @@ useposix (Extensions.U): for hints files to indicate that POSIX will not compile on a particular system. +usequadmath (usequadmath.U): + This variable conditionally defines the USE_QUADMATH symbol, + and indicates that the quadmath library __float128 long doubles + should be used when available. + usereentrant (usethreads.U): This variable conditionally defines the USE_REENTRANT_API symbol, which indicates that the thread code may try to use the various diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index ef3efbc..57df910 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -16,13 +16,13 @@ use File::Glob qw(:case); # complain if it can't find them) @IGNORABLE = qw( - .cvsignore .dualLivedDiffConfig .gitignore + .cvsignore .dualLivedDiffConfig .gitignore .perlcriticrc .perltidyrc ANNOUNCE Announce Artistic AUTHORS BENCHMARK BUGS Build.PL CHANGELOG ChangeLog Changelog CHANGES Changes CONTRIBUTING COPYING Copying cpanfile CREDITS dist.ini GOALS HISTORY INSTALL INSTALL.SKIP LICENSE Makefile.PL MANIFEST MANIFEST.SKIP META.json META.yml MYMETA.json - MYMETA.yml NEW NOTES perlcritic.rc ppport.h README README.PATCHING - SIGNATURE THANKS TODO Todo VERSION WHATSNEW .perlcriticrc.perltidyrc + MYMETA.yml NEW NEWS NOTES perlcritic.rc ppport.h README README.PATCHING + SIGNATURE THANKS TODO Todo VERSION WHATSNEW ); # Each entry in the %Modules hash roughly represents a distribution, @@ -119,7 +119,7 @@ use File::Glob qw(:case); %Modules = ( 'Archive::Tar' => { - 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.00.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Archive-Tar-2.02.tar.gz', 'FILES' => q[cpan/Archive-Tar], 'BUGS' => 'bug-archive-tar@rt.cpan.org', 'EXCLUDED' => [ @@ -298,13 +298,13 @@ use File::Glob qw(:case); }, 'CPAN::Meta::Requirements' => { - 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.126.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/CPAN-Meta-Requirements-2.128.tar.gz', 'FILES' => q[cpan/CPAN-Meta-Requirements], 'EXCLUDED' => [ qw(CONTRIBUTING.mkdn), - qw(t/00-compile.t), qw(t/00-report-prereqs.t), qw(t/00-report-prereqs.dd), + qw(t/version-cleanup.t), qr{^xt}, ], }, @@ -321,7 +321,7 @@ use File::Glob qw(:case); }, 'Data::Dumper' => { - 'DISTRIBUTION' => 'SMUELLER/Data-Dumper-2.151.tar.gz', + 'DISTRIBUTION' => 'SMUELLER/Data-Dumper-2.154.tar.gz', 'FILES' => q[dist/Data-Dumper], }, @@ -379,6 +379,9 @@ use File::Glob qw(:case); examples/dups ), ], + # Was hoping to be merged upstream in CPAN RT#96498, + # but that has been rejected... + 'CUSTOMIZED' => ['hints/hpux.pl'], }, 'Dumpvalue' => { @@ -408,7 +411,7 @@ use File::Glob qw(:case); }, 'experimental' => { - 'DISTRIBUTION' => 'LEONT/experimental-0.008.tar.gz', + 'DISTRIBUTION' => 'LEONT/experimental-0.010.tar.gz', 'FILES' => q[cpan/experimental], 'EXCLUDED' => [ qr{^t/release-.*\.t}, @@ -427,7 +430,7 @@ use File::Glob qw(:case); }, 'ExtUtils::CBuilder' => { - 'DISTRIBUTION' => 'AMBS/ExtUtils/ExtUtils-CBuilder-0.280216.tar.gz', + 'DISTRIBUTION' => 'AMBS/ExtUtils-CBuilder-0.280219.tar.gz', 'FILES' => q[dist/ExtUtils-CBuilder], 'EXCLUDED' => [ qw(README.mkdn), @@ -457,7 +460,7 @@ use File::Glob qw(:case); }, 'ExtUtils::Install' => { - 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-1.68.tar.gz', + 'DISTRIBUTION' => 'BINGOS/ExtUtils-Install-2.04.tar.gz', 'FILES' => q[cpan/ExtUtils-Install], 'EXCLUDED' => [ qw( t/lib/Test/Builder.pm @@ -482,10 +485,18 @@ use File::Glob qw(:case); 'PATCHING', 'README.packaging', ], + 'CUSTOMIZED' => [ + # Already merged upstream in GitHub 0116aaf4e, just awaiting + # a new stable CPAN release + qw( t/pm_to_blib.t ), + # Already merged upstream in GitHub 46586b12c, just awaiting + # a new stable CPAN release + qw( lib/ExtUtils/Liblist/Kid.pm ), + ], }, 'ExtUtils::Manifest' => { - 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.65.tar.gz', + 'DISTRIBUTION' => 'BINGOS/ExtUtils-Manifest-1.68.tar.gz', 'FILES' => q[cpan/ExtUtils-Manifest], 'EXCLUDED' => [qr(^xt/)], }, @@ -583,7 +594,7 @@ use File::Glob qw(:case); }, 'HTTP::Tiny' => { - 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.047.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/HTTP-Tiny-0.049.tar.gz', 'FILES' => q[cpan/HTTP-Tiny], 'EXCLUDED' => [ 't/00-report-prereqs.t', @@ -630,7 +641,7 @@ use File::Glob qw(:case); }, 'IO::Socket::IP' => { - 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.31.tar.gz', + 'DISTRIBUTION' => 'PEVANS/IO-Socket-IP-0.32.tar.gz', 'FILES' => q[cpan/IO-Socket-IP], 'EXCLUDED' => [ qr{^examples/}, @@ -684,7 +695,7 @@ use File::Glob qw(:case); }, 'Locale-Codes' => { - 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.31.tar.gz', + 'DISTRIBUTION' => 'SBECK/Locale-Codes-3.32.tar.gz', 'FILES' => q[cpan/Locale-Codes], 'EXCLUDED' => [ qw( README.first @@ -788,7 +799,7 @@ use File::Glob qw(:case); }, 'Module::CoreList' => { - 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.021002.tar.gz', + 'DISTRIBUTION' => 'BINGOS/Module-CoreList-5.20140914.tar.gz', 'FILES' => q[dist/Module-CoreList], }, @@ -902,7 +913,7 @@ use File::Glob qw(:case); }, 'Pod::Perldoc' => { - 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.23.tar.gz', + 'DISTRIBUTION' => 'MALLEN/Pod-Perldoc-3.24.tar.gz', 'FILES' => q[cpan/Pod-Perldoc], # Note that we use the CPAN-provided Makefile.PL, since it @@ -954,7 +965,7 @@ use File::Glob qw(:case); }, 'Scalar-List-Utils' => { - 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.39.tar.gz', + 'DISTRIBUTION' => 'PEVANS/Scalar-List-Utils-1.41.tar.gz', 'FILES' => q[cpan/Scalar-List-Utils], }, @@ -970,7 +981,7 @@ use File::Glob qw(:case); }, 'Socket' => { - 'DISTRIBUTION' => 'PEVANS/Socket-2.014.tar.gz', + 'DISTRIBUTION' => 'PEVANS/Socket-2.015.tar.gz', 'FILES' => q[cpan/Socket], }, @@ -1031,7 +1042,7 @@ use File::Glob qw(:case); }, 'Test::Harness' => { - 'DISTRIBUTION' => 'LEONT/Test-Harness-3.32.tar.gz', + 'DISTRIBUTION' => 'LEONT/Test-Harness-3.33.tar.gz', 'FILES' => q[cpan/Test-Harness], 'EXCLUDED' => [ qr{^examples/}, @@ -1050,7 +1061,7 @@ use File::Glob qw(:case); }, 'Test::Simple' => { - 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001003.tar.gz', + 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001006.tar.gz', 'FILES' => q[cpan/Test-Simple], 'EXCLUDED' => [ qr{^t/xt}, @@ -1160,7 +1171,7 @@ use File::Glob qw(:case); }, 'threads' => { - 'DISTRIBUTION' => 'JDHEDDEN/threads-1.92.tar.gz', + 'DISTRIBUTION' => 'JDHEDDEN/threads-1.96.tar.gz', 'FILES' => q[dist/threads], 'EXCLUDED' => [ qr{^examples/}, @@ -1207,7 +1218,7 @@ use File::Glob qw(:case); }, 'Time::Piece' => { - 'DISTRIBUTION' => 'RJBS/Time-Piece-1.27.tar.gz', + 'DISTRIBUTION' => 'RJBS/Time-Piece-1.29.tar.gz', 'FILES' => q[cpan/Time-Piece], }, @@ -1231,7 +1242,7 @@ use File::Glob qw(:case); }, 'version' => { - 'DISTRIBUTION' => 'JPEACOCK/version-0.9908.tar.gz', + 'DISTRIBUTION' => 'JPEACOCK/version-0.9909.tar.gz', 'FILES' => q[cpan/version vutil.c vutil.h vxs.inc], 'EXCLUDED' => [ qr{^vutil/lib/}, @@ -1250,7 +1261,6 @@ use File::Glob qw(:case); # Merged upstream, waiting for new CPAN release: see CPAN RT#92721 qw( vutil.c - vxs.inc ), ], @@ -1352,6 +1362,7 @@ use File::Glob qw(:case); lib/AnyDBM_File.{pm,t} lib/Benchmark.{pm,t} lib/B/Deparse{.pm,.t,-core.t} + lib/B/Op_private.pm lib/CORE.pod lib/Class/Struct.{pm,t} lib/Config.t diff --git a/Porting/bisect-runner.pl b/Porting/bisect-runner.pl index 572c0cc..263e9b7 100755 --- a/Porting/bisect-runner.pl +++ b/Porting/bisect-runner.pl @@ -582,7 +582,7 @@ F is run, and C and C code isn't patched until after F is built. If C<--all-fixups> is specified, all the fixups are done before running C. In rare cases adding this may cause a bisect to abort, because an inapplicable patch or other fixup is attempted -for a revision which would usually have already Ied. If this happens, +for a revision which would usually have already Iped. If this happens, please report it as a bug, giving the OS and problem revision. =item * diff --git a/Porting/bisect.pl b/Porting/bisect.pl index 81a7d9b..6a51f67 100755 --- a/Porting/bisect.pl +++ b/Porting/bisect.pl @@ -225,7 +225,7 @@ system 'git', 'bisect', 'run', $^X, $runner, @ARGV and die; END { my $end_time = time; - printf "That took %d seconds\n", $end_time - $start_time + printf "That took %d seconds.\n", $end_time - $start_time if defined $start_time; } diff --git a/Porting/cmpVERSION.pl b/Porting/cmpVERSION.pl index c92fe78..37017cf 100755 --- a/Porting/cmpVERSION.pl +++ b/Porting/cmpVERSION.pl @@ -95,7 +95,6 @@ my %skip; my %skip_versions = ( # 'some/sample/file.pm' => [ '1.23', '1.24' ], - 'dist/threads/lib/threads.pm' => [ '1.83' ], ); my $skip_dirs = qr|^t/lib|; @@ -120,6 +119,7 @@ sub pm_file_from_xs { # look for a .pm in lib/ based on that: my ($path) = shift =~ m!^(.*)/!; my ($last) = $path =~ m!([^/]+)\z!; + $last = 'List-Util' if $last eq 'Scalar-List-Utils'; $last =~ tr !-!/!; return "$path/lib/$last"; }) { diff --git a/Porting/config.sh b/Porting/config.sh index 6f76268..cda4fc5 100644 --- a/Porting/config.sh +++ b/Porting/config.sh @@ -39,12 +39,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/hostname' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='21' -api_versionstring='5.21.3' +api_versionstring='5.21.4' ar='ar' -archlib='/pro/lib/perl5/5.21.3/i686-linux-64int' -archlibexp='/pro/lib/perl5/5.21.3/i686-linux-64int' +archlib='/pro/lib/perl5/5.21.4/i686-linux-64int' +archlibexp='/pro/lib/perl5/5.21.4/i686-linux-64int' archname64='64int' archname='i686-linux-64int' archobjs='' @@ -115,6 +115,7 @@ d_SCNfldbl='define' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='define' d_archlib='define' @@ -200,6 +201,7 @@ d_fcntl_can_lock='define' d_fd_macros='define' d_fd_set='define' d_fds_bits='undef' +d_fegetround='undef' d_fgetpos='define' d_finite='define' d_finitel='define' @@ -208,10 +210,13 @@ d_flock='define' d_flockproto='define' d_fork='define' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='define' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='define' d_fs_data_s='undef' @@ -303,9 +308,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='define' d_isfinite='undef' +d_isfinitel='undef' d_isinf='define' +d_isinfl='undef' d_isnan='define' d_isnanl='define' +d_j0='undef' +d_j0l='undef' d_killpg='define' d_lchown='define' d_ldbl_dig='define' @@ -530,6 +539,7 @@ d_tm_tm_gmtoff='define' d_tm_tm_zone='define' d_tmpnam_r='undef' d_truncate='define' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' @@ -669,6 +679,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='undef' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -697,6 +708,7 @@ i_poll='define' i_prot='undef' i_pthread='define' i_pwd='define' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='define' @@ -704,6 +716,7 @@ i_socks='define' i_stdarg='define' i_stdbool='define' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -753,7 +766,7 @@ incpath='' incpth='/usr/lib/gcc/i586-suse-linux/4.8/include /usr/local/include /usr/lib/gcc/i586-suse-linux/4.8/include-fixed /usr/lib/gcc/i586-suse-linux/4.8/../../../../i586-suse-linux/include /usr/include' inews='' initialinstalllocation='/pro/bin' -installarchlib='/pro/lib/perl5/5.21.3/i686-linux-64int' +installarchlib='/pro/lib/perl5/5.21.4/i686-linux-64int' installbin='/pro/bin' installhtml1dir='' installhtml3dir='' @@ -761,13 +774,13 @@ installman1dir='/pro/local/man/man1' installman3dir='/pro/local/man/man3' installprefix='/pro' installprefixexp='/pro' -installprivlib='/pro/lib/perl5/5.21.3' +installprivlib='/pro/lib/perl5/5.21.4' installscript='/pro/bin' -installsitearch='/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int' +installsitearch='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int' installsitebin='/pro/bin' installsitehtml1dir='' installsitehtml3dir='' -installsitelib='/pro/lib/perl5/site_perl/5.21.3' +installsitelib='/pro/lib/perl5/site_perl/5.21.4' installsiteman1dir='/pro/local/man/man1' installsiteman3dir='/pro/local/man/man3' installsitescript='/pro/bin' @@ -889,7 +902,7 @@ perl_patchlevel='' perl_static_inline='static __inline__' perladmin='hmbrand@cpan.org' perllibs='-lnsl -ldl -lm -lcrypt -lutil -lc' -perlpath='/pro/bin/perl5.21.3' +perlpath='/pro/bin/perl5.21.4' pg='pg' phostname='hostname' pidtype='pid_t' @@ -898,8 +911,8 @@ pmake='' pr='' prefix='/pro' prefixexp='/pro' -privlib='/pro/lib/perl5/5.21.3' -privlibexp='/pro/lib/perl5/5.21.3' +privlib='/pro/lib/perl5/5.21.4' +privlibexp='/pro/lib/perl5/5.21.4' procselfexe='"/proc/self/exe"' prototype='define' ptrsize='4' @@ -965,17 +978,17 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 6, 17, 29, 31, 0' sig_size='69' signal_t='void' -sitearch='/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int' -sitearchexp='/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int' +sitearch='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int' +sitearchexp='/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int' sitebin='/pro/bin' sitebinexp='/pro/bin' sitehtml1dir='' sitehtml1direxp='' sitehtml3dir='' sitehtml3direxp='' -sitelib='/pro/lib/perl5/site_perl/5.21.3' +sitelib='/pro/lib/perl5/site_perl/5.21.4' sitelib_stem='/pro/lib/perl5/site_perl' -sitelibexp='/pro/lib/perl5/site_perl/5.21.3' +sitelibexp='/pro/lib/perl5/site_perl/5.21.4' siteman1dir='/pro/local/man/man1' siteman1direxp='/pro/local/man/man1' siteman3dir='/pro/local/man/man3' @@ -1001,7 +1014,7 @@ src='.' ssizetype='ssize_t' st_ino_sign='1' st_ino_size='8' -startperl='#!/pro/bin/perl5.21.3' +startperl='#!/pro/bin/perl5.21.4' startsh='#!/bin/sh' static_ext=' ' stdchar='char' @@ -1014,7 +1027,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/usr/include/string.h' submit='' -subversion='3' +subversion='4' sysman='/usr/share/man/man1' sysroot='' tail='' @@ -1075,6 +1088,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='define' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='false' @@ -1112,8 +1126,8 @@ vendorprefix='' vendorprefixexp='' vendorscript='' vendorscriptexp='' -version='5.21.3' -version_patchlevel_string='version 21 subversion 3' +version='5.21.4' +version_patchlevel_string='version 21 subversion 4' versiononly='define' vi='' xlibpth='/usr/lib/386 /lib/386' @@ -1123,10 +1137,10 @@ zcat='' zip='zip' PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL='' PERL_CONFIG_SH=true : Variables propagated from previous config.sh file. diff --git a/Porting/config_H b/Porting/config_H index dc21a7b..40e802c 100644 --- a/Porting/config_H +++ b/Porting/config_H @@ -960,8 +960,8 @@ * This symbol contains the ~name expanded version of ARCHLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define ARCHLIB "/pro/lib/perl5/5.21.3/i686-linux-64int-ld" /**/ -#define ARCHLIB_EXP "/pro/lib/perl5/5.21.3/i686-linux-64int-ld" /**/ +#define ARCHLIB "/pro/lib/perl5/5.21.4/i686-linux-64int-ld" /**/ +#define ARCHLIB_EXP "/pro/lib/perl5/5.21.4/i686-linux-64int-ld" /**/ /* ARCHNAME: * This symbol holds a string representing the architecture name. @@ -2068,8 +2068,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/pro/lib/perl5/5.21.3" /**/ -#define PRIVLIB_EXP "/pro/lib/perl5/5.21.3" /**/ +#define PRIVLIB "/pro/lib/perl5/5.21.4" /**/ +#define PRIVLIB_EXP "/pro/lib/perl5/5.21.4" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -2119,8 +2119,8 @@ * This symbol contains the ~name expanded version of SITEARCH, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define SITEARCH "/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int-ld" /**/ -#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.3/i686-linux-64int-ld" /**/ +#define SITEARCH "/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int-ld" /**/ +#define SITEARCH_EXP "/pro/lib/perl5/site_perl/5.21.4/i686-linux-64int-ld" /**/ /* SITELIB: * This symbol contains the name of the private library for this package. @@ -2142,8 +2142,8 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/pro/lib/perl5/site_perl/5.21.3" /**/ -#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.3" /**/ +#define SITELIB "/pro/lib/perl5/site_perl/5.21.4" /**/ +#define SITELIB_EXP "/pro/lib/perl5/site_perl/5.21.4" /**/ #define SITELIB_STEM "/pro/lib/perl5/site_perl" /**/ /* SSize_t: @@ -4326,7 +4326,7 @@ * script to make sure (one hopes) that it runs with perl and not * some shell. */ -#define STARTPERL "#!/pro/bin/perl5.21.3" /**/ +#define STARTPERL "#!/pro/bin/perl5.21.4" /**/ /* HAS_STDIO_STREAM_ARRAY: * This symbol, if defined, tells that there is an array diff --git a/Porting/epigraphs.pod b/Porting/epigraphs.pod index 20f4230..001ffa4 100644 --- a/Porting/epigraphs.pod +++ b/Porting/epigraphs.pod @@ -17,6 +17,136 @@ Consult your favorite dictionary for details. =head1 EPIGRAPHS +=head2 v5.20.1 - Lorenzo da Ponte, Così fan tutte + +L + + DORABELLA (as if waking from a daze): Where are they? + DON ALFONSO: They've gone. + FIORDILIGI: Oh, the cruel bitterness of parting! + + DON ALFONSO: + Take heart, my dearest children. + Look, in the distance, your lovers are waving to you. + + FIORDILIGI: Bon voyage, my darling! + DORABELLA: Bon voyage! + + FIORDILIGI: + O heavens! How swiftly the ship is sailing away! + It is disappearing already! + It is no longer in sight! + Oh, may heaven grant it a prosperous voyage! + + DORABELLA: May good luck attend it to the battlefield! + DON ALFONSO: And may your sweethearts and my friends be safe! + + FIORDILIGI, DORABELLA, DON ALFONSO: + May the wind be gentle, + may the sea be calm, + and may the elements + respond kindly + to our wishes. + + -- Lorenzo da Ponte, /Così fan tutte/, + trans. Diana Reed + +=head2 v5.20.1-RC2 - Lorenzo da Ponte, Così fan tutte + +L + + GUGLIELMO: + Oh God, I feel that this foot of mine + is reluctant to come before her. + + FERRANDO: + My trembling lip + can utter no word. + + DON ALFONSO: + The hero displays his manliness + in the most terrible moments. + + FIORDILIGI, DORABELLA: + Now that we have heard the news, + you have the lesser duty: + Take heart, and plunge your swords + into both our hearts. + + FERRANDO, GUGLIELMO: + My idol, blame fate + that I must abandon you. + + DORABELLA: Ah no, you shall not leave... + FIORDILIGI: No, cruel one, you shall not go... + DORABELLA: First I want to tear out my heart. + FIORDILIGI: First I want to die at your feet. + FERRANDO (softly to Don Alfonso): What do you say to that? + GUGLIELMO (softly to Don Alfonso): You realise? + DON ALFONSO (softly): Steady, friend, finem lauda. + + ALL: + Thus destiny defrauds + the hopes of mortals. + Ah, among so many misfortunes, + who can ever love life? + + -- Lorenzo da Ponte, /Così fan tutte/, + trans. William Weaver + +=head2 v5.20.1-RC1 - Lorenzo da Ponte, Così fan tutte + +L + + DON ALFONSO: + I'd like to speak, but I haven't the heart: + my lip stammers. + My voice cannot emerge, + but remains in my throat. + What will you do? What shall I do? + Oh what a great catastrophe! + There can be nothing worse. + I feel pity for you and for them. + + FIORDILIGI: Heavens! For mercy's sake, Signor Alfonso, don't make us + die. + DON ALFONSO: My children, you must arm yourselves with constancy. + DORABELLA: Ye Gods! What evil has occurred? What horrible event? Is my + love dead, perhaps? + FIORDILIGI: Is mine dead? + DON ALFONSO: They are not dead, but they are not far from it. + DORABELLA: Wounded? + DON ALFONSO: No. + FIORDILIGI: Ill? + DON ALFONSO: Nor that. + FIORDILIGI: What, then? + DON ALFONSO: A royal command summons them to the field of battle. + FIORDILIGI, DORABELLA: Alas, what do I hear? And they will leave? + DON ALFONSO: Immediately. + DORABELLA: And there is no way of preventing it? + DON ALFONSO: There is none. + FIORDILIGI: And not even a single farewell... + DON ALFONSO: The unhappy men haven't the courage to see you; but if + you wish it, they are ready... + DORABELLA: Where are they? + DON ALFONSO: Come in, friends. + + -- Lorenzo da Ponte, /Così fan tutte/, + trans. William Weaver + +=head2 v5.21.3 - Robert Service, The Men that Don't Fit In + +L + + If they just went straight they might go far, + They are strong and brave and true; + But they're always tired of the things that are, + And they want the strange and new. + They say: "Could I find my proper groove, + What a deep mark I would make!" + So they chop and change, and each fresh move + Is only a fresh mistake. + =head2 v5.21.2 - Neil Armstrong, Buzz Aldrin, Charlie Duke, Final minutes of communication of the first manned moon landing, July 20, 1969. L diff --git a/Porting/perldelta_template.pod b/Porting/perldelta_template.pod index 9e4ce59..d904a50 100644 --- a/Porting/perldelta_template.pod +++ b/Porting/perldelta_template.pod @@ -378,7 +378,7 @@ here. XXX Generate this with: - perl Porting/acknowledgements.pl v5.21.3..HEAD + perl Porting/acknowledgements.pl v5.21.4..HEAD =head1 Reporting Bugs diff --git a/Porting/release_announcement_template.txt b/Porting/release_announcement_template.txt index fbd8d22..5f2e897 100644 --- a/Porting/release_announcement_template.txt +++ b/Porting/release_announcement_template.txt @@ -3,7 +3,7 @@ -- [ATTRIBUTION] We are [SYNONYM FOR 'pleased'] to announce version [VERSION.SUBVERSION], -the [N-TH] development release of version 19 of Perl 5. +the [N-TH] development release of version [VERSION] of Perl 5. You will soon be able to download Perl 5.[VERSION.SUBVERSION] from your favorite CPAN mirror or find it at: @@ -21,7 +21,7 @@ the "pod" directory inside the release and on the web. [ACKNOWLEDGEMENTS SECTION FROM PERLDELTA] We expect to release version [NEXT BLEAD VERSION.SUBVERSION] on [FUTURE -DATE]. The next major stable release of Perl 5, version 20.0, should -appear in May 2014. +DATE]. The next major stable release of Perl 5, version 22.0, should +appear in May 2015. [YOUR SALUTATION HERE] diff --git a/Porting/release_schedule.pod b/Porting/release_schedule.pod index 18f8fd3..32f54b6 100644 --- a/Porting/release_schedule.pod +++ b/Porting/release_schedule.pod @@ -14,12 +14,11 @@ deemed necessary by the Pumpking. =head2 Perl 5.20 2014-05-27 5.20.0 ✓ Ricardo Signes - 2014-08-?? 5.20.1 Steve Hay + 2014-09-14 5.20.1 ✓ Steve Hay + 2015-01-?? 5.20.2 Steve Hay =head2 Perl 5.18 -Release schedule (with release manager): - 2013-05-18 5.18.0 ✓ Ricardo Signes 2013-08-12 5.18.1 ✓ Ricardo Signes 2014-01-06 5.18.2 ✓ Ricardo Signes @@ -43,13 +42,13 @@ you should reset the version numbers to the next blead series. 2014-05-20 5.21.0 ✓ Ricardo Signes 2014-06-20 5.21.1 ✓ Matthew Horsfall - 2014-07-20 5.21.2 Abigail - 2014-08-20 5.21.3 Peter Martini + 2014-07-20 5.21.2 ✓ Abigail + 2014-08-20 5.21.3 ✓ Peter Martini 2014-09-20 5.21.4 Steve Hay - 2014-10-20 5.21.5 ? - 2014-11-20 5.21.6 ? - 2014-12-20 5.21.7 ? - 2015-01-20 5.21.8 ? + 2014-10-20 5.21.5 Abigail + 2014-11-20 5.21.6 Chris "BinGOs" Williams + 2014-12-20 5.21.7 Max Maischein + 2015-01-20 5.21.8 Matthew Horsfall 2015-02-20 5.21.9 ? 2015-03-20 5.21.10 ? 2015-04-20 5.21.11 ? @@ -78,7 +77,9 @@ Jesse Luehrs Jesse Vincent Leon Brocard Matt Trout +Matthew Horsfall Max Maischein +Peter Martini Philippe Bruhat Ricardo Signes Stevan Little diff --git a/Porting/todo.pod b/Porting/todo.pod index b67f106..4fba938 100644 --- a/Porting/todo.pod +++ b/Porting/todo.pod @@ -467,7 +467,7 @@ Natively 64-bit systems need neither -Duse64bitint nor -Duse64bitall. On these systems, it might be the default compilation mode, and there is currently no guarantee that passing no use64bitall option to the Configure process will build a 32bit perl. Implementing -Duse32bit* -options would be nice for perl 5.21.3. +options would be nice for perl 5.21.4. =head2 Profile Perl - am I hot or not? @@ -1015,14 +1015,15 @@ The old perltodo notes "Look at the "reification" code in C". =head2 Virtualize operating system access Implement a set of "vtables" that virtualizes operating system access -(open(), mkdir(), unlink(), readdir(), getenv(), etc.) At the very -least these interfaces should take SVs as "name" arguments instead of -bare char pointers; probably the most flexible and extensible way -would be for the Perl-facing interfaces to accept HVs. The system -needs to be per-operating-system and per-file-system -hookable/filterable, preferably both from XS and Perl level -(L is good reading at this point, -in fact, all of L is.) +(chdir(), chmod(), dbmopen(), getenv(), glob(), link(), mkdir(), open(), +opendir(), readdir(), rename(), rmdir(), stat(), sysopen(), uname(), +unlink(), etc.) At the very least these interfaces should take SVs as +"name" arguments instead of bare char pointers; probably the most +flexible and extensible way would be for the Perl-facing interfaces to +accept HVs. The system needs to be per-operating-system and +per-file-system hookable/filterable, preferably both from XS and Perl +level (L is good reading at this +point, in fact, all of L is.) This has actually already been implemented (but only for Win32), take a look at F and F. While all Win32 @@ -1168,7 +1169,7 @@ L =head1 Big projects Tasks that will get your name mentioned in the description of the "Highlights -of 5.21.3" +of 5.21.4" =head2 make ithreads more robust diff --git a/README.haiku b/README.haiku index 16aa478..fade672 100644 --- a/README.haiku +++ b/README.haiku @@ -22,9 +22,9 @@ The build procedure is completely standard: Make perl executable and create a symlink for libperl: chmod a+x /boot/common/bin/perl - cd /boot/common/lib; ln -s perl5/5.21.3/BePC-haiku/CORE/libperl.so . + cd /boot/common/lib; ln -s perl5/5.21.4/BePC-haiku/CORE/libperl.so . -Replace C<5.21.3> with your respective version of Perl. +Replace C<5.21.4> with your respective version of Perl. =head1 KNOWN PROBLEMS diff --git a/README.macosx b/README.macosx index 40ffd47..1a5d811 100644 --- a/README.macosx +++ b/README.macosx @@ -10,9 +10,9 @@ perlmacosx - Perl under Mac OS X This document briefly describes Perl under Mac OS X. - curl -O http://www.cpan.org/src/perl-5.21.3.tar.gz - tar -xzf perl-5.21.3.tar.gz - cd perl-5.21.3 + curl -O http://www.cpan.org/src/perl-5.21.4.tar.gz + tar -xzf perl-5.21.4.tar.gz + cd perl-5.21.4 ./Configure -des -Dprefix=/usr/local/ make make test @@ -20,7 +20,7 @@ This document briefly describes Perl under Mac OS X. =head1 DESCRIPTION -The latest Perl release (5.21.3 as of this writing) builds without changes +The latest Perl release (5.21.4 as of this writing) builds without changes under all versions of Mac OS X from 10.3 "Panther" onwards. In order to build your own version of Perl you will need 'make', diff --git a/README.os2 b/README.os2 index 46278a8..ae03a56 100644 --- a/README.os2 +++ b/README.os2 @@ -619,7 +619,7 @@ C in F, see L<"PERLLIB_PREFIX">. =item Additional Perl modules - unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.3/ + unzip perl_ste.zip -d f:/perllib/lib/site_perl/5.21.4/ Same remark as above applies. Additionally, if this directory is not one of directories on @INC (and @INC is influenced by C), you diff --git a/README.vms b/README.vms index 99a5649..894d02c 100644 --- a/README.vms +++ b/README.vms @@ -142,11 +142,11 @@ You may need to set up a foreign symbol for the unpacking utility of choice. Once you have done so, use a command like the following to unpack the archive: - vmstar -xvf perl-5^.21^.3.tar + vmstar -xvf perl-5^.21^.4.tar Then set default to the top-level source directory like so: - set default [.perl-5^.21^.3] + set default [.perl-5^.21^.4] and proceed with configuration as described in the next section. diff --git a/TestInit.pm b/TestInit.pm index 16eb318..f4ed6fd 100644 --- a/TestInit.pm +++ b/TestInit.pm @@ -76,7 +76,16 @@ sub import { } else { # (likely) we're being run by t/TEST or t/harness, and we're a test # in t/ - @INC = '../lib'; + if (defined &DynaLoader::boot_DynaLoader) { + @INC = '../lib'; + } + else { + # miniperl/minitest + # t/TEST does not supply -I../lib, so buildcustomize.pl is + # not automatically included. + unshift @INC, '../lib'; + do "../lib/buildcustomize.pl"; + } } } diff --git a/cflags.SH b/cflags.SH index 6bfa188..031b780 100755 --- a/cflags.SH +++ b/cflags.SH @@ -317,6 +317,21 @@ case "$gccversion" in ;; esac +# The quadmath Q format specifier will cause -Wformat to whine. +case "$gccversion" in +'') ;; +*) case "$usequadmath" in + define) + for f in -Wno-format + do + echo "cflags.SH: Adding $f because of usequadmath." + warn="$warn $f" + done + ;; + esac + ;; +esac + case "$cc" in *g++*) # Extra paranoia in case people have bad canned ccflags: diff --git a/config_h.SH b/config_h.SH index 168feee..7aae94f 100755 --- a/config_h.SH +++ b/config_h.SH @@ -1935,6 +1935,11 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ +/* HAS_LDEXPL: + * This symbol, if defined, indicates that the ldexpl routine is + * available to shift a long double floating-point number + * by an integral power of 2. + */ /* LONG_DOUBLEKIND: * LONG_DOUBLEKIND will be one of * LONG_DOUBLE_IS_DOUBLE @@ -1947,6 +1952,7 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * LONG_DOUBLE_IS_UNKNOWN_FORMAT * It is only defined if the system supports long doubles. */ +#$d_ldexpl HAS_LDEXPL /**/ #$d_longdbl HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE $longdblsize /**/ @@ -2876,6 +2882,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$d_pwgecos PWGECOS /**/ #$d_pwpasswd PWPASSWD /**/ +/* I_QUADMATH: + * This symbol, if defined, indicates to the C program that it should + * include . + */ +#$i_quadmath I_QUADMATH /**/ + /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . @@ -3406,6 +3418,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d__fwalk HAS__FWALK /**/ +/* HAS_ACOSH: + * This symbol, if defined, indicates that the acosh routine is + * available to do the inverse hyperbolic cosine function. + */ +#$d_acosh HAS_ACOSH /**/ + /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. @@ -3516,6 +3534,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_fcntl_can_lock FCNTL_CAN_LOCK /**/ +/* HAS_FEGETROUND: + * This symbol, if defined, indicates that the fegetround routine is + * available to return the macro corresponding to the current rounding + * mode. + */ +#$d_fegetround HAS_FEGETROUND /**/ + /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). @@ -3555,6 +3580,13 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_fp_class HAS_FP_CLASS /**/ +/* HAS_FP_CLASSL: + * This symbol, if defined, indicates that the fp_classl routine is + * available to classify long doubles. Available for example in + * Digital UNIX. See for possible values HAS_FP_CLASS. + */ +#$d_fp_classl HAS_FP_CLASSL /**/ + /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. @@ -3585,7 +3617,19 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un * FP_NAN NaN * */ -#$d_fpclassify HAS_FPCLASSIFY /**/ +/* HAS_FP_CLASSIFY: + * This symbol, if defined, indicates that the fp_classify routine is + * available to classify doubles. The values are defined in + * + * FP_NORMAL Normalized + * FP_ZERO Zero + * FP_INFINITE Infinity + * FP_SUBNORMAL Denormalized + * FP_NAN NaN + * + */ +#$d_fpclassify HAS_FPCLASSIFY /**/ +#$d_fp_classify HAS_FP_CLASSIFY /**/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is @@ -3605,6 +3649,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_fpclassl HAS_FPCLASSL /**/ +/* HAS_FPGETROUND: + * This symbol, if defined, indicates that the fpgetround routine is + * available to get the floating point rounding mode. + */ +#$d_fpgetround HAS_FPGETROUND /**/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ @@ -3617,13 +3667,6 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_frexpl HAS_FREXPL /**/ -/* HAS_LDEXPL: - * This symbol, if defined, indicates that the ldexpl routine is - * available to shift a long double floating-point number - * by an integral power of 2. - */ -#$d_ldexpl HAS_LDEXPL /**/ - /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. @@ -3764,12 +3807,25 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_isfinite HAS_ISFINITE /**/ +/* HAS_ISFINITEL: + * This symbol, if defined, indicates that the isfinitel routine is + * available to check whether a long double is finite. + * (non-infinity non-NaN). + */ +#$d_isfinitel HAS_ISFINITEL /**/ + /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ #$d_isinf HAS_ISINF /**/ +/* HAS_ISINFL: + * This symbol, if defined, indicates that the isinfl routine is + * available to check whether a long double is an infinity. + */ +#$d_isinfl HAS_ISINFL /**/ + /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. @@ -3782,6 +3838,19 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_isnanl HAS_ISNANL /**/ +/* HAS_J0: + * This symbol, if defined, indicates to the C program that the + * j0() function is available for Bessel functions of the first + * kind of the order zero, for doubles. + */ +/* HAS_J0L: + * This symbol, if defined, indicates to the C program that the + * j0l() function is available for Bessel functions of the first + * kind of the order zero, for long doubles. + */ +#$d_j0 HAS_J0 /**/ +#$d_j0l HAS_J0L /**/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number @@ -4166,6 +4235,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$d_timegm HAS_TIMEGM /**/ +/* HAS_TRUNCL: + * This symbol, if defined, indicates that the truncl routine is + * available. If copysignl is also present we can emulate modfl. + */ +#$d_truncl HAS_TRUNCL /**/ + /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. @@ -4295,6 +4370,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #define DB_VERSION_MINOR_CFG $db_version_minor /**/ #define DB_VERSION_PATCH_CFG $db_version_patch /**/ +/* I_FENV: + * This symbol, if defined, indicates to the C program that it should + * include to get the floating point environment definitions. + */ +#$i_fenv I_FENV /**/ + /* I_FP: * This symbol, if defined, indicates that exists and * should be included. @@ -4379,6 +4460,12 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un */ #$i_stdbool I_STDBOOL /**/ +/* I_STDINT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +#$i_stdint I_STDINT /**/ + /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. @@ -4762,6 +4849,14 @@ sed <$CONFIG_H -e 's!^#undef\(.*/\)\*!/\*#define\1 \*!' -e 's!^#un #$uselongdouble USE_LONG_DOUBLE /**/ #endif +/* USE_QUADMATH: + * This symbol, if defined, indicates that the quadmath library should + * be used when available. + */ +#ifndef USE_QUADMATH +#$usequadmath USE_QUADMATH /**/ +#endif + /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. diff --git a/configpm b/configpm index d5bf5f2..21bd3ef 100755 --- a/configpm +++ b/configpm @@ -628,6 +628,24 @@ foreach my $prefix (qw(libs libswanted)) { $heavy_txt .= "${prefix}_nolargefiles='$value'\n"; } +if (open(my $fh, "cflags")) { + my $ccwarnflags; + my $ccstdflags; + while (<$fh>) { + if (/^warn="(.+)"$/) { + $ccwarnflags = $1; + } elsif (/^stdflags="(.+)"$/) { + $ccstdflags = $1; + } + } + if (defined $ccwarnflags) { + $heavy_txt .= "ccwarnflags='$ccwarnflags'\n"; + } + if (defined $ccstdflags) { + $heavy_txt .= "ccstdflags='$ccstdflags'\n"; + } +} + $heavy_txt .= "EOVIRTUAL\n"; $heavy_txt .= <<'ENDOFGIT'; diff --git a/configure.com b/configure.com index 1fb5fb3..0bb1a75 100644 --- a/configure.com +++ b/configure.com @@ -3374,9 +3374,17 @@ $ IF useieee .OR. useieee .EQS. "define" $ THEN $ d_isnan = "define" $ d_isnanl = "define" +$ d_fp_classify = "define" +$ d_j0 = "define" +$ d_acosh = "define" +$ d_truncl = "define" $ ELSE $ d_isnan = "undef" $ d_isnanl = "undef" +$ d_fp_classify = "undef" +$ d_j0 = "undef" +$ d_acosh = "undef" +$ d_truncl = "undef" $ ENDIF $! $! Now some that we build up @@ -5885,6 +5893,7 @@ $ WC "d_SCNfldbl='" + d_SCNfldbl + "'" $ WC "d__fwalk='undef'" $ WC "d_access='" + d_access + "'" $ WC "d_accessx='undef'" +$ WC "d_acosh='" + d_acosh + "'" $ WC "d_aintl='undef'" $ WC "d_alarm='define'" $ WC "d_archlib='define'" @@ -5967,6 +5976,7 @@ $ WC "d_fcntl_can_lock='" + d_fcntl_can_lock + "'" $ WC "d_fd_set='" + d_fd_set + "'" $ WC "d_fd_macros='define'" $ WC "d_fds_bits='define'" +$ WC "d_fegetround='undef'" $ WC "d_fgetpos='define'" $ IF F$ELEMENT(0, "-", archname) .NES. "VMS_VAX" .AND. use_ieee_math $ THEN @@ -5981,10 +5991,14 @@ $ WC "d_flock='undef'" $ WC "d_flockproto='undef'" $ WC "d_fork='undef'" $ WC "d_fp_class='undef'" +$ WC "d_fp_classify='" + d_fp_classify + "'" +$ WC "d_fp_classify='undef'" +$ WC "d_fp_classl='undef'" $ WC "d_fpathconf='" + d_fpathconf + "'" $ WC "d_fpclass='undef'" $ WC "d_fpclassify='undef'" $ WC "d_fpclassl='undef'" +$ WC "d_fpgetround='undef'" $ WC "d_fpos64_t='" + d_fpos64_t + "'" $ WC "d_frexpl='" + d_frexpl + "'" $ WC "d_fs_data_s='undef'" @@ -6064,15 +6078,14 @@ $ WC "d_ipv6_mreq='define'" $ WC "d_ipv6_mreq_source='undef'" $ WC "d_isascii='define'" $ WC "d_isblank='undef'" -$ IF F$ELEMENT(0, "-", archname) .NES. "VMS_VAX" .AND. use_ieee_math -$ THEN -$ WC "d_isfinite='define'" -$ ELSE -$ WC "d_isfinite='undef'" -$ ENDIF +$ WC "d_isfinite='undef'" +$ WC "d_isfinitel='undef'" $ WC "d_isinf='undef'" +$ WC "d_isinfl='undef'" $ WC "d_isnan='" + d_isnan + "'" $ WC "d_isnanl='" + d_isnanl + "'" +$ WC "d_j0='" + d_j0 + "'" +$ WC "d_j0l='undef'" $ WC "d_killpg='undef'" $ WC "d_lchown='" + d_lchown + "'" $ WC "d_ldbl_dig='define'" @@ -6305,6 +6318,7 @@ $ WC "d_tm_tm_gmtoff='undef'" $ WC "d_tm_tm_zone='undef'" $ ENDIF $ WC "d_truncate='" + d_truncate + "'" +$ WC "d_truncl='" + d_truncl + "'" $ WC "d_tzname='" + d_tzname + "'" $ WC "d_u32align='define'" $ WC "d_ualarm='" + d_ualarm + "'" @@ -6405,6 +6419,7 @@ $ WC "i_dirent='undef'" ! we roll our own $ WC "i_dlfcn='undef'" $ WC "i_execinfo='undef'" $ WC "i_fcntl='" + i_fcntl + "'" +$ WC "i_fenv='undef'" $ WC "i_float='define'" $ WC "i_fp='undef'" $ WC "i_fp_class='undef'" @@ -6434,6 +6449,7 @@ $ WC "i_poll='" + i_poll + "'" $ WC "i_prot='undef'" $ WC "i_pthread='define'" $ WC "i_pwd='undef'" +$ WC "i_quadmath='undef'" $ WC "i_rpcsvcdbm='undef'" $ WC "i_sgtty='undef'" $ WC "i_shadow='" + i_shadow + "'" @@ -6446,6 +6462,7 @@ $ ELSE $ WC "i_stdbool='undef'" $ ENDIF $ WC "i_stddef='define'" +$ WC "i_stdint='undef'" $ WC "i_stdlib='define'" $ WC "i_string='define'" $ WC "i_sunmath='undef'" @@ -6713,6 +6730,7 @@ $ WC "usemultiplicity='" + usemultiplicity + "'" $ WC "usemymalloc='" + usemymalloc + "'" $ WC "useperlio='define'" $ WC "useposix='false'" +$ WC "usequadmath='undef'" $ WC "usereentrant='undef'" $ WC "userelocatableinc='undef'" $ WC "usesecurelog='" + usesecurelog + "'" ! VMS-specific diff --git a/cpan/Archive-Tar/lib/Archive/Tar.pm b/cpan/Archive-Tar/lib/Archive/Tar.pm index 5cbea64..ddb174d 100644 --- a/cpan/Archive-Tar/lib/Archive/Tar.pm +++ b/cpan/Archive-Tar/lib/Archive/Tar.pm @@ -31,7 +31,7 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD $DEBUG = 0; $WARN = 1; $FOLLOW_SYMLINK = 0; -$VERSION = "2.00"; +$VERSION = "2.02"; $CHOWN = 1; $CHMOD = 1; $SAME_PERMISSIONS = $> == 0 ? 1 : 0; diff --git a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm index ac0c5c6..19a95dc 100644 --- a/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm +++ b/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm @@ -3,7 +3,7 @@ package Archive::Tar::Constant; BEGIN { require Exporter; - $VERSION = '2.00'; + $VERSION = '2.02'; @ISA = qw[Exporter]; require Time::Local if $^O eq "MacOS"; diff --git a/cpan/Archive-Tar/lib/Archive/Tar/File.pm b/cpan/Archive-Tar/lib/Archive/Tar/File.pm index e204753..d5ee6af 100644 --- a/cpan/Archive-Tar/lib/Archive/Tar/File.pm +++ b/cpan/Archive-Tar/lib/Archive/Tar/File.pm @@ -13,7 +13,7 @@ use Archive::Tar::Constant; use vars qw[@ISA $VERSION]; #@ISA = qw[Archive::Tar]; -$VERSION = '2.00'; +$VERSION = '2.02'; ### set value to 1 to oct() it during the unpack ### diff --git a/cpan/Archive-Tar/t/08_ptargrep.t b/cpan/Archive-Tar/t/08_ptargrep.t index 62131ae..a5cf591 100644 --- a/cpan/Archive-Tar/t/08_ptargrep.t +++ b/cpan/Archive-Tar/t/08_ptargrep.t @@ -7,9 +7,9 @@ use FindBin '$Bin'; use Archive::Tar; # filenames -my $tartest = File::Spec->catfile("t", "tartest"); -my $foo = File::Spec->catfile("t", "tartest", "foo"); -my $tarfile = File::Spec->catfile("t", "tartest.tar"); +my $tartest = File::Spec->catfile("t", "ptargrep"); +my $foo = File::Spec->catfile("t", "ptargrep", "foo"); +my $tarfile = File::Spec->catfile("t", "ptargrep.tar"); my $ptargrep = File::Spec->catfile($Bin, "..", "bin", "ptargrep"); my $cmd = qq/$^X $ptargrep --list-only "file foo" $tarfile/; @@ -26,7 +26,7 @@ $tar->write($tarfile); # see if ptargrep matches my $out = qx{$cmd}; -cmp_ok($out, '=~', qr{^t.*tartest.*foo$}m, "ptargrep shows matched file"); +cmp_ok($out, '=~', qr{^t.*ptargrep.*foo$}m, "ptargrep shows matched file"); # cleanup END { diff --git a/cpan/CPAN-Meta-Requirements/lib/CPAN/Meta/Requirements.pm b/cpan/CPAN-Meta-Requirements/lib/CPAN/Meta/Requirements.pm index c1193a0..727fb28 100644 --- a/cpan/CPAN-Meta-Requirements/lib/CPAN/Meta/Requirements.pm +++ b/cpan/CPAN-Meta-Requirements/lib/CPAN/Meta/Requirements.pm @@ -1,7 +1,7 @@ use strict; use warnings; package CPAN::Meta::Requirements; -our $VERSION = '2.126'; # VERSION +our $VERSION = '2.128'; # VERSION # ABSTRACT: a set of version requirements for a CPAN dist #pod =head1 SYNOPSIS @@ -33,7 +33,22 @@ our $VERSION = '2.126'; # VERSION use Carp (); use Scalar::Util (); -use version 0.77 (); # the ->parse method + +# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls +# before 5.10, we fall back to the EUMM bundled compatibility version module if +# that's the only thing available. This shouldn't ever happen in a normal CPAN +# install of CPAN::Meta::Requirements, as version.pm will be picked up from +# prereqs and be available at runtime. + +BEGIN { + eval "use version ()"; ## no critic + if ( my $err = $@ ) { + eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic + } +} + +# Perl 5.10.0 didn't have "is_qv" in version.pm +*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; #pod =method new #pod @@ -63,15 +78,41 @@ sub new { return bless \%self => $class; } +# from version::vpp +sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; +} + sub _version_object { my ($self, $version) = @_; my $vobj; + # hack around version::vpp not handling <3 character vstring literals + if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) { + my $magic = _find_magic_vstring( $version ); + $version = $magic if length $magic; + } + eval { local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" }; - $vobj = (! defined $version) ? version->parse(0) - : (! Scalar::Util::blessed($version)) ? version->parse($version) + $vobj = (! defined $version) ? version->new(0) + : (! Scalar::Util::blessed($version)) ? version->new($version) : $version; }; @@ -87,12 +128,12 @@ sub _version_object { # ensure no leading '.' if ( $vobj =~ m{\A\.} ) { - $vobj = version->parse("0$vobj"); + $vobj = version->new("0$vobj"); } # ensure normal v-string form - if ( $vobj->is_qv ) { - $vobj = version->parse($vobj->normal); + if ( _is_qv($vobj) ) { + $vobj = version->new($vobj->normal); } return $vobj; @@ -694,7 +735,7 @@ CPAN::Meta::Requirements - a set of version requirements for a CPAN dist =head1 VERSION -version 2.126 +version 2.128 =head1 SYNOPSIS @@ -970,6 +1011,8 @@ Ricardo Signes =head1 CONTRIBUTORS +=for stopwords Karen Etheridge robario + =over 4 =item * diff --git a/cpan/Digest-SHA/src/sdf.c b/cpan/Digest-SHA/src/sdf.c new file mode 100644 index 0000000..e74f8e0 --- /dev/null +++ b/cpan/Digest-SHA/src/sdf.c @@ -0,0 +1,100 @@ +/* Extracted from perl-5.004/universal.c, contributed by Graham Barr */ + +static SV * +isa_lookup(stash, name, len, level) +HV *stash; +char *name; +int len; +int level; +{ + AV* av; + GV* gv; + GV** gvp; + HV* hv = Nullhv; + + if (!stash) + return &sv_undef; + + if(strEQ(HvNAME(stash), name)) + return &sv_yes; + + if (level > 100) + croak("Recursive inheritance detected"); + + gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); + + if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) { + SV* sv; + SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); + if (svp && (sv = *svp) != (SV*)&sv_undef) + return sv; + } + + gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + + if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + if(!hv) { + gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); + + gv = *gvp; + + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); + + hv = GvHVn(gv); + } + if(hv) { + SV** svp = AvARRAY(av); + I32 items = AvFILL(av) + 1; + while (items--) { + SV* sv = *svp++; + HV* basestash = gv_stashsv(sv, FALSE); + if (!basestash) { + if (dowarn) + warn("Can't locate package %s for @%s::ISA", + SvPVX(sv), HvNAME(stash)); + continue; + } + if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) { + (void)hv_store(hv,name,len,&sv_yes,0); + return &sv_yes; + } + } + (void)hv_store(hv,name,len,&sv_no,0); + } + } + + return &sv_no; +} + +static bool +sv_derived_from(sv, name) +SV * sv ; +char * name ; +{ + SV *rv; + char *type; + HV *stash; + + stash = Nullhv; + type = Nullch; + + if (SvGMAGICAL(sv)) + mg_get(sv) ; + + if (SvROK(sv)) { + sv = SvRV(sv); + type = sv_reftype(sv,0); + if(SvOBJECT(sv)) + stash = SvSTASH(sv); + } + else { + stash = gv_stashsv(sv, FALSE); + } + + return (type && strEQ(type,name)) || + (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) + ? TRUE + : FALSE ; + +} diff --git a/cpan/ExtUtils-Install/Changes b/cpan/ExtUtils-Install/Changes deleted file mode 100644 index a828406..0000000 --- a/cpan/ExtUtils-Install/Changes +++ /dev/null @@ -1,352 +0,0 @@ -Revision history for ExtUtils-Install - -1.63 - -- Enable tests to run in parallel - -1.62 - -- Various POD fixes and typos -- Cross-compilation fixes -- VMS fixes - -1.57 - -Adds 'skip_cwd' parameter to ExtUtils::Installed. With this new parameter, -the current directory is not included in the installed module search. This -avoids finding modules from other perls which happen to be below the -current directory. - -1.56 - -Pod fixes. - -1.55 - -Pod fixes. - -1.54 - -This is a "no-change" version bump because I pushed the v1.53 change -and then realized that MakeMaker.t was a bad name for a file that would -end up in core where the EUMM tests and the EUI tests are in the same -directory. This renames it to InstallWithMM.t. - -1.53 - -Final stage of the divorce from EUMM. Now the EUMM related tests are no -longer shared. Build.pl and Build.t go, and there shall be peace on earth. -At least until somebody patches EUMM/t/basic.t for something EUI related... - -Thanks to M. Schwern for helping me work this one out. Cheers man. - -1.52_03 - -Missed the t/Installed.t test from core. Bumped version number to allow -a new distro to be released. - -1.52_02 - -Make _chmod verbose message use octal modes, thanks to BDFOY - -Further changes from core, including lastest test file infrastructure -from EUMM. - -Fixed a number of problems in ExtUtils::Installed, for various reasons -this includes a version bump to 1.999_001, which will eventually become -version 2.0. These problems related to finding modules that were installed -with either INSTALL_BASE or PREFIX. Hopefully this resolves these issues. - -1.52_01 (core only release) - -Changes from Core: - -commit 3d55b451d9544fbd4c27c33287b76bee30328830 -Author: John Malmberg -Date: Sun Feb 15 09:25:10 2009 -0600 - - ExtUtils::Install VMS extended character set support - - Preview from https://rt.cpan.org/Ticket/Display.html?id=42149 - - -1.52 - -Production rerelease of 1.51 to make the CPAN indexer happy about permissions -(hopefully). - -SVN Revision 44. - -1.51 - -Production release of 1.50_05. No other changes. - -SVN revision 43. - -1.50_05 - -SVN revision 42. - -Fix broken test as reported by Craig Berry. - -1.50_04 - -SVN revision 41. - -Restructure tests to make it easier to maintain given it is distributed in various -ways in three different packages. - -1.50_03 - -SVN revision 40. - -Sigh, just after i released 1.50_02 I noticed that a test modified in it will fail -under VMS. So this is a fixup release for that alone. - -1.50_02 - -SVN revision 39. - -Synchronize with the changes that were made in blead perl -patch #33567. VMS changes by Craig Berry. See - -http://perl5.git.perl.org/perl.git/commit/553b5000d7907cb0cb8f4658c1d6a2aac379415b - -This was marked in the pod as 1.51 but not actually version bumped. - -So I've marked it as 1.50_02 as a test release prior to putting it out -as the real 1.51 - -This release also restores the missing installed.t which was accidentally -missed by the MANIFEST having a duplicate entry for install.t instead. -Probably something should have warned about this, but I haven't worked out -what. - -Includes changes from Activestate/ActivePerl: - -- To make installation less chatty when not under verbose mode. See - -http://rt.cpan.org/Public/Bug/Display.html?id=5903 - -- To install HTML documentation files under builds that set $Config{installhtmldir} -(and presumably also create HTML versions of the pod -- which is quite nice actually :-) - -http://rt.cpan.org/Ticket/Display.html?id=37727 - -1.50_01 - -Version only released as part of bleadperl added in revision #33566. -Cygwin related changes by Steve Hay, and others, see - -http://perl5.git.perl.org/perl.git/commit/038ae9a45711aea142f721498a4a61353b40c4e4 - -and discussion at - -http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-03/msg00056.html - -1.50 - -Previous patches to _have_write_access() were causing problems -on Cygwin. So now we skip using POSIX::access under cygwin. -Also added some =pod directives to make my favorite editor -highlight the pod properly. - -1.49 - -Turns out that the new can_write_dir.t doesn't work properly under root -as root can read the files regardless as to their mode. So we skip those -tests when the effective UID is 0 indicating root. - -1.48 - -We were getting N/A test results from CPAN testers due to the -presence of Config in the prequisities list. This has been corrected. - -Also it was pointed out that EU_ALWAYS_COPY did not follow the naming -convention of other ExtUtils::Install environment variables. It has -been renamed EU_INSTALL_ALWAYS_COPY. Support remains for the original -deprecated environment variable but it will be removed in 1.50. - -1.47 - -Fix build process so a new META.YML is produced each time. Also -add support for a new argument syntax to install() as well as -support for always copying installed files even when the old -file was identical. This is needed for some bundling mechanisms -and can be activated by setting the environment variable EU_ALWAYS_COPY -before the install process starts. - -Add a newer cleaner interface to install() to allow named parameters -and easier external monitoring of what transpired. - -1.46 2008-03-01 12:42:35 - -Apply patches from Michael G. Schwern (rt #33688, rt #31429, rt #31248) -and from Slaven Rezic (rt #33290). Also implemented the suggestion from -Schwern about not dieing when failing to remove a shadow file that is -later on in INC than the installed version. (rt #2928) - -1.45 2008-02-27 13:55:27 - -Fix rt.cpan.org #32813, use catpath() to attach volume name -to dirs in _can_write_dir() when necessary to avoid cygwin -builds doing a hostname lookup. - -1.44 2007-09-09 23:12:25 - -by Schwern - -*** MAJOR BUG FIX *** - -install() would always try to uninstall different versions of the -installed files when $uninstall_shadows was given whether it was true or false. -This meant "make install" and "Build install" would both always try to uninstall -differing versions of the modules. [rt.cpan.org 28672] - -1.43 2007-07-21 00:09:24 - -Turns out some recent version, I haven't figured out which, causes -ExtUtils::MakeMaker to fail test. The failure is actually bogus, EUMM -is testing for output that we stopped producing except under verbose, -however it is a pain, so this release fixes the problem. It also adds -a new test file, a stripped down version of ExtUtils::MakeMakers -t/basic.t. - -1.42 2007-07-20 22:43:04 - -This is just 1.41_04 as a production release. - -1.41_04 2007-07-07 16:52:40 - -Reorganize how things work in Install so that we don't try to create -directories which exist but are not writable to us when they contain -files which we want to install which are writable by us. -http://rt.cpan.org/Public/Bug/Display.html?id=25627 - -Also fix a VMS issue as recommended by Craig Berry. -http://rt.cpan.org/Public/Bug/Display.html?id=22157 - -1.41_03 2007-02-11 15:13 - -Add an extra_libs parameter to ExtUtils::Installed->new() which allows -one to specify additional libs to search for installed modules. - -Additional code cleanup and tweaks. - -1.41_02 2007-02-03 21:10 - -Fix bug in _can_write_file(). - -1.41_01 2007-02-02 21:03 - -Integrated changes from - -1. Steffen Mueller: make ExtUtils::Installed respect PERL5LIB and allow -overriding the current config and inc with something else. - -2. Michael Schwern (RT#21949, RT#21948): Fix use lib and installdirs -and other EU::MakeMaker related changes. - -3. ActiveState (RT#5903): Reduce install verbosity. - -4. Craig Berry (RT#22157): Fix VMS related install failure. - -5. Ken Williams (RT#16225): Make fake uninstall actually fake. - - -1.41 2006-07-02 16:09 - -Integrated ExtUtils::Packlist changes from Nicholas Clark to allow for -relocatable perls. Bumped version numbers on all files. - -1.40 2006-04-30 15:04 - -Enhanced errorcatching and reporting. Fixed a problem with the INSTALL.SKIP -file. Changed the Makefile.PL so that when installing it would not use the same -stuff it was replacing. This doesn't affect building with Module::Build -currently. - -Removed META.yml from distribution. - -1.39 2006-04-14 18:53 - -- Fixed problem with the META.yml file being produced from a Win32 point of view. -IMO this is an error/failing in the design of the META.yml process. META.yml should -be created on the client side not on the distributor side. Now produces a -platform agnostic (ie UNIXy) META.yml. - -- Reversed order of change file so newest entries go on top. - - -1.38 2006-04-02 17:31 - -- Removed MANIFEST.SKIP support (INSTALL.SKIP still supported), and -added support for providing a fallback skip file by using -ENV{EU_INSTALL_SITE_SKIP} as a fallback if there is not a distribution -specific skip file. - -- Released under the ExtUtils-Install-1.38 Name - - -1.3702 2006-03-19 16:54 - -- Added support for skipping files during install based on a set of filter -rules. If there is an INSTALL.SKIP in the current directory when doing an -install then it is loaded, otherwise if there is a MANIFEST.SKIP then it is -loaded. If neither exists then no filtration occurs. The env variable -EU_INSTALL_IGNORE_SKIP may be set to a true value to override this behaviour. -This means that you can make .svn directories be ignored on install. - -1.3701 2006-03-13 20:00 - -- Integrated patch from Randy Sims. - - 1. Fixes error during 'perl Makefile.PL' because it MakeMaker can't - find the NAME section describing DISTNAME (which has the 'ex-' - prefix). - - 2. Win32API::File is recommended on MSWin32 && cygwin. - - 3. Under Perl5.005, ExtUtils::MM is not present in the version of - MakeMaker included. I don't know what version first includes it. - Needs research or better: eliminate need for it. - - 4. Test::More is bundled with the distro for its test suite. This - would be needed on Perl5.005, for example. It was listed as a - requirement, but the directory it's bundled in is not in @INC when - prereqs are checked. I removed the prereq from Build.PL & - Makefile.PL. Other options: 1) fixup @INC to include t/lib; or 2) - unbundle and add back to prereqs. - - 4. Update t/pod.t t/pod-coverage fixup of @INC so it can find - bundled Test::More. - -- Fixed pod/coverage related issues. - -- When trying to schedule a delete at reboot after renaming a dll out of -the way no error occurs if Win32API::File isn't available. Instead it -merely warns that the file should be hand deleted. - -- Fixed install at reboot behaviour by making sure the temporar file is -writable after install (normally files installed are readonly) - -1.37 2006-03-12 23:20 - -- Refactored reboot support. Integrated changes from Randy Sims -in p5p message 4413F4E9.7090802@thepierianspring.org - - -1.36 2006-03-11 12:42 - -- Extended Win32 support. Added ExtUtils::Install::MUST_REBOOT to -handle such scenario when rebooting. - -- Released as ex-ExtUtils-Install by demerphq - -1.35 Wed Feb 1 23:00:00 CST 2006 - - - First independent release; Extracted ExtUtils::Install, - ExtUtils::Installed, & ExtUtils::Packlist from MakeMaker. - - - Changed the $VERSION of all modules to the same version number, a - number higher than all $VERSIONs. diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm index 85fe1c9..1e8ac4c 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm @@ -38,11 +38,11 @@ ExtUtils::Install - install files from here to there =head1 VERSION -1.68 +2.04 =cut -$VERSION = '1.68'; # <-- do not forget to update the POD section just above this line! +$VERSION = '2.04'; # <-- do not forget to update the POD section just above this line! $VERSION = eval $VERSION; =pod diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm index a62de6e..061c329 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Installed.pm @@ -17,7 +17,7 @@ my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); require VMS::Filespec if $Is_VMS; use vars qw($VERSION); -$VERSION = '1.999005'; +$VERSION = '2.04'; $VERSION = eval $VERSION; sub _is_prefix { diff --git a/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm b/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm index 8323725..c1ab002 100644 --- a/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm +++ b/cpan/ExtUtils-Install/lib/ExtUtils/Packlist.pm @@ -5,7 +5,7 @@ use strict; use Carp qw(); use Config; use vars qw($VERSION $Relocations); -$VERSION = '1.48'; +$VERSION = '2.04'; $VERSION = eval $VERSION; # Used for generating filehandle globs. IO::File might not be available! diff --git a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm index e39c8b2..7ef793f 100644 --- a/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm +++ b/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm @@ -11,7 +11,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '6.98'; +our $VERSION = '6.98_01'; use ExtUtils::MakeMaker::Config; use Cwd 'cwd'; @@ -106,8 +106,10 @@ sub _unix_os2_ext { # For gcc-2.6.2 on linux (March 1995), DLD can not load # .sa libraries, with the exception of libm.sa, so we # deliberately skip them. - if ( @fullname = $self->lsdir( $thispth, "^\Qlib$thislib.$so.\E[0-9]+" ) ) { - + if ((@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) || + (@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) { # Take care that libfoo.so.10 wins against libfoo.so.9. # Compare two libraries to find the most recent version # number. E.g. if you have libfoo.so.9.0.7 and diff --git a/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm b/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm index 1761589..ce0007b 100644 --- a/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm +++ b/cpan/ExtUtils-Manifest/lib/ExtUtils/Manifest.pm @@ -10,7 +10,7 @@ use Carp; use strict; use warnings; -our $VERSION = '1.65'; +our $VERSION = '1.68'; our @ISA = ('Exporter'); our @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck @@ -195,7 +195,7 @@ sub manifind { # $File::Find::name is unavailable. # Also, it's okay to use / here, because MANIFEST files use Unix-style # paths. - find({wanted => $wanted}, + find({wanted => $wanted, follow_fast => 1}, $Is_MacOS ? ":" : "."); return $found; @@ -354,7 +354,7 @@ sub maniread { # filename may contain spaces if enclosed in '' # (in which case, \\ and \' are escapes) - if (($file, $comment) = /^'(\\[\\']|.+)+'\s*(.*)/) { + if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) { $file =~ s/\\([\\'])/$1/g; } else { diff --git a/cpan/ExtUtils-Manifest/t/Manifest.t b/cpan/ExtUtils-Manifest/t/Manifest.t index 48e31b9..67cc5a1 100644 --- a/cpan/ExtUtils-Manifest/t/Manifest.t +++ b/cpan/ExtUtils-Manifest/t/Manifest.t @@ -8,12 +8,13 @@ BEGIN { else { unshift @INC, 't/lib'; } + $ENV{PERL_MM_MANIFEST_VERBOSE}=1; } chdir 't'; use strict; -use Test::More tests => 97; +use Test::More tests => 98; use Cwd; use File::Spec; @@ -34,7 +35,6 @@ if ($Is_VMS) { $Is_VMS_noefs = 0 if $vms_efs; } - # We're going to be chdir'ing and modules are sometimes loaded on the # fly in this test, so we need an absolute @INC. @INC = map { File::Spec->rel2abs($_) } @INC; @@ -333,6 +333,20 @@ SKIP: { $funky_files{'space_quote_backslash'} = 'foo bar\\baz\'quux'; } +# test including a filename which is itself a quoted string +# https://rt.perl.org/Ticket/Display.html?id=122415 +SKIP: { + my $quoted_filename = q{'quoted name.txt'}; + my $description = "quoted string"; + add_file( $quoted_filename => $description ) + or skip "couldn't create $description test file", 1; + local $ExtUtils::Manifest::MANIFEST = "albatross"; + maniadd({ $quoted_filename => $description }); + is( maniread()->{$quoted_filename}, $description, + 'file whose name starts and ends with quotes' ); + $funky_files{$description} = $quoted_filename; +} + my @funky_keys = qw(space space_quote space_backslash space_quote_backslash); # test including an external manifest.skip file in MANIFEST.SKIP { diff --git a/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm b/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm index 06c0961..ef434f3 100644 --- a/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm +++ b/cpan/HTTP-Tiny/lib/HTTP/Tiny.pm @@ -3,7 +3,7 @@ package HTTP::Tiny; use strict; use warnings; # ABSTRACT: A small, simple, correct HTTP/1.1 client -our $VERSION = '0.047'; # VERSION +our $VERSION = '0.049'; # VERSION use Carp (); @@ -53,9 +53,9 @@ use Carp (); #pod #pod The C parameter enables a persistent connection, but only to a #pod single destination scheme, host and port. Also, if any connection-relevant -#pod attributes are modified, a persistent connection will be dropped. If you want -#pod persistent connections across multiple destinations, use multiple HTTP::Tiny -#pod objects. +#pod attributes are modified, or if the process ID or thread ID change, the +#pod persistent connection will be dropped. If you want persistent connections +#pod across multiple destinations, use multiple HTTP::Tiny objects. #pod #pod See L for more on the C and C attributes. #pod @@ -861,6 +861,15 @@ use warnings; use Errno qw[EINTR EPIPE]; use IO::Socket qw[SOCK_STREAM]; +# for thread safety, we need to know thread id or else fake it; +# requires "threads.pm" to hide it from the minimum version detector +if ( eval { require "threads.pm"; 1 } ) { ## no critic + *_get_tid = sub { threads->tid }; +} +else { + *_get_tid = sub () { 0 }; +} + # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old # behavior if someone is unable to boostrap CPAN from a new perl install; it is # not intended for general, per-client use and may be removed in the future @@ -924,6 +933,8 @@ sub connect { $self->{scheme} = $scheme; $self->{host} = $host; $self->{port} = $port; + $self->{pid} = $$; + $self->{tid} = _get_tid(); return $self; } @@ -1367,7 +1378,9 @@ sub _assert_ssl { sub can_reuse { my ($self,$scheme,$host,$port) = @_; return 0 if - length($self->{rbuf}) + $self->{pid} != $$ + || $self->{tid} != _get_tid() + || length($self->{rbuf}) || $scheme ne $self->{scheme} || $host ne $self->{host} || $port ne $self->{port} @@ -1444,7 +1457,7 @@ HTTP::Tiny - A small, simple, correct HTTP/1.1 client =head1 VERSION -version 0.047 +version 0.049 =head1 SYNOPSIS @@ -1554,9 +1567,9 @@ content field in the response will contain the text of the exception. The C parameter enables a persistent connection, but only to a single destination scheme, host and port. Also, if any connection-relevant -attributes are modified, a persistent connection will be dropped. If you want -persistent connections across multiple destinations, use multiple HTTP::Tiny -objects. +attributes are modified, or if the process ID or thread ID change, the +persistent connection will be dropped. If you want persistent connections +across multiple destinations, use multiple HTTP::Tiny objects. See L for more on the C and C attributes. @@ -2009,6 +2022,8 @@ David Golden =head1 CONTRIBUTORS +=for stopwords Alan Gardner James Raspass Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Petr Písař Serguei Trouchelle Syohei YOSHIDA Sören Kornetzki Alessandro Ghedini Tom Hukins Tony Cook Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Mitchell Edward Zborowski + =over 4 =item * @@ -2017,83 +2032,87 @@ Alan Gardner =item * -Alessandro Ghedini +James Raspass =item * -Brad Gilbert +Jess Robinson =item * -Chris Nehren +Lukas Eklund =item * -Chris Weyl +Martin J. Evans =item * -Claes Jakobsson +Martin-Louis Bright =item * -Clinton Gormley +Mike Doherty =item * -Craig Berry +Petr Písař =item * -David Mitchell +Serguei Trouchelle =item * -Edward Zborowski +Syohei YOSHIDA =item * -James Raspass +Sören Kornetzki =item * -Jess Robinson +Alessandro Ghedini =item * -Lukas Eklund +Tom Hukins =item * -Martin J. Evans +Tony Cook =item * -Martin-Louis Bright +Brad Gilbert =item * -Mike Doherty +Chris Nehren =item * -Petr Písař +Chris Weyl =item * -Serguei Trouchelle +Claes Jakobsson =item * -Syohei YOSHIDA +Clinton Gormley =item * -Sören Kornetzki +Craig Berry =item * -Tony Cook +David Mitchell + +=item * + +Edward Zborowski =back diff --git a/cpan/HTTP-Tiny/t/140_proxy.t b/cpan/HTTP-Tiny/t/140_proxy.t index 6ecc6a5..4b12261 100644 --- a/cpan/HTTP-Tiny/t/140_proxy.t +++ b/cpan/HTTP-Tiny/t/140_proxy.t @@ -10,6 +10,8 @@ use HTTP::Tiny; # Require a true value for my $proxy (undef, "", 0){ + local $ENV{all_proxy} = undef; + local $ENV{ALL_PROXY} = undef; local $ENV{http_proxy} = $proxy; my $c = HTTP::Tiny->new(); ok(!defined $c->http_proxy); diff --git a/cpan/HTTP-Tiny/t/Util.pm b/cpan/HTTP-Tiny/t/Util.pm index 2428053..6698bdc 100644 --- a/cpan/HTTP-Tiny/t/Util.pm +++ b/cpan/HTTP-Tiny/t/Util.pm @@ -156,6 +156,8 @@ sub sort_headers { $self->{port} = $monkey_port = $port; $self->{scheme} = $scheme; $self->{fh} = shift @req_fh; + $self->{pid} = $$; + $self->{tid} = HTTP::Tiny::Handle::_get_tid(); return $self; }; my $original_write_request = \&HTTP::Tiny::Handle::write_request; diff --git a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm index af783f2..8ebc44a 100644 --- a/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm +++ b/cpan/IO-Socket-IP/lib/IO/Socket/IP.pm @@ -7,7 +7,7 @@ package IO::Socket::IP; # $VERSION needs to be set before use base 'IO::Socket' # - https://rt.cpan.org/Ticket/Display.html?id=92107 BEGIN { - $VERSION = '0.31'; + $VERSION = '0.32'; } use strict; @@ -31,7 +31,7 @@ use Socket 1.97 qw( my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0; use POSIX qw( dup2 ); -use Errno qw( EINVAL EINPROGRESS EISCONN ); +use Errno qw( EINVAL EINPROGRESS EISCONN ETIMEDOUT EWOULDBLOCK ); use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" ); @@ -304,6 +304,22 @@ If defined but false, the socket will be set to non-blocking mode. Otherwise it will default to blocking mode. See the NON-BLOCKING section below for more detail. +=item Timeout => NUM + +If defined, gives a maximum time in seconds to block per C call +when in blocking mode. If missing, no timeout is applied other than that +provided by the underlying operating system. When in non-blocking mode this +parameter is ignored. + +Note that if the hostname resolves to multiple address candidates, the same +timeout will apply to each connection attempt individually, rather than to the +operation as a whole. Further note that the timeout does not apply to the +initial hostname resolve operation, if connecting by hostname. + +This behviour is copied inspired by C; for more fine grained +control over connection timeouts, consider performing a nonblocking connect +directly. + =back If neither C nor C hints are provided, a default of @@ -611,12 +627,12 @@ sub setup return 0; } - # If connect failed but we have no system error there must be an error - # at the application layer, like a bad certificate with - # IO::Socket::SSL. - # In this case don't continue IP based multi-homing because the problem - # cannot be solved at the IP layer. - return 0 if ! $!; + # If connect failed but we have no system error there must be an error + # at the application layer, like a bad certificate with + # IO::Socket::SSL. + # In this case don't continue IP based multi-homing because the problem + # cannot be solved at the IP layer. + return 0 if ! $!; ${*$self}{io_socket_ip_errors}[0] = $!; next; @@ -641,7 +657,47 @@ sub connect # useful APIs I'm just going to end-run around it and call CORE::connect() # directly - return CORE::connect( $self, $_[0] ) if @_; + if( @_ ) { + my ( $addr ) = @_; + + # Annoyingly IO::Socket's connect() is where the timeout logic is + # implemented, so we'll have to reinvent it here + my $timeout = ${*$self}{'io_socket_timeout'}; + + return CORE::connect( $self, $addr ) unless defined $timeout; + + my $was_blocking = $self->blocking( 0 ); + + my $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0; + + if( !$err ) { + # All happy + return 1; + } + elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) { + # Failed for some other reason + return undef; + } + elsif( !$was_blocking ) { + # We shouldn't block anyway + return undef; + } + + my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1; + if( !select( $vec, $vec, $vec, $timeout ) ) { + $! = ETIMEDOUT; + return undef; + } + + # Hoist the error by connect()ing a second time + $err = defined CORE::connect( $self, $addr ) ? 0 : $!+0; + $err = 0 if $err == EISCONN; # Some OSes give EISCONN + + $self->blocking( $was_blocking ); + + $! = $err, return undef if $err; + return 1; + } return 1 if !${*$self}{io_socket_ip_connect_in_progress}; @@ -1090,6 +1146,37 @@ constructor will ignore the value of this argument, except if it is defined but false. An exception is thrown in this case, because that would request it disable the C search behaviour in the first place. +=item * + +C implements both the C and C parameters, +but it implements the interaction of both in a different way. + +In C<::INET>, supplying a timeout overrides the non-blocking behaviour, +meaning that the C operation will still block despite that the +caller asked for a non-blocking socket. This is not explicitly specified in +its documentation, nor does this author believe that is a useful behaviour - +it appears to come from a quirk of implementation. + +In C<::IP> therefore, the C parameter takes precedence - if a +non-blocking socket is requested, no operation will block. The C +parameter here simply defines the maximum time that a blocking C +call will wait, if it blocks at all. + +In order to specifically obtain the "blocking connect then non-blocking send +and receive" behaviour of specifying this combination of options to C<::INET> +when using C<::IP>, perform first a blocking connect, then afterwards turn the +socket into nonblocking mode. + + my $sock = IO::Socket::IP->new( + PeerHost => $peer, + Timeout => 20, + ) or die "Cannot connect - $@"; + + $sock->blocking( 0 ); + +This code will behave identically under both C and +C. + =back =cut diff --git a/cpan/IO-Socket-IP/t/02local-server-v4.t b/cpan/IO-Socket-IP/t/02local-server-v4.t index d1f2b40..bca5b83 100644 --- a/cpan/IO-Socket-IP/t/02local-server-v4.t +++ b/cpan/IO-Socket-IP/t/02local-server-v4.t @@ -27,6 +27,7 @@ foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { my $testserver = IO::Socket::IP->new( ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), LocalHost => "127.0.0.1", + Port => 0, Type => Socket->$socktype, ); diff --git a/cpan/IO-Socket-IP/t/03local-cross-v4.t b/cpan/IO-Socket-IP/t/03local-cross-v4.t index 532b78c..4d75d95 100644 --- a/cpan/IO-Socket-IP/t/03local-cross-v4.t +++ b/cpan/IO-Socket-IP/t/03local-cross-v4.t @@ -11,6 +11,7 @@ foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { my $testserver = IO::Socket::IP->new( ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), LocalHost => "127.0.0.1", + Port => 0, Type => Socket->$socktype, ) or die "Cannot listen on PF_INET - $@"; diff --git a/cpan/IO-Socket-IP/t/05local-server-v6.t b/cpan/IO-Socket-IP/t/05local-server-v6.t index 22ee59e..27664b6 100644 --- a/cpan/IO-Socket-IP/t/05local-server-v6.t +++ b/cpan/IO-Socket-IP/t/05local-server-v6.t @@ -33,6 +33,7 @@ foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { my $testserver = IO::Socket::IP->new( ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), LocalHost => "::1", + Port => 0, Type => Socket->$socktype, GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ); diff --git a/cpan/IO-Socket-IP/t/06local-cross-v6.t b/cpan/IO-Socket-IP/t/06local-cross-v6.t index c4842b7..8d40f4a 100644 --- a/cpan/IO-Socket-IP/t/06local-cross-v6.t +++ b/cpan/IO-Socket-IP/t/06local-cross-v6.t @@ -14,6 +14,7 @@ foreach my $socktype (qw( SOCK_STREAM SOCK_DGRAM )) { my $testserver = IO::Socket::IP->new( ( $socktype eq "SOCK_STREAM" ? ( Listen => 1 ) : () ), LocalHost => "::1", + Port => 0, Type => Socket->$socktype, ) or die "Cannot listen on PF_INET6 - $@"; diff --git a/cpan/IO-Socket-IP/t/15io-socket.t b/cpan/IO-Socket-IP/t/15io-socket.t index 8acc9a7..0747294 100644 --- a/cpan/IO-Socket-IP/t/15io-socket.t +++ b/cpan/IO-Socket-IP/t/15io-socket.t @@ -15,6 +15,7 @@ use IO::Socket::IP -register; Type => SOCK_STREAM, LocalHost => "127.0.0.1", LocalPort => 0, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ); isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET )' ) or @@ -41,6 +42,7 @@ SKIP: { Type => SOCK_STREAM, LocalHost => "::1", LocalPort => 0, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ); isa_ok( $sock, "IO::Socket::IP", 'IO::Socket->new( Domain => AF_INET6 )' ) or diff --git a/cpan/IO-Socket-IP/t/16v6only.t b/cpan/IO-Socket-IP/t/16v6only.t index 4aeb4e0..8e3ee31 100644 --- a/cpan/IO-Socket-IP/t/16v6only.t +++ b/cpan/IO-Socket-IP/t/16v6only.t @@ -25,6 +25,7 @@ my $ECONNREFUSED_STR = "$!"; LocalPort => 0, Type => SOCK_STREAM, V6Only => 1, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ) or die "Cannot listen on PF_INET6 - $@"; is( $listensock->getsockopt( IPPROTO_IPV6, IPV6_V6ONLY ), 1, 'IPV6_V6ONLY is 1 on $listensock' ); @@ -34,6 +35,7 @@ my $ECONNREFUSED_STR = "$!"; PeerHost => "127.0.0.1", PeerPort => $listensock->sockport, Type => SOCK_STREAM, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ); my $err = "$@"; @@ -52,6 +54,7 @@ SKIP: { LocalPort => 0, Type => SOCK_STREAM, V6Only => 0, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ) or die "Cannot listen on PF_INET6 - $@"; is( $listensock->getsockopt( IPPROTO_IPV6, IPV6_V6ONLY ), 0, 'IPV6_V6ONLY is 0 on $listensock' ); @@ -61,6 +64,7 @@ SKIP: { PeerHost => "127.0.0.1", PeerPort => $listensock->sockport, Type => SOCK_STREAM, + GetAddrInfoFlags => 0, # disable AI_ADDRCONFIG ); my $err = "$@"; diff --git a/cpan/IO-Socket-IP/t/22timeout.t b/cpan/IO-Socket-IP/t/22timeout.t new file mode 100644 index 0000000..48bc697 --- /dev/null +++ b/cpan/IO-Socket-IP/t/22timeout.t @@ -0,0 +1,29 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use IO::Socket::IP; + +my $server = IO::Socket::IP->new( + Listen => 1, + LocalHost => "127.0.0.1", + LocalPort => 0, +) or die "Cannot listen on PF_INET - $!"; + +my $client = IO::Socket::IP->new( + PeerHost => $server->sockhost, + PeerPort => $server->sockport, + Timeout => 0.1, +) or die "Cannot connect on PF_INET - $!"; + +ok( defined $client, 'client constructed with Timeout' ); + +my $accepted = $server->accept + or die "Cannot accept - $!"; + +ok( defined $accepted, 'accepted a client' ); + +done_testing; diff --git a/cpan/Locale-Codes/lib/Locale/Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes.pm index 61d10e0..5ddd466 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes.pm @@ -31,7 +31,7 @@ our($VERSION,%Data,%Retired); # $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME # { name }{ NAME } = [CODE,NAME] (the key is lowercase) -$VERSION='3.31'; +$VERSION='3.32'; #======================================================================= # diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Changes.pod b/cpan/Locale-Codes/lib/Locale/Codes/Changes.pod index bc1c266..e1d523c 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Changes.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/Changes.pod @@ -24,7 +24,9 @@ codes, I will add them to the module and release a new version. =head1 VERSION 3.33 (planned 2014-12-01; sbeck) -=head1 VERSION 3.32 (planned 2014-09-01; sbeck) +=head1 VERSION 3.32 (2014-09-01; sbeck) + +NEW CODE(s) =head1 VERSION 3.31 (2014-06-01; sbeck) diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Constants.pm b/cpan/Locale-Codes/lib/Locale/Codes/Constants.pm index df8bf45..cf2822b 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Constants.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Constants.pm @@ -17,7 +17,7 @@ require Exporter; our($VERSION,@ISA,@EXPORT); our(%ALL_CODESETS); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(LOCALE_CODE_ALPHA_2 LOCALE_CODE_ALPHA_3 diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Country.pm b/cpan/Locale-Codes/lib/Locale/Codes/Country.pm index 5e05420..de62dfa 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Country.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Country.pm @@ -22,7 +22,7 @@ use Locale::Codes::Country_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2country country2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Country.pod b/cpan/Locale-Codes/lib/Locale/Codes/Country.pod index c9e9180..8c0e80b 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Country.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/Country.pod @@ -80,15 +80,15 @@ Locale::Codes::Changes document for details. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Country_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/Country_Codes.pm index a3861473..22a253f 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Country_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Country_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::Country_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 10:41:20 EDT 2014 +# Generated on: Fri Aug 22 15:26:47 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'country'}{'id'} = '0250'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Country_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/Country_Retired.pm index f951054..4b80393 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Country_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Country_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::Country_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'country'}{'alpha-2'}{'code'} = { q(an) => q(Netherlands Antilles), diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Currency.pm b/cpan/Locale-Codes/lib/Locale/Codes/Currency.pm index 990c7b7..7f0f223 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Currency.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Currency.pm @@ -22,7 +22,7 @@ use Locale::Codes::Currency_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2currency currency2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Currency.pod b/cpan/Locale-Codes/lib/Locale/Codes/Currency.pod index 52ddd63..e941685 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Currency.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/Currency.pod @@ -60,15 +60,15 @@ This is the set of three-digit numeric codes from ISO 4217. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Currency_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/Currency_Codes.pm index 289398a..d4f9c23 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Currency_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Currency_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::Currency_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 11:22:06 EDT 2014 +# Generated on: Fri Aug 22 15:31:17 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'currency'}{'id'} = '0178'; @@ -119,7 +119,7 @@ $Locale::Codes::Data{'currency'}{'id2names'} = { q(Canadian Dollar), ], q(0035) => [ - q(Cape Verde Escudo), + q(Cabo Verde Escudo), ], q(0036) => [ q(Cayman Islands Dollar), @@ -654,12 +654,12 @@ $Locale::Codes::Data{'currency'}{'alias2id'} = { q(0031), q(0), ], - q(canadian dollar) => [ - q(0034), + q(cabo verde escudo) => [ + q(0035), q(0), ], - q(cape verde escudo) => [ - q(0035), + q(canadian dollar) => [ + q(0034), q(0), ], q(cayman islands dollar) => [ diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Currency_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/Currency_Retired.pm index 510007d..2171ed3 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Currency_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Currency_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::Currency_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'currency'}{'alpha'}{'code'} = { q(ADP) => q(Andorran Peseta), @@ -82,6 +82,7 @@ $Locale::Codes::Retired{'currency'}{'alpha'}{'name'} = { q(bolivar fuerte) => [ q(VEF), q(Bolivar Fuerte) ], q(bond markets units european composite unit (eurco)) => [ q(XBA), q(Bond Markets Units European Composite Unit (EURCO)) ], q(candian dollar) => [ q(CAD), q(Candian Dollar) ], + q(cape verde escudo) => [ q(CVE), q(Cape Verde Escudo) ], q(cedi) => [ q(GHS), q(Cedi) ], q(convertible marks) => [ q(BAM), q(Convertible Marks) ], q(cyprus pound) => [ q(CYP), q(Cyprus Pound) ], @@ -148,6 +149,7 @@ $Locale::Codes::Retired{'currency'}{'alpha'}{'name'} = { $Locale::Codes::Retired{'currency'}{'num'}{'name'} = { q(bolivar fuerte) => [ q(937), q(Bolivar Fuerte) ], + q(cape verde escudo) => [ q(132), q(Cape Verde Escudo) ], q(cedi) => [ q(936), q(Cedi) ], q(latvian lats) => [ q(428), q(Latvian Lats) ], q(leu) => [ q(946), q(Leu) ], diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pm index cde7a0a..76f9d22 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pm @@ -20,7 +20,7 @@ use Locale::Codes::LangExt_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2langext langext2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pod b/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pod index 47cb8ab..34aed49 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangExt.pod @@ -52,15 +52,15 @@ This is the default code set. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Codes.pm index 421b641..56a98e8 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::LangExt_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 11:23:46 EDT 2014 +# Generated on: Fri Aug 22 15:31:59 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'langext'}{'id'} = '0229'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Retired.pm index 4df7433..c70fdbf 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangExt_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::LangExt_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'langext'}{'alpha'}{'code'} = { }; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pm index 78a8b3e..e0a8bef 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pm @@ -20,7 +20,7 @@ use Locale::Codes::LangFam_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2langfam langfam2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pod b/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pod index 0b597d4..a67ccef 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangFam.pod @@ -52,15 +52,15 @@ This is the default code set. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Codes.pm index 0d7eedb..28f9a10 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::LangFam_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 11:23:56 EDT 2014 +# Generated on: Fri Aug 22 15:32:07 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'langfam'}{'id'} = '0116'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Retired.pm index e524d5f..9eaf6e7 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangFam_Retired.pm @@ -38,7 +38,7 @@ use warnings; require 5.002; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'langfam'}{'alpha'}{'code'} = { }; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pm index 50882d1..513d7d2 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pm @@ -20,7 +20,7 @@ use Locale::Codes::LangVar_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2langvar langvar2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pod b/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pod index e0a3c06..463251a 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangVar.pod @@ -54,15 +54,15 @@ This is the default code set. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Codes.pm index 84638ec..260db40 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::LangVar_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 11:23:53 EDT 2014 +# Generated on: Fri Aug 22 15:32:06 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'langvar'}{'id'} = '0067'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Retired.pm index b343836..22e44bc 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/LangVar_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::LangVar_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'langvar'}{'alpha'}{'code'} = { }; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Language.pm b/cpan/Locale-Codes/lib/Locale/Codes/Language.pm index 8c48271..08ff561 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Language.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Language.pm @@ -22,7 +22,7 @@ use Locale::Codes::Language_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2language language2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Language.pod b/cpan/Locale-Codes/lib/Locale/Codes/Language.pod index 648da38..aefb693 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Language.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/Language.pod @@ -63,15 +63,15 @@ ISO 639. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Language_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/Language_Codes.pm index 152a2e8..df3b8a0 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Language_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Language_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::Language_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 10:48:07 EDT 2014 +# Generated on: Fri Aug 22 15:27:10 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'language'}{'id'} = '7991'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Language_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/Language_Retired.pm index a4fd408..7fb25ba 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Language_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Language_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::Language_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'language'}{'alpha-2'}{'code'} = { q(in) => q(Indonesian), diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Script.pm b/cpan/Locale-Codes/lib/Locale/Codes/Script.pm index 09e0561..a842454 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Script.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Script.pm @@ -22,7 +22,7 @@ use Locale::Codes::Script_Retired; our($VERSION,@ISA,@EXPORT,@EXPORT_OK); -$VERSION='3.31'; +$VERSION='3.32'; @ISA = qw(Exporter); @EXPORT = qw(code2script script2code diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Script.pod b/cpan/Locale-Codes/lib/Locale/Codes/Script.pod index 771b46e..1de28ec 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Script.pod +++ b/cpan/Locale-Codes/lib/Locale/Codes/Script.pod @@ -61,15 +61,15 @@ for Phoenician. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Script_Codes.pm b/cpan/Locale-Codes/lib/Locale/Codes/Script_Codes.pm index 9897ba8..76c2fb2 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Script_Codes.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Script_Codes.pm @@ -3,7 +3,7 @@ Locale::Codes::Script_Codes; # This file was automatically generated. Any changes to this file will # be lost the next time 'harvest_data' is run. -# Generated on: Wed May 28 11:22:35 EDT 2014 +# Generated on: Fri Aug 22 15:31:57 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Data{'script'}{'id'} = '0166'; diff --git a/cpan/Locale-Codes/lib/Locale/Codes/Script_Retired.pm b/cpan/Locale-Codes/lib/Locale/Codes/Script_Retired.pm index 8d1b67a..b873a15 100644 --- a/cpan/Locale-Codes/lib/Locale/Codes/Script_Retired.pm +++ b/cpan/Locale-Codes/lib/Locale/Codes/Script_Retired.pm @@ -3,7 +3,7 @@ Locale::Codes::Script_Retired; # This file was automatically generated. Any changes to this file will # be lost the next time 'deprecate_codes' is run. -# Generated on: Wed May 28 11:24:54 EDT 2014 +# Generated on: Tue Aug 26 11:38:09 EDT 2014 use strict; require 5.006; @@ -11,7 +11,7 @@ use warnings; use utf8; our($VERSION); -$VERSION='3.31'; +$VERSION='3.32'; $Locale::Codes::Retired{'script'}{'alpha'}{'code'} = { }; diff --git a/cpan/Locale-Codes/lib/Locale/Country.pm b/cpan/Locale-Codes/lib/Locale/Country.pm index 1fb75b6..caef0a8 100644 --- a/cpan/Locale-Codes/lib/Locale/Country.pm +++ b/cpan/Locale-Codes/lib/Locale/Country.pm @@ -10,7 +10,7 @@ use warnings; use Exporter; our $VERSION; -$VERSION='3.31'; +$VERSION='3.32'; our (@ISA,@EXPORT); diff --git a/cpan/Locale-Codes/lib/Locale/Country.pod b/cpan/Locale-Codes/lib/Locale/Country.pod index 7639f7a..e89226d 100644 --- a/cpan/Locale-Codes/lib/Locale/Country.pod +++ b/cpan/Locale-Codes/lib/Locale/Country.pod @@ -80,15 +80,15 @@ Locale::Codes::Changes document for details. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Currency.pm b/cpan/Locale-Codes/lib/Locale/Currency.pm index 555fd77..de0b6c8 100644 --- a/cpan/Locale-Codes/lib/Locale/Currency.pm +++ b/cpan/Locale-Codes/lib/Locale/Currency.pm @@ -10,7 +10,7 @@ use warnings; use Exporter; our $VERSION; -$VERSION='3.31'; +$VERSION='3.32'; our (@ISA,@EXPORT); diff --git a/cpan/Locale-Codes/lib/Locale/Currency.pod b/cpan/Locale-Codes/lib/Locale/Currency.pod index 1638390..8ad59aa 100644 --- a/cpan/Locale-Codes/lib/Locale/Currency.pod +++ b/cpan/Locale-Codes/lib/Locale/Currency.pod @@ -60,15 +60,15 @@ This is the set of three-digit numeric codes from ISO 4217. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Language.pm b/cpan/Locale-Codes/lib/Locale/Language.pm index 7a785d2..e87af27 100644 --- a/cpan/Locale-Codes/lib/Locale/Language.pm +++ b/cpan/Locale-Codes/lib/Locale/Language.pm @@ -10,7 +10,7 @@ use warnings; use Exporter; our $VERSION; -$VERSION='3.31'; +$VERSION='3.32'; our (@ISA,@EXPORT); diff --git a/cpan/Locale-Codes/lib/Locale/Language.pod b/cpan/Locale-Codes/lib/Locale/Language.pod index 9504853..0cf5066 100644 --- a/cpan/Locale-Codes/lib/Locale/Language.pod +++ b/cpan/Locale-Codes/lib/Locale/Language.pod @@ -63,15 +63,15 @@ ISO 639. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Locale-Codes/lib/Locale/Script.pm b/cpan/Locale-Codes/lib/Locale/Script.pm index 776ac62..164e996 100644 --- a/cpan/Locale-Codes/lib/Locale/Script.pm +++ b/cpan/Locale-Codes/lib/Locale/Script.pm @@ -10,7 +10,7 @@ use warnings; use Exporter; our $VERSION; -$VERSION='3.31'; +$VERSION='3.32'; our (@ISA,@EXPORT); diff --git a/cpan/Locale-Codes/lib/Locale/Script.pod b/cpan/Locale-Codes/lib/Locale/Script.pod index f466c30..07e5c83 100644 --- a/cpan/Locale-Codes/lib/Locale/Script.pod +++ b/cpan/Locale-Codes/lib/Locale/Script.pod @@ -61,15 +61,15 @@ for Phoenician. =over 4 -=item B +=item B -=item B +=item B =item B -=item B +=item B -=item B +=item B =item B diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm index 6ddd21d..d1d7cf6 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm @@ -12,7 +12,7 @@ use File::Spec::Functions qw(catfile catdir splitdir); use vars qw($VERSION @Pagers $Bindir $Pod2man $Temp_Files_Created $Temp_File_Lifetime ); -$VERSION = '3.23'; +$VERSION = '3.24'; #.......................................................................... @@ -939,7 +939,7 @@ sub maybe_generate_dynamic_pod { $self->aside("Hm, I found some Pod from that search!\n"); my ($buffd, $buffer) = $self->new_tempfile('pod', 'dyn'); if ( $] >= 5.008 && $self->opt_L ) { - binmode($buffd, ":utf8"); + binmode($buffd, ":encoding(UTF-8)"); print $buffd "=encoding utf8\n\n"; } @@ -1043,6 +1043,7 @@ sub search_perlvar { open(PVAR, "<", $perlvar) # "Funk is its own reward" or $self->die("Can't open $perlvar: $!"); + binmode(PVAR, ":encoding(UTF-8)"); if ( $opt ne '$0' && $opt =~ /^\$\d+$/ ) { # handle $1, $2, ... $opt = '$>'; } @@ -1112,6 +1113,7 @@ sub search_perlop { # especially since we need to support UTF8 or other encoding when dealing # with perlop, perlfunc, perlapi, perlfaq[1-9] open( PERLOP, '<', $perlop ) or $self->die( "Can't open $perlop: $!" ); + binmode(PERLOP, ":encoding(UTF-8)"); my $thing = $self->opt_f; @@ -1202,7 +1204,7 @@ sub search_perlapi { $self->aside("Your old perl doesn't really have proper unicode support."); } else { - binmode(PAPI, ":utf8"); + binmode(PAPI, ":encoding(UTF-8)"); } } @@ -1284,7 +1286,7 @@ sub search_perlfunc { $self->aside("Your old perl doesn't really have proper unicode support."); } else { - binmode(PFUNC, ":utf8"); + binmode(PFUNC, ":encoding(UTF-8)"); } } @@ -1379,6 +1381,7 @@ EOD $self->die( "invalid file spec: $!" ) if $file =~ /[<>|]/; open(INFAQ, "<", $file) # XXX 5.6ism or $self->die( "Can't read-open $file: $!\nAborting" ); + binmode(INFAQ, ":encoding(UTF-8)"); while () { if ( m/^=head2\s+.*(?:$search_key)/i ) { $found = 1; diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/BaseTo.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/BaseTo.pm index b216d42..29eb7fb 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/BaseTo.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/BaseTo.pm @@ -3,7 +3,7 @@ use strict; use warnings; use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; use Carp qw(croak carp); use Config qw(%Config); diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm index 3f4e218..e05b953 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/GetOptsOO.pm @@ -2,7 +2,7 @@ package Pod::Perldoc::GetOptsOO; use strict; use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; BEGIN { # Make a DEBUG constant ASAP *DEBUG = defined( &Pod::Perldoc::DEBUG ) diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToANSI.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToANSI.pm index f0ecbce..19a14ba 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToANSI.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToANSI.pm @@ -4,7 +4,7 @@ use warnings; use parent qw(Pod::Perldoc::BaseTo); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; sub is_pageable { 1 } sub write_with_binmode { 0 } diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToChecker.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToChecker.pm index 8bff338..b153b76 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToChecker.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToChecker.pm @@ -4,7 +4,7 @@ use warnings; use vars qw(@ISA); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; # Pick our superclass... # diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm index 1080dbd..7ee17b1 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm @@ -5,7 +5,7 @@ use warnings; use parent qw(Pod::Perldoc::BaseTo); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; use File::Spec::Functions qw(catfile); use Pod::Man 2.18; diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToNroff.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToNroff.pm index 9777581..9b7f210 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToNroff.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToNroff.pm @@ -4,7 +4,7 @@ use warnings; use parent qw(Pod::Perldoc::BaseTo); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; # This is unlike ToMan.pm in that it emits the raw nroff source! diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToPod.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToPod.pm index 97185bb..777bae1 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToPod.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToPod.pm @@ -4,7 +4,7 @@ use warnings; use parent qw(Pod::Perldoc::BaseTo); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; sub is_pageable { 1 } sub write_with_binmode { 0 } diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToRtf.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToRtf.pm index 5884057..392ea1e 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToRtf.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToRtf.pm @@ -4,7 +4,7 @@ use warnings; use parent qw( Pod::Simple::RTF ); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; sub is_pageable { 0 } sub write_with_binmode { 0 } diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTerm.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTerm.pm index 693b52a..bbc0755 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTerm.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTerm.pm @@ -3,7 +3,7 @@ use strict; use warnings; use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; use parent qw(Pod::Perldoc::BaseTo); diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToText.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToText.pm index 07f44cd..69a2f29 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToText.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToText.pm @@ -3,7 +3,7 @@ use strict; use warnings; use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; use parent qw(Pod::Perldoc::BaseTo); diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm index 627289e..5b87153 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToTk.pm @@ -3,7 +3,7 @@ use strict; use warnings; use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; use parent qw(Pod::Perldoc::BaseTo); diff --git a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm index 5c86b3e..f1670e3 100644 --- a/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm +++ b/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToXml.pm @@ -6,7 +6,7 @@ use vars qw($VERSION); use parent qw( Pod::Simple::XMLOutStream ); use vars qw($VERSION); -$VERSION = '3.23'; +$VERSION = '3.24'; sub is_pageable { 0 } sub write_with_binmode { 0 } diff --git a/cpan/Scalar-List-Utils/ListUtil.xs b/cpan/Scalar-List-Utils/ListUtil.xs index e6a2eaa..515677f 100644 --- a/cpan/Scalar-List-Utils/ListUtil.xs +++ b/cpan/Scalar-List-Utils/ListUtil.xs @@ -82,6 +82,9 @@ static enum slu_accum accum_type(SV *sv) { return ACC_NV; } +/* Magic for set_subname */ +static MGVTBL subname_vtbl; + MODULE=List::Util PACKAGE=List::Util void @@ -237,6 +240,8 @@ CODE: retsv = TARG; switch(accum) { + case ACC_SV: /* nothing to do */ + break; case ACC_IV: sv_setiv(retsv, retiv); break; @@ -316,7 +321,7 @@ CODE: SAVESPTR(GvSV(agv)); SAVESPTR(GvSV(bgv)); GvSV(agv) = ret; - SvSetSV(ret, args[1]); + SvSetMagicSV(ret, args[1]); #ifdef dMULTICALL if(!CvISXSUB(cv)) { dMULTICALL; @@ -326,7 +331,7 @@ CODE: for(index = 2 ; index < items ; index++) { GvSV(bgv) = args[index]; MULTICALL; - SvSetSV(ret, *PL_stack_sp); + SvSetMagicSV(ret, *PL_stack_sp); } # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT if(CvDEPTH(multicall_cv) > 1) @@ -344,7 +349,7 @@ CODE: PUSHMARK(SP); call_sv((SV*)cv, G_SCALAR); - SvSetSV(ret, *PL_stack_sp); + SvSetMagicSV(ret, *PL_stack_sp); } } @@ -1064,7 +1069,7 @@ CODE: croak("vstrings are not implemented in this release of perl"); #endif -int +SV * looks_like_number(sv) SV *sv PROTOTYPE: $ @@ -1076,47 +1081,18 @@ CODE: } #if PERL_BCDVERSION < 0x5008005 if(SvPOK(sv) || SvPOKp(sv)) { - RETVAL = !!looks_like_number(sv); + RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; } else { - RETVAL = SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + RETVAL = (SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK)) ? &PL_sv_yes : &PL_sv_no; } #else - RETVAL = !!looks_like_number(sv); + RETVAL = looks_like_number(sv) ? &PL_sv_yes : &PL_sv_no; #endif OUTPUT: RETVAL void -set_prototype(subref, proto) - SV *subref - SV *proto -PROTOTYPE: &$ -CODE: -{ - SvGETMAGIC(subref); - if(SvROK(subref)) { - SV *sv = SvRV(subref); - if(SvTYPE(sv) != SVt_PVCV) { - /* not a subroutine reference */ - croak("set_prototype: not a subroutine reference"); - } - if(SvPOK(proto)) { - /* set the prototype */ - sv_copypv(sv, proto); - } - else { - /* delete the prototype */ - SvPOK_off(sv); - } - } - else { - croak("set_prototype: not a reference"); - } - XSRETURN(1); -} - -void openhandle(SV *sv) PROTOTYPE: $ CODE: @@ -1145,6 +1121,164 @@ CODE: XSRETURN_UNDEF; } +MODULE=List::Util PACKAGE=Sub::Util + +void +set_prototype(proto, code) + SV *proto + SV *code +PREINIT: + SV *cv; /* not CV * */ +PPCODE: + SvGETMAGIC(code); + if(!SvROK(code)) + croak("set_prototype: not a reference"); + + cv = SvRV(code); + if(SvTYPE(cv) != SVt_PVCV) + croak("set_prototype: not a subroutine reference"); + + if(SvPOK(proto)) { + /* set the prototype */ + sv_copypv(cv, proto); + } + else { + /* delete the prototype */ + SvPOK_off(cv); + } + + PUSHs(code); + XSRETURN(1); + +void +set_subname(name, sub) + char *name + SV *sub +PREINIT: + CV *cv = NULL; + GV *gv; + HV *stash = CopSTASH(PL_curcop); + char *s, *end = NULL; + MAGIC *mg; +PPCODE: + if (!SvROK(sub) && SvGMAGICAL(sub)) + mg_get(sub); + if (SvROK(sub)) + cv = (CV *) SvRV(sub); + else if (SvTYPE(sub) == SVt_PVGV) + cv = GvCVu(sub); + else if (!SvOK(sub)) + croak(PL_no_usym, "a subroutine"); + else if (PL_op->op_private & HINT_STRICT_REFS) + croak("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use", + SvPV_nolen(sub), "a subroutine"); + else if ((gv = gv_fetchpv(SvPV_nolen(sub), FALSE, SVt_PVCV))) + cv = GvCVu(gv); + if (!cv) + croak("Undefined subroutine %s", SvPV_nolen(sub)); + if (SvTYPE(cv) != SVt_PVCV && SvTYPE(cv) != SVt_PVFM) + croak("Not a subroutine reference"); + for (s = name; *s++; ) { + if (*s == ':' && s[-1] == ':') + end = ++s; + else if (*s && s[-1] == '\'') + end = s; + } + s--; + if (end) { + char *namepv = savepvn(name, end - name); + stash = GvHV(gv_fetchpv(namepv, TRUE, SVt_PVHV)); + Safefree(namepv); + name = end; + } + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV *hv = GvHV(PL_DBsub); + + char *new_pkg = HvNAME(stash); + + char *old_name = GvNAME( CvGV(cv) ); + char *old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); + + int old_len = strlen(old_name) + strlen(old_pkg); + int new_len = strlen(name) + strlen(new_pkg); + + SV **old_data; + char *full_name; + + Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); + + strcat(full_name, old_pkg); + strcat(full_name, "::"); + strcat(full_name, old_name); + + old_data = hv_fetch(hv, full_name, strlen(full_name), 0); + + if (old_data) { + strcpy(full_name, new_pkg); + strcat(full_name, "::"); + strcat(full_name, name); + + SvREFCNT_inc(*old_data); + if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0)) + SvREFCNT_dec(*old_data); + } + Safefree(full_name); + } + + gv = (GV *) newSV(0); + gv_init(gv, stash, name, s - name, TRUE); + + /* + * set_subname needs to create a GV to store the name. The CvGV field of a + * CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV if + * it destroys the containing CV. We use a MAGIC with an empty vtable + * simply for the side-effect of using MGf_REFCOUNTED to store the + * actually-counted reference to the GV. + */ + mg = SvMAGIC(cv); + while (mg && mg->mg_virtual != &subname_vtbl) + mg = mg->mg_moremagic; + if (!mg) { + Newxz(mg, 1, MAGIC); + mg->mg_moremagic = SvMAGIC(cv); + mg->mg_type = PERL_MAGIC_ext; + mg->mg_virtual = &subname_vtbl; + SvMAGIC_set(cv, mg); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = (SV *) gv; + SvRMAGICAL_on(cv); + CvANON_off(cv); +#ifndef CvGV_set + CvGV(cv) = gv; +#else + CvGV_set(cv, gv); +#endif + PUSHs(sub); + +void +subname(code) + SV *code +PREINIT: + CV *cv; + GV *gv; +PPCODE: + if (!SvROK(code) && SvGMAGICAL(code)) + mg_get(code); + + if(!SvROK(code) || SvTYPE(cv = (CV *)SvRV(code)) != SVt_PVCV) + croak("Not a subroutine reference"); + + if(!(gv = CvGV(cv))) + XSRETURN(0); + + mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv))); + XSRETURN(1); + BOOT: { HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE); diff --git a/cpan/Scalar-List-Utils/lib/List/Util.pm b/cpan/Scalar-List-Utils/lib/List/Util.pm index c99bcd4..837b6c8 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -14,7 +14,7 @@ our @EXPORT_OK = qw( all any first min max minstr maxstr none notall product reduce sum sum0 shuffle pairmap pairgrep pairfirst pairs pairkeys pairvalues ); -our $VERSION = "1.39"; +our $VERSION = "1.41"; our $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -110,7 +110,9 @@ C being returned The remaining list-reduction functions are all specialisations of this generic idea. -=head2 $b = any { BLOCK } @list +=head2 any + + my $bool = any { BLOCK } @list; I @@ -126,26 +128,34 @@ instead, as it can short-circuit after the first true result. # at least one string has more than 10 characters } -=head2 $b = all { BLOCK } @list +=head2 all + + my $bool = all { BLOCK } @list; I -Similar to C, except that it requires all elements of the C<@list> to make -the C return true. If any element returns false, then it returns false. -If the C never returns false or the C<@list> was empty then it returns -true. +Similar to L, except that it requires all elements of the C<@list> to +make the C return true. If any element returns false, then it returns +false. If the C never returns false or the C<@list> was empty then it +returns true. + +=head2 none -=head2 $b = none { BLOCK } @list +=head2 notall -=head2 $b = notall { BLOCK } @list + my $bool = none { BLOCK } @list; + + my $bool = notall { BLOCK } @list; I -Similar to C and C, but with the return sense inverted. C -returns true only if no value in the LIST causes the BLOCK to return true, and -C returns true only if not all of the values do. +Similar to L and L, but with the return sense inverted. C +returns true only if no value in the C<@list> causes the C to return +true, and C returns true only if not all of the values do. + +=head2 first -=head2 $val = first { BLOCK } @list + my $val = first { BLOCK } @list; Similar to C in that it evaluates C setting C<$_> to each element of C<@list> in turn. C returns the first element where the result from @@ -156,7 +166,9 @@ then C is returned. $foo = first { $_ > $value } @list # first value in @list which # is greater than $value -=head2 $num = max @list +=head2 max + + my $num = max @list; Returns the entry in the list with the highest numerical value. If the list is empty then C is returned. @@ -165,9 +177,11 @@ empty then C is returned. $foo = max 3,9,12 # 12 $foo = max @bar, @baz # whatever -=head2 $str = maxstr @list +=head2 maxstr + + my $str = maxstr @list; -Similar to C, but treats all the entries in the list as strings and +Similar to L, but treats all the entries in the list as strings and returns the highest string as defined by the C operator. If the list is empty then C is returned. @@ -175,18 +189,22 @@ empty then C is returned. $foo = maxstr "hello","world" # "world" $foo = maxstr @bar, @baz # whatever -=head2 $num = min @list +=head2 min + + my $num = min @list; -Similar to C but returns the entry in the list with the lowest numerical +Similar to L but returns the entry in the list with the lowest numerical value. If the list is empty then C is returned. $foo = min 1..10 # 1 $foo = min 3,9,12 # 3 $foo = min @bar, @baz # whatever -=head2 $str = minstr @list +=head2 minstr -Similar to C, but treats all the entries in the list as strings and + my $str = minstr @list; + +Similar to L, but treats all the entries in the list as strings and returns the lowest string as defined by the C operator. If the list is empty then C is returned. @@ -194,7 +212,9 @@ empty then C is returned. $foo = minstr "hello","world" # "hello" $foo = minstr @bar, @baz # whatever -=head2 $num = product @list +=head2 product + + my $num = product @list; I @@ -204,7 +224,9 @@ empty then C<1> is returned. $foo = product 1..10 # 3628800 $foo = product 3,9,12 # 324 -=head2 $num_or_undef = sum @list +=head2 sum + + my $num_or_undef = sum @list; Returns the numerical sum of all the elements in C<@list>. For backwards compatibility, if C<@list> is empty then C is returned. @@ -213,12 +235,14 @@ compatibility, if C<@list> is empty then C is returned. $foo = sum 3,9,12 # 24 $foo = sum @bar, @baz # whatever -=head2 $num = sum0 @list +=head2 sum0 + + my $num = sum0 @list; I -Similar to C, except this returns 0 when given an empty list, rather than -C. +Similar to L, except this returns 0 when given an empty list, rather +than C. =cut @@ -232,9 +256,11 @@ value - nor even do they require that the first of each pair be a plain string. =cut -=head2 @kvlist = pairgrep { BLOCK } @kvlist +=head2 pairgrep + + my @kvlist = pairgrep { BLOCK } @kvlist; -=head2 $count = pairgrep { BLOCK } @kvlist + my $count = pairgrep { BLOCK } @kvlist; I @@ -254,13 +280,15 @@ As with C aliasing C<$_> to list elements, C aliases C<$a> and C<$b> to elements of the given list. Any modifications of it by the code block will be visible to the caller. -=head2 ( $key, $val ) = pairfirst { BLOCK } @kvlist +=head2 pairfirst -=head2 $found = pairfirst { BLOCK } @kvlist + my ( $key, $val ) = pairfirst { BLOCK } @kvlist; + + my $found = pairfirst { BLOCK } @kvlist; I -Similar to the C function, but interprets the given list as an +Similar to the L function, but interprets the given list as an even-sized list of pairs. It invokes the C multiple times, in scalar context, with C<$a> and C<$b> set to successive pairs of values from the C<@kvlist>. @@ -276,9 +304,11 @@ As with C aliasing C<$_> to list elements, C aliases C<$a> and C<$b> to elements of the given list. Any modifications of it by the code block will be visible to the caller. -=head2 @list = pairmap { BLOCK } @kvlist +=head2 pairmap + + my @list = pairmap { BLOCK } @kvlist; -=head2 $count = pairmap { BLOCK } @kvlist + my $count = pairmap { BLOCK } @kvlist; I @@ -299,7 +329,9 @@ will be visible to the caller. See L for a known-bug with C, and a workaround. -=head2 @pairs = pairs @kvlist +=head2 pairs + + my @pairs = pairs @kvlist; I @@ -325,7 +357,9 @@ the two methods C and C. The following code is equivalent: ... } -=head2 @keys = pairkeys @kvlist +=head2 pairkeys + + my @keys = pairkeys @kvlist; I @@ -335,7 +369,9 @@ It is a more efficient version of @keys = pairmap { $a } @kvlist -=head2 @values = pairvalues @kvlist +=head2 pairvalues + + my @values = pairvalues @kvlist; I @@ -351,7 +387,9 @@ It is a more efficient version of =cut -=head2 @values = shuffle @values +=head2 shuffle + + my @values = shuffle @values; Returns the values of the input in a random order @@ -365,7 +403,7 @@ Returns the values of the input in a random order L -If the block of code given to C contains lexical variables that are +If the block of code given to L contains lexical variables that are captured by a returned closure, and the closure is executed after the block has been re-used for the next iteration, these lexicals will not see the correct values. For example: diff --git a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index e605d88..f2e01ae 100644 --- a/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -2,7 +2,7 @@ package List::Util::XS; use strict; use List::Util; -our $VERSION = "1.39"; # FIXUP +our $VERSION = "1.41"; # FIXUP $VERSION = eval $VERSION; # FIXUP 1; diff --git a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index 06d3660..3f17d13 100644 --- a/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -14,9 +14,10 @@ our @ISA = qw(Exporter); our @EXPORT_OK = qw( blessed refaddr reftype weaken unweaken isweak - dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted + dualvar isdual isvstring looks_like_number openhandle readonly set_prototype + tainted ); -our $VERSION = "1.39"; +our $VERSION = "1.41"; $VERSION = eval $VERSION; our @EXPORT_FAIL; @@ -45,6 +46,13 @@ sub export_fail { @_; } +# set_prototype has been moved to Sub::Util with a different interface +sub set_prototype(&$) +{ + my ( $code, $proto ) = @_; + return Sub::Util::set_prototype( $proto, $code ); +} + 1; __END__ @@ -75,7 +83,9 @@ By default C does not export any subroutines. The following functions all perform some useful activity on reference values. -=head2 $pkg = blessed( $ref ) +=head2 blessed + + my $pkg = blessed( $ref ); If C<$ref> is a blessed reference the name of the package that it is blessed into is returned. Otherwise C is returned. @@ -92,7 +102,9 @@ into is returned. Otherwise C is returned. Take care when using this function simply as a truth test (such as in C) because the package name C<"0"> is defined yet false. -=head2 $addr = refaddr( $ref ) +=head2 refaddr + + my $addr = refaddr( $ref ); If C<$ref> is reference the internal memory address of the referenced value is returned as a plain integer. Otherwise C is returned. @@ -104,7 +116,9 @@ returned as a plain integer. Otherwise C is returned. $obj = bless {}, "Foo"; $addr = refaddr $obj; # eg 88123488 -=head2 $type = reftype( $ref ) +=head2 reftype + + my $type = reftype( $ref ); If C<$ref> is a reference the basic Perl type of the variable referenced is returned as a plain string (such as C or C). Otherwise C @@ -117,9 +131,11 @@ is returned. $obj = bless {}, "Foo"; $type = reftype $obj; # HASH -=head2 weaken( REF ) +=head2 weaken -The lvalue C will be turned into a weak reference. This means that it + weaken( $ref ); + +The lvalue C<$ref> will be turned into a weak reference. This means that it will not hold a reference count on the object it references. Also when the reference count on that object reaches zero, the reference will be set to undef. This function mutates the lvalue passed as its argument and returns no @@ -154,14 +170,16 @@ references to objects will be strong, causing the remaining objects to never be destroyed because there is now always a strong reference to them in the @object array. -=head2 unweaken( REF ) +=head2 unweaken + + unweaken( $ref ); I The lvalue C will be turned from a weak reference back into a normal (strong) reference again. This function mutates the lvalue passed as its argument and returns no value. This undoes the action performed by -C. +L. This function is slightly neater and more convenient than the otherwise-equivalent code @@ -173,7 +191,9 @@ otherwise-equivalent code (because in particular, simply assigning a weak reference back to itself does not work to unweaken it; C<$REF = $REF> does not work). -=head2 $weak = isweak( $ref ) +=head2 isweak + + my $weak = isweak( $ref ); Returns true if C<$ref> is a weak reference. @@ -189,7 +209,9 @@ B: Copying a weak reference creates a normal, strong, reference. =head1 OTHER FUNCTIONS -=head2 $var = dualvar( $num, $string ) +=head2 dualvar + + my $var = dualvar( $num, $string ); Returns a scalar that has the value C<$num> in a numeric context and the value C<$string> in a string context. @@ -198,7 +220,9 @@ C<$string> in a string context. $num = $foo + 2; # 12 $str = $foo . " world"; # Hello world -=head2 $dual = isdual( $var ) +=head2 isdual + + my $dual = isdual( $var ); I @@ -228,7 +252,9 @@ You can capture its numeric and string content using: $err = dualvar $!, $!; $dual = isdual($err); # true -=head2 $vstring = isvstring( $var ) +=head2 isvstring + + my $vstring = isvstring( $var ); If C<$var> is a scalar which was coded as a vstring the result is true. @@ -236,12 +262,16 @@ If C<$var> is a scalar which was coded as a vstring the result is true. $fmt = isvstring($vs) ? "%vd" : "%s"; #true printf($fmt,$vs); -=head2 $isnum = looks_like_number( $var ) +=head2 looks_like_number + + my $isnum = looks_like_number( $var ); Returns true if perl thinks C<$var> is a number. See L. -=head2 $fh = openhandle( $fh ) +=head2 openhandle + + my $fh = openhandle( $fh ); Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is is a tied handle. Otherwise C is returned. @@ -251,7 +281,9 @@ is a tied handle. Otherwise C is returned. $fh = openhandle(*NOTOPEN); # undef $fh = openhandle("scalar"); # undef -=head2 $ro = readonly( $var ) +=head2 readonly + + my $ro = readonly( $var ); Returns true if C<$var> is readonly. @@ -260,14 +292,18 @@ Returns true if C<$var> is readonly. $readonly = foo($bar); # false $readonly = foo(0); # true -=head2 $code = set_prototype( $code, $prototype ) +=head2 set_prototype + + my $code = set_prototype( $code, $prototype ); Sets the prototype of the function given by the C<$code> reference, or deletes it if C<$prototype> is C. Returns the C<$code> reference itself. set_prototype \&foo, '$$'; -=head2 $t = tainted( $var ) +=head2 tainted + + my $t = tainted( $var ); Return true if C<$var> is tainted. @@ -283,12 +319,12 @@ Module use may give one of the following errors during import. =item Weak references are not implemented in the version of perl The version of perl that you are using does not implement weak references, to -use C or C you will need to use a newer release of perl. +use L or L you will need to use a newer release of perl. =item Vstrings are not implemented in the version of perl The version of perl that you are using does not implement Vstrings, to use -C you will need to use a newer release of perl. +L you will need to use a newer release of perl. =item C is only available with the XS version of Scalar::Util @@ -316,10 +352,15 @@ Copyright (c) 1997-2007 Graham Barr . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -Except weaken and isweak which are +Additionally L and L which are Copyright (c) 1999 Tuomas J. Lukka . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as perl itself. +Copyright (C) 2004, 2008 Matthijs van Duin. All rights reserved. +Copyright (C) 2014 cPanel Inc. All rights reserved. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + =cut diff --git a/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/cpan/Scalar-List-Utils/lib/Sub/Util.pm new file mode 100644 index 0000000..e40cf22 --- /dev/null +++ b/cpan/Scalar-List-Utils/lib/Sub/Util.pm @@ -0,0 +1,149 @@ +# Copyright (c) 2014 Paul Evans . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Sub::Util; + +use strict; +use warnings; + +require Exporter; +require List::Util; # as it has the XS + +our @ISA = qw( Exporter ); +our @EXPORT_OK = qw( + prototype set_prototype + subname set_subname +); + +our $VERSION = "1.41"; +$VERSION = eval $VERSION; + +=head1 NAME + +Sub::Util - A selection of utility subroutines for subs and CODE references + +=head1 SYNOPSIS + + use Sub::Util qw( prototype set_prototype subname set_subname ); + +=head1 DESCRIPTION + +C contains a selection of utility subroutines that are useful for +operating on subs and CODE references. + +The rationale for inclusion in this module is that the function performs some +work for which an XS implementation is essential because it cannot be +implemented in Pure Perl, and which is sufficiently-widely used across CPAN +that its popularity warrants inclusion in a core module, which this is. + +=cut + +=head1 FUNCTIONS + +=cut + +=head2 prototype + + my $proto = prototype( $code ) + +I + +Returns the prototype of the given C<$code> reference, if it has one, as a +string. This is the same as the C operator; it is included +here simply for symmetry and completeness with the other functions. + +=cut + +sub prototype +{ + my ( $code ) = @_; + return CORE::prototype( $code ); +} + +=head2 set_prototype + + my $code = set_prototype $prototype, $code; + +I + +Sets the prototype of the function given by the C<$code> reference, or deletes +it if C<$prototype> is C. Returns the C<$code> reference itself. + +I: This function takes arguments in a different order to the previous +copy of the code from C. This is to match the order of +C, and other potential additions in this file. This order has +been chosen as it allows a neat and simple chaining of other +C functions as might become available, such as: + + my $code = + set_subname name_here => + set_prototype '&@' => + set_attribute ':lvalue' => + sub { ...... }; + +=cut + +=head2 subname + + my $name = subname( $code ) + +I + +Returns the name of the given C<$code> reference, if it has one. Normal named +subs will give a fully-qualified name consisting of the package and the +localname separated by C<::>. Anonymous code references will give C<__ANON__> +as the localname. If a name has been set using L, this name will +be returned instead. + +This function was inspired by C from L. The +remaining functions that C implements can easily be emulated +using regexp operations, such as + + sub get_code_info { return (subname $_[0]) =~ m/^(.+)::(.+?)$/ } + sub sub_name { return (get_code_info $_[0])[0] } + sub stash_name { return (get_code_info $_[0])[1] } + +I: This function is B the same as +C; it returns the existing name of the sub rather than +changing it. To set or change a name, see instead L. + +=cut + +=head2 set_subname + + my $code = set_subname $name, $code; + +I + +Sets the name of the function given by the C<$code> reference. Returns the +C<$code> reference itself. If the C<$name> is unqualified, the package of the +caller is used to qualify it. + +This is useful for applying names to anonymous CODE references so that stack +traces and similar situations, to give a useful name rather than having the +default of C<__ANON__>. Note that this name is only used for this situation; +the C will not install it into the symbol table; you will have to +do that yourself if required. + +However, since the name is not used by perl except as the return value of +C, for stack traces or similar, there is no actual requirement that +the name be syntactically valid as a perl function name. This could be used to +attach extra information that could be useful in debugging stack traces. + +This function was copied from C and renamed to the naming +convention of this module. + +=cut + +=head1 AUTHOR + +The general structure of this module was written by Paul Evans +. + +The XS implementation of L was copied from L by +Matthijs van Duin + +=cut + +1; diff --git a/cpan/Scalar-List-Utils/t/prototype.t b/cpan/Scalar-List-Utils/t/prototype.t new file mode 100644 index 0000000..32549a8 --- /dev/null +++ b/cpan/Scalar-List-Utils/t/prototype.t @@ -0,0 +1,40 @@ +#!./perl + +use strict; +use warnings; + +use Sub::Util qw( prototype set_prototype ); +use Test::More tests => 13; + +sub f { } +is( prototype('f'), undef, 'no prototype'); +is( CORE::prototype('f'), undef, 'no prototype from CORE'); + +my $r = set_prototype('$', \&f); +is( prototype('f'), '$', 'prototype'); +is( CORE::prototype('f'), '$', 'prototype from CORE'); +is( $r, \&f, 'return value'); + +set_prototype(undef, \&f); +is( prototype('f'), undef, 'remove prototype'); + +set_prototype('', \&f); +is( prototype('f'), '', 'empty prototype'); + +sub g (@) { } +is( prototype('g'), '@', '@ prototype'); + +set_prototype(undef, \&g); +is( prototype('g'), undef, 'remove prototype'); + +sub stub; +is( prototype('stub'), undef, 'non existing sub'); + +set_prototype('$$$', \&stub); +is( prototype('stub'), '$$$', 'change non existing sub'); + +sub f_decl ($$$$); +is( prototype('f_decl'), '$$$$', 'forward declaration'); + +set_prototype('\%', \&f_decl); +is( prototype('f_decl'), '\%', 'change forward declaration'); diff --git a/cpan/Scalar-List-Utils/t/reduce.t b/cpan/Scalar-List-Utils/t/reduce.t index b8acbe7..848c34f 100644 --- a/cpan/Scalar-List-Utils/t/reduce.t +++ b/cpan/Scalar-List-Utils/t/reduce.t @@ -5,7 +5,7 @@ use warnings; use List::Util qw(reduce min); use Test::More; -plan tests => 29 + ($::PERL_ONLY ? 0 : 2); +plan tests => 30 + ($::PERL_ONLY ? 0 : 2); my $v = reduce {}; @@ -160,3 +160,6 @@ ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); eval { &reduce(+{},1,2,3) }; ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); +my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk'); +my $longest = reduce { length($a) > length($b) ? $a : $b } @names; +is( length($longest), 6, 'missing SMG rt#121992'); diff --git a/cpan/Scalar-List-Utils/t/proto.t b/cpan/Scalar-List-Utils/t/scalarutil-proto.t similarity index 100% rename from cpan/Scalar-List-Utils/t/proto.t rename to cpan/Scalar-List-Utils/t/scalarutil-proto.t diff --git a/cpan/Scalar-List-Utils/t/subname.t b/cpan/Scalar-List-Utils/t/subname.t new file mode 100644 index 0000000..1bf8a9f --- /dev/null +++ b/cpan/Scalar-List-Utils/t/subname.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +BEGIN { $^P |= 0x210 } + +use Test::More tests => 18; + +use B::Deparse; +use Sub::Util qw( subname set_subname ); + +{ + sub localfunc {} + sub fully::qualified::func {} + + is(subname(\&subname), "Sub::Util::subname", + 'subname of \&subname'); + is(subname(\&localfunc), "main::localfunc", + 'subname of \&localfunc'); + is(subname(\&fully::qualified::func), "fully::qualified::func", + 'subname of \&fully::qualfied::func'); + + # Because of the $^P debug flag, we'll get [file:line] as well + like(subname(sub {}), qr/^main::__ANON__\[.+:\d+\]$/, 'subname of anon sub'); + + ok(!eval { subname([]) }, 'subname [] dies'); +} + +my $x = set_subname foo => sub { (caller 0)[3] }; +my $line = __LINE__ - 1; +my $file = __FILE__; +my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"}; + +is($x->(), "main::foo"); + +{ + package Blork; + + use Sub::Util qw( set_subname ); + + set_subname " Bar!", $x; + ::is($x->(), "Blork:: Bar!"); + + set_subname "Foo::Bar::Baz", $x; + ::is($x->(), "Foo::Bar::Baz"); + + set_subname "set_subname (dynamic $_)", \&set_subname for 1 .. 3; + + for (4 .. 5) { + set_subname "Dynamic $_", $x; + ::is($x->(), "Blork::Dynamic $_"); + } + + ::is($DB::sub{"main::foo"}, $anon); + + for (4 .. 5) { + ::is($DB::sub{"Blork::Dynamic $_"}, $anon); + } + + for ("Blork:: Bar!", "Foo::Bar::Baz") { + ::is($DB::sub{$_}, $anon); + } +} + +# RT42725 +{ + my $source = eval { + B::Deparse->new->coderef2text(set_subname foo => sub{ @_ }); + }; + + ok !$@; + + like $source, qr/\@\_/; +} + +# subname of set_subname +{ + is(subname(set_subname "my-scary-name-here", sub {}), "main::my-scary-name-here", + 'subname of set_subname'); +} + +# vim: ft=perl diff --git a/cpan/Test-Harness/lib/App/Prove.pm b/cpan/Test-Harness/lib/App/Prove.pm index 7f8e787..94b7c73 100644 --- a/cpan/Test-Harness/lib/App/Prove.pm +++ b/cpan/Test-Harness/lib/App/Prove.pm @@ -18,11 +18,11 @@ App::Prove - Implements the C command. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State.pm b/cpan/Test-Harness/lib/App/Prove/State.pm index ecb5fd5..c41ecd7 100644 --- a/cpan/Test-Harness/lib/App/Prove/State.pm +++ b/cpan/Test-Harness/lib/App/Prove/State.pm @@ -25,11 +25,11 @@ App::Prove::State - State storage for the C command. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result.pm b/cpan/Test-Harness/lib/App/Prove/State/Result.pm index 80ab1bd..474a362 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result.pm @@ -14,11 +14,11 @@ App::Prove::State::Result - Individual test suite results. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm index 216f514..1a8864c 100644 --- a/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm +++ b/cpan/Test-Harness/lib/App/Prove/State/Result/Test.pm @@ -9,11 +9,11 @@ App::Prove::State::Result::Test - Individual test results. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Base.pm b/cpan/Test-Harness/lib/TAP/Base.pm index 5f60500..5867ee7 100644 --- a/cpan/Test-Harness/lib/TAP/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Base.pm @@ -12,11 +12,11 @@ and L =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; use constant GOT_TIME_HIRES => do { eval 'use Time::HiRes qw(time);'; diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm index 477794c..440af92 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Base.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Base.pm @@ -58,11 +58,11 @@ TAP::Formatter::Base - Base class for harness output delegates =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm index 69e555a..4d97bfa 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Color.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Color.pm @@ -71,11 +71,11 @@ TAP::Formatter::Color - Run Perl test scripts with color =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm index 390b2bf..9360cea 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console.pm @@ -11,11 +11,11 @@ TAP::Formatter::Console - Harness output delegate for default console output =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm index 8d486c6..fd8c021 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/ParallelSession.pm @@ -41,11 +41,11 @@ TAP::Formatter::Console::ParallelSession - Harness output delegate for parallel =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm index a075bfa..8262d9b 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Console/Session.pm @@ -26,11 +26,11 @@ TAP::Formatter::Console::Session - Harness output delegate for default console o =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File.pm b/cpan/Test-Harness/lib/TAP/Formatter/File.pm index b8751ee..baff4c1 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File.pm @@ -13,11 +13,11 @@ TAP::Formatter::File - Harness output delegate for file output =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION @@ -30,7 +30,7 @@ This provides file orientated output formatting for TAP::Harness. =head2 C<< open_test >> -See L +See L =cut diff --git a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm index b17a294..456f92a 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/File/Session.pm @@ -10,11 +10,11 @@ TAP::Formatter::File::Session - Harness output delegate for file output =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm index 531185d..fca74d6 100644 --- a/cpan/Test-Harness/lib/TAP/Formatter/Session.pm +++ b/cpan/Test-Harness/lib/TAP/Formatter/Session.pm @@ -23,11 +23,11 @@ TAP::Formatter::Session - Abstract base class for harness output delegate =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 METHODS diff --git a/cpan/Test-Harness/lib/TAP/Harness.pm b/cpan/Test-Harness/lib/TAP/Harness.pm index bf67563..70849dd 100644 --- a/cpan/Test-Harness/lib/TAP/Harness.pm +++ b/cpan/Test-Harness/lib/TAP/Harness.pm @@ -16,11 +16,11 @@ TAP::Harness - Run test scripts with statistics =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; $ENV{HARNESS_ACTIVE} = 1; $ENV{HARNESS_VERSION} = $VERSION; diff --git a/cpan/Test-Harness/lib/TAP/Harness/Env.pm b/cpan/Test-Harness/lib/TAP/Harness/Env.pm index c21139c..c169528 100644 --- a/cpan/Test-Harness/lib/TAP/Harness/Env.pm +++ b/cpan/Test-Harness/lib/TAP/Harness/Env.pm @@ -7,7 +7,7 @@ use constant IS_VMS => ( $^O eq 'VMS' ); use TAP::Object; use Text::ParseWords qw/shellwords/; -our $VERSION = '3.32'; +our $VERSION = '3.33'; # Get the parts of @INC which are changed from the stock list AND # preserve reordering of stock directories. @@ -126,24 +126,40 @@ TAP::Harness::Env - Parsing harness related environmental variables where approp =head1 VERSION -Version 3.32 +Version 3.33 =head1 SYNOPSIS - my ($class, $args) = get_test_arguments(); - require_module($class); - $class->new($args); + my $harness = TAP::Harness::Env->create(\%extra_args) =head1 DESCRIPTION -This module implements the environmental variables that L for use with TAP::Harness. +This module implements the environmental variables that L for use with TAP::Harness, and instantiates it with the appropriate arguments. -=head1 FUNCTIONS +=over 4 + +=item * HARNESS_PERL_SWITCHES + +=item * HARNESS_VERBOSE + +=item * HARNESS_SUBCLASS + +=item * HARNESS_OPTIONS + +=item * HARNESS_TIMER + +=item * HARNESS_COLOR + +=item * HARNESS_IGNORE_EXIT + +=back + +=head1 METHODS =over 4 -=item * get_test_options( \%args ) +=item * create( \%args ) -This function reads the environment and generates an appropriate argument hash from it. If given any arguments, there will override the environmental defaults. It will return of C<$class> and C<$args>. +This function reads the environment and generates an appropriate argument hash from it. If given any arguments in C<%extra_args>, these will override the environmental defaults. In accepts C (which defaults to C), and any argument the harness class accepts. =back diff --git a/cpan/Test-Harness/lib/TAP/Object.pm b/cpan/Test-Harness/lib/TAP/Object.pm index dc4a721..a1a2164 100644 --- a/cpan/Test-Harness/lib/TAP/Object.pm +++ b/cpan/Test-Harness/lib/TAP/Object.pm @@ -9,11 +9,11 @@ TAP::Object - Base class that provides common functionality to all C mod =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser.pm b/cpan/Test-Harness/lib/TAP/Parser.pm index 8ff4825..32b1f4e 100644 --- a/cpan/Test-Harness/lib/TAP/Parser.pm +++ b/cpan/Test-Harness/lib/TAP/Parser.pm @@ -27,11 +27,11 @@ TAP::Parser - Parse L output =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; my $DEFAULT_TAP_VERSION = 12; my $MAX_TAP_VERSION = 13; diff --git a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm index eac9734..d02c3e8 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Aggregator.pm @@ -12,11 +12,11 @@ TAP::Parser::Aggregator - Aggregate TAP::Parser results =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm index 83ba5a2..5ee121b 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Grammar.pm @@ -14,11 +14,11 @@ TAP::Parser::Grammar - A grammar for the Test Anything Protocol. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm index e1f2f79..a949b52 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator - Base class for TAP source iterators =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm index 0c7252b..ce71f05 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Array.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator::Array - Iterator for array-based TAP sources =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm index a0b9d38..8580498 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Process.pm @@ -16,11 +16,11 @@ TAP::Parser::Iterator::Process - Iterator for process-based TAP sources =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm index 1b6125d..5ee9fbf 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Iterator/Stream.pm @@ -11,11 +11,11 @@ TAP::Parser::Iterator::Stream - Iterator for filehandle-based TAP sources =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm index 4410284..6216528 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/IteratorFactory.pm @@ -16,11 +16,11 @@ TAP::Parser::IteratorFactory - Figures out which SourceHandler objects to use fo =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm index df4dc43..4173cdc 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Multiplexer.pm @@ -17,11 +17,11 @@ TAP::Parser::Multiplexer - Multiplex multiple TAP::Parsers =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result.pm b/cpan/Test-Harness/lib/TAP/Parser/Result.pm index df6bce5..48ba5dc 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result.pm @@ -24,11 +24,11 @@ TAP::Parser::Result - Base class for TAP::Parser output objects =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm index 75df122..0d213e6 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Bailout.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Bailout - Bailout result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm index 1dea7d2..fc1f889 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Comment.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Comment - Comment result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm index 7d526cc..b52f9da 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Plan.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Plan - Plan result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm index 941210a..dd4818d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Pragma.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Pragma - TAP pragma token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm index 9a76bc5..0f34577 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Test.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Test - Test result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm index ff36bc1..c5b86a8 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Unknown.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Unknown - Unknown result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm index 1420db9..733021d 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/Version.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::Version - TAP syntax version token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm index 792d1ef..f592f68 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Result/YAML.pm @@ -11,11 +11,11 @@ TAP::Parser::Result::YAML - YAML result token. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm index dd68cce..14ba708 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/ResultFactory.pm @@ -29,11 +29,11 @@ TAP::Parser::ResultFactory - Factory for creating TAP::Parser output objects =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head2 DESCRIPTION diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm index f7823b8..1e9b07f 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler.pm @@ -13,11 +13,11 @@ TAP::Parser::Scheduler - Schedule tests during parallel testing =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS @@ -100,7 +100,7 @@ Here are some examples: =head3 Rules resolution -=over4 +=over 4 =item * By default, all tests are eligible to be run in parallel. Specifying any of your own rules removes this one. diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm index 036d2a3..b95f486 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Job.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Job - A single testing job. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm index 11b9846..7cfeb65 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Scheduler/Spinner.pm @@ -10,11 +10,11 @@ TAP::Parser::Scheduler::Spinner - A no-op job. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/Source.pm b/cpan/Test-Harness/lib/TAP/Parser/Source.pm index bb0f0ae..4085d65 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/Source.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/Source.pm @@ -14,11 +14,11 @@ TAP::Parser::Source - a TAP source & meta data about it =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm index e17c1d6..b761de5 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler.pm @@ -12,11 +12,11 @@ TAP::Parser::SourceHandler - Base class for different TAP source handlers =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm index 63c8e60..d68bfd6 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Executable.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::Executable - Stream output from an executable TAP so =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm index eaa4781..d4d9300 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/File.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::File - Stream TAP from a text file. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm index 90719af..697ebf4 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Handle.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::Handle - Stream TAP from an IO::Handle or a GLOB. =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm index 9eef400..138500a 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/Perl.pm @@ -21,11 +21,11 @@ TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm index 32e480f..69cb88c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/SourceHandler/RawTAP.pm @@ -16,11 +16,11 @@ TAP::Parser::SourceHandler::RawTAP - Stream output from raw TAP in a scalar/arra =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm index 7b54062..3dfe62c 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Reader.pm @@ -5,7 +5,7 @@ use warnings; use base 'TAP::Object'; -our $VERSION = '3.32'; +our $VERSION = '3.33'; # TODO: # Handle blessed object syntax @@ -269,7 +269,7 @@ TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator =head1 VERSION -Version 3.32 +Version 3.33 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm index c883969..258a7cf 100644 --- a/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm +++ b/cpan/Test-Harness/lib/TAP/Parser/YAMLish/Writer.pm @@ -5,7 +5,7 @@ use warnings; use base 'TAP::Object'; -our $VERSION = '3.32'; +our $VERSION = '3.33'; my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; @@ -146,7 +146,7 @@ TAP::Parser::YAMLish::Writer - Write YAMLish data =head1 VERSION -Version 3.32 +Version 3.33 =head1 SYNOPSIS diff --git a/cpan/Test-Harness/lib/Test/Harness.pm b/cpan/Test-Harness/lib/Test/Harness.pm index 2f90aef..d080401 100644 --- a/cpan/Test-Harness/lib/Test/Harness.pm +++ b/cpan/Test-Harness/lib/Test/Harness.pm @@ -31,11 +31,11 @@ Test::Harness - Run Perl standard test scripts with statistics =head1 VERSION -Version 3.32 +Version 3.33 =cut -our $VERSION = '3.32'; +our $VERSION = '3.33'; # Backwards compatibility for exportable variable names. *verbose = *Verbose; diff --git a/cpan/Test-Simple/lib/Test/Builder.pm b/cpan/Test-Simple/lib/Test/Builder.pm index 00a3ec5..31933b3 100644 --- a/cpan/Test-Simple/lib/Test/Builder.pm +++ b/cpan/Test-Simple/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.001003'; +our $VERSION = '1.001006'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) BEGIN { @@ -89,7 +89,7 @@ Test::Builder - Backend for building test libraries =head1 DESCRIPTION -Test::Simple and Test::More have proven to be popular testing modules, +L and L have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides a building block upon which to write your own test libraries I. @@ -223,15 +223,18 @@ sub child { =item B - $builder->subtest($name, \&subtests); + $builder->subtest($name, \&subtests, @args); -See documentation of C in Test::More. +See documentation of C in Test::More. + +C also, and optionally, accepts arguments which will be passed to the +subtests reference. =cut sub subtest { my $self = shift; - my($name, $subtests) = @_; + my($name, $subtests, @args) = @_; if ('CODE' ne ref $subtests) { $self->croak("subtest()'s second argument must be a code ref"); @@ -255,7 +258,7 @@ sub subtest { my $run_the_subtests = sub { # Add subtest name for clarification of starting point $self->note("Subtest: $name"); - $subtests->(); + $subtests->(@args); $self->done_testing unless $self->_plan_handled; 1; }; @@ -321,7 +324,7 @@ sub _plan_handled { When your child is done running tests, you must call C to clean up and tell the parent your pass/fail status. -Calling finalize on a child with open children will C. +Calling C on a child with open children will C. If the child falls out of scope before C is called, a failure diagnostic will be issued and the child is considered to have failed. @@ -1062,14 +1065,14 @@ DIAGNOSTIC $Test->isnt_eq($got, $dont_expect, $name); -Like Test::More's C. Checks if C<$got ne $dont_expect>. This is +Like L's C. Checks if C<$got ne $dont_expect>. This is the string version. =item B $Test->isnt_num($got, $dont_expect, $name); -Like Test::More's C. Checks if C<$got ne $dont_expect>. This is +Like L's C. Checks if C<$got ne $dont_expect>. This is the numeric version. =cut @@ -1111,14 +1114,14 @@ sub isnt_num { $Test->like($thing, qr/$regex/, $name); $Test->like($thing, '/$regex/', $name); -Like Test::More's C. Checks if $thing matches the given C<$regex>. +Like L's C. Checks if $thing matches the given C<$regex>. =item B $Test->unlike($thing, qr/$regex/, $name); $Test->unlike($thing, '/$regex/', $name); -Like Test::More's C. Checks if $thing B the +Like L's C. Checks if $thing B the given C<$regex>. =cut @@ -1141,7 +1144,7 @@ sub unlike { $Test->cmp_ok($thing, $type, $that, $name); -Works just like Test::More's C. +Works just like L's C. $Test->cmp_ok($big_num, '!=', $other_big_num); @@ -1246,7 +1249,7 @@ These are methods which are used in the course of writing a test but are not the $Test->BAIL_OUT($reason); -Indicates to the Test::Harness that things are going so badly all +Indicates to the L that things are going so badly all testing should terminate. This includes running any additional test scripts. @@ -2201,7 +2204,7 @@ pretty good at guessing the right package to look at. It first looks for the caller based on C<$Level + 1>, since C is usually called inside a test function. As a last resort it will use C. -Sometimes there is some confusion about where todo() should be looking +Sometimes there is some confusion about where C should be looking for the C<$TODO> variable. If you want to be sure, tell it explicitly what $pack to use. @@ -2616,7 +2619,7 @@ Test::Builder. =head1 MEMORY -An informative hash, accessible via C<>, is stored for each +An informative hash, accessible via C, is stored for each test you perform. So memory usage will scale linearly with each test run. Although this is not a problem for most test suites, it can become an issue if you do large (hundred thousands to million) @@ -2624,19 +2627,19 @@ combinatorics tests in the same run. In such cases, you are advised to either split the test file into smaller ones, or use a reverse approach, doing "normal" (code) compares and -triggering fail() should anything go unexpected. +triggering C should anything go unexpected. Future versions of Test::Builder will have a way to turn history off. =head1 EXAMPLES -CPAN can provide the best examples. Test::Simple, Test::More, -Test::Exception and Test::Differences all use Test::Builder. +CPAN can provide the best examples. L, L, +L and L all use Test::Builder. =head1 SEE ALSO -Test::Simple, Test::More, Test::Harness +L, L, L =head1 AUTHORS diff --git a/cpan/Test-Simple/lib/Test/Builder/Module.pm b/cpan/Test-Simple/lib/Test/Builder/Module.pm index a11033e..50c2957 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -7,7 +7,7 @@ use Test::Builder 0.99; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.001003'; +our $VERSION = '1.001006'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -35,41 +35,41 @@ Test::Builder::Module - Base class for test modules =head1 DESCRIPTION -This is a superclass for Test::Builder-based modules. It provides a +This is a superclass for L-based modules. It provides a handful of common functionality and a method of getting at the underlying -Test::Builder object. +L object. =head2 Importing -Test::Builder::Module is a subclass of Exporter which means your +Test::Builder::Module is a subclass of L which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. -A few methods are provided to do the C 23> part +A few methods are provided to do the C<< use Your::Module tests => 23 >> part for you. =head3 import -Test::Builder::Module provides an import() method which acts in the -same basic way as Test::More's, setting the plan and controlling +Test::Builder::Module provides an C method which acts in the +same basic way as L's, setting the plan and controlling exporting of functions and variables. This allows your module to set -the plan independent of Test::More. +the plan independent of L. -All arguments passed to import() are passed onto +All arguments passed to C are passed onto C<< Your::Module->builder->plan() >> with the exception of C<< import =>[qw(things to import)] >>. use Your::Module import => [qw(this that)], tests => 23; -says to import the functions this() and that() as well as set the plan +says to import the functions C and C as well as set the plan to be 23 tests. -import() also sets the exported_to() attribute of your builder to be -the caller of the import() function. +C also sets the C attribute of your builder to be +the caller of the C function. -Additional behaviors can be added to your import() method by overriding -import_extra(). +Additional behaviors can be added to your C method by overriding +C. =cut @@ -123,13 +123,13 @@ sub _strip_imports { Your::Module->import_extra(\@import_args); -import_extra() is called by import(). It provides an opportunity for you +C is called by C. It provides an opportunity for you to add behaviors to your module based on its import list. -Any extra arguments which shouldn't be passed on to plan() should be +Any extra arguments which shouldn't be passed on to C should be stripped off by this method. -See Test::More for an example of its use. +See L for an example of its use. B This mechanism is I as it feels like a bit of an ugly hack in its current form. @@ -147,15 +147,15 @@ Test::Builder object. my $builder = Your::Class->builder; -This method returns the Test::Builder object associated with Your::Class. +This method returns the L object associated with Your::Class. It is not a constructor so you can call it as often as you like. -This is the preferred way to get the Test::Builder object. You should +This is the preferred way to get the L object. You should I get it via C<< Test::Builder->new >> as was previously recommended. -The object returned by builder() may change at runtime so you should -call builder() inside each function rather than store it in a global. +The object returned by C may change at runtime so you should +call C inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 5128be9..5dd8436 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = "1.23_003"; +our $VERSION = "1.24"; use Test::Builder 0.98; use Symbol; @@ -25,20 +25,20 @@ Test::Builder =head1 DESCRIPTION A module that helps you test testing modules that are built with -B. +L. The testing system is designed to be used by performing a three step process for each test you wish to test. This process starts with using C and C in advance to declare what the testsuite you -are testing will output with B to stdout and stderr. +are testing will output with L to stdout and stderr. You then can run the test(s) from your test suite that call -B. At this point the output of B is -safely captured by B rather than being +L. At this point the output of L is +safely captured by L rather than being interpreted as real test output. The final stage is to call C that will simply compare what you -predeclared to what B actually outputted, and report the +predeclared to what L actually outputted, and report the results back with a "ok" or "not ok" (with debugging) to the normal output. @@ -165,8 +165,8 @@ which is even the same as test_out("ok 2"); Once C or C (or C or C) have -been called, all further output from B will be -captured by B. This means that you will not +been called, all further output from L will be +captured by L. This means that you will not be able perform further tests to the normal output in the normal way until you call C (well, unless you manually meddle with the output filehandles) @@ -189,7 +189,7 @@ sub test_err { =item test_fail -Because the standard failure message that B produces +Because the standard failure message that L produces whenever a test fails will be a common occurrence in your test error output, and because it has changed between Test::Builder versions, rather than forcing you to call C with the string all the time like @@ -228,7 +228,7 @@ sub test_fail { =item test_diag As most of the remaining expected output to the error stream will be -created by Test::Builder's C function, B +created by L's C function, L provides a convenience function C that you can use instead of C. @@ -242,7 +242,7 @@ you can write test_diag("Couldn't open file"); -Remember that B's diag function will not add newlines to +Remember that L's diag function will not add newlines to the end of output and test_diag will. So to check Test::Builder->new->diag("foo\n","bar\n"); @@ -267,7 +267,7 @@ sub test_diag { =item test_test Actually performs the output check testing the tests, comparing the -data (with C) that we have captured from B against +data (with C) that we have captured from L against what was declared with C and C. This takes name/value pairs that effect how the test is run. @@ -297,9 +297,9 @@ As a convenience, if only one argument is passed then this argument is assumed to be the name of the test (as in the above examples.) Once C has been run test output will be redirected back to -the original filehandles that B was connected to +the original filehandles that L was connected to (probably STDOUT and STDERR,) meaning any further tests you run -will function normally and cause success/errors for B. +will function normally and cause success/errors for L. =cut @@ -400,11 +400,11 @@ respectively, and the function called with no argument will return the current setting. To enable colouring from the command line, you can use the -B module like so: +L module like so: perl -Mlib=Text::Builder::Tester::Color test.t -Or by including the B module directly in +Or by including the L module directly in the PERL5LIB. =cut @@ -420,12 +420,12 @@ sub color { =head1 BUGS -Calls C<no_ending>> turning off the ending tests. +Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. -The color function doesn't work unless B is +The color function doesn't work unless L is compatible with your terminal. Bugs (and requests for new features) can be reported to the author @@ -436,7 +436,7 @@ L Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. -Some code taken from B and B, written by +Some code taken from L and L, written by Michael G Schwern Eschwern@pobox.comE. Hence, those parts Copyright Micheal G Schwern 2001. Used and distributed with permission. diff --git a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index b269a27..4cb3b15 100644 --- a/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = "1.23_002"; +our $VERSION = "1.24"; require Test::Builder::Tester; diff --git a/cpan/Test-Simple/lib/Test/More.pm b/cpan/Test-Simple/lib/Test/More.pm index 217ad59..ca178bb 100644 --- a/cpan/Test-Simple/lib/Test/More.pm +++ b/cpan/Test-Simple/lib/Test/More.pm @@ -9,7 +9,7 @@ use warnings; # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) -# Can't use Carp because it might cause use_ok() to accidentally succeed +# Can't use Carp because it might cause C to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { @@ -17,7 +17,7 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.001003'; +our $VERSION = '1.001006'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module 0.99; @@ -144,7 +144,7 @@ but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; -Alternatively, you can use the plan() function. Useful for when you +Alternatively, you can use the C function. Useful for when you have to calculate the number of tests. use Test::More; @@ -204,7 +204,7 @@ sub import_extra { If you don't know how many tests you're going to run, you can issue the plan when you're done running tests. -$number_of_tests is the same as plan(), it's the number of tests you +$number_of_tests is the same as C, it's the number of tests you expected to run. You can omit this, in which case the number of tests you ran doesn't matter, just the fact that your tests ran to conclusion. @@ -277,13 +277,13 @@ out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. -Should an ok() fail, it will produce some diagnostics: +Should an C fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 'sufficient mucus' # in foo.t at line 42. -This is the same as Test::Simple's ok() routine. +This is the same as L's C routine. =cut @@ -301,7 +301,7 @@ sub ok ($;$) { is ( $got, $expected, $test_name ); isnt( $got, $expected, $test_name ); -Similar to ok(), is() and isnt() compare their two arguments +Similar to C, C and C compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: @@ -323,9 +323,9 @@ against C like this: (Mnemonic: "This is that." "This isn't that.") -So why use these? They produce better diagnostics on failure. ok() -cannot know what you are testing for (beyond the name), but is() and -isnt() know what the test was and why it failed. For example this +So why use these? They produce better diagnostics on failure. C +cannot know what you are testing for (beyond the name), but C and +C know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; @@ -341,7 +341,7 @@ Will produce something like this: So you can figure out what went wrong without rerunning the test. -You are encouraged to use is() and isnt() over ok() where possible, +You are encouraged to use C and C over C where possible, however do not be tempted to use them to find out if something is true or false! @@ -350,11 +350,11 @@ true or false! This does not check if C is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. -In these cases, use ok(). +In these cases, use C. ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); -A simple call to isnt() usually does not provide a strong test but there +A simple call to C usually does not provide a strong test but there are cases when you cannot say much more about a value than that it is different from some other value: @@ -366,7 +366,7 @@ different from some other value: isnt $obj, $clone, "clone() produces a different object"; For those grammatical pedants out there, there's an C -function which is an alias of isnt(). +function which is an alias of C. =cut @@ -383,12 +383,13 @@ sub isnt ($$;$) { } *isn't = \&isnt; +# ' to unconfuse syntax higlighters =item B like( $got, qr/expected/, $test_name ); -Similar to ok(), like() matches $got against the regex C. +Similar to C, C matches $got against the regex C. So this: @@ -409,7 +410,7 @@ currently not supported): Regex options may be placed on the end (C<'/expected/i'>). -Its advantages over ok() are similar to that of is() and isnt(). Better +Its advantages over C are similar to that of C and C. Better diagnostics on failure. =cut @@ -424,7 +425,7 @@ sub like ($$;$) { unlike( $got, qr/expected/, $test_name ); -Works exactly as like(), only it checks if $got B match the +Works exactly as C, only it checks if $got B match the given pattern. =cut @@ -453,7 +454,7 @@ passes if the comparison is true and fails otherwise. cmp_ok( $got, '&&', $expected, 'this && that' ); ...etc... -Its advantage over ok() is when the test fails you'll know what $got +Its advantage over C is when the test fails you'll know what $got and $expected were: not ok 1 @@ -463,7 +464,7 @@ and $expected were: # undef It's also useful in those cases where you are comparing numbers and -is()'s use of C will interfere: +C's use of C will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); @@ -501,7 +502,7 @@ is almost exactly like saying: only without all the typing and with a better interface. Handy for quickly testing an interface. -No matter how many @methods you check, a single can_ok() call counts +No matter how many @methods you check, a single C call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { @@ -663,7 +664,7 @@ WHOA my $obj = new_ok( $class => \@args, $object_name ); A convenience function which combines creating an object and calling -isa_ok() on that object. +C on that object. It is basically equivalent to: @@ -672,7 +673,7 @@ It is basically equivalent to: If @args is not given, an empty list will be used. -This function only works on new() and it assumes new() will return +This function only works on C and it assumes C will return just a single object which isa C<$class>. =cut @@ -704,7 +705,7 @@ sub new_ok { subtest $name => \&code; -subtest() runs the &code as its own little test with its own plan and +C runs the &code as its own little test with its own plan and its own result. The main test counts this as a single test using the result of the whole subtest to determine if its ok or not ok. @@ -734,7 +735,7 @@ This would produce. ok 2 - An example subtest ok 3 - Third test -A subtest may call "skip_all". No tests will be run, but the subtest is +A subtest may call C. No tests will be run, but the subtest is considered a skip. subtest 'skippy' => sub { @@ -779,9 +780,9 @@ sub subtest { Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to -wedge into an ok(). In this case, you can simply use pass() (to +wedge into an C. In this case, you can simply use C (to declare the test ok) or fail (for not ok). They are synonyms for -ok(1) and ok(0). +C and C. Use these very, very, very sparingly. @@ -896,7 +897,7 @@ If you just want to test a module can be loaded, use C. If you just want to load a module in a test, we recommend simply using C directly. It will cause the test to stop. -It's recommended that you run use_ok() inside a BEGIN block so its +It's recommended that you run C inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. @@ -1017,16 +1018,16 @@ B I'm not quite sure what will happen with filehandles. is_deeply( $got, $expected, $test_name ); -Similar to is(), except that if $got and $expected are references, it +Similar to C, except that if $got and $expected are references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. -is_deeply() compares the dereferenced values of references, the +C compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". -is_deeply() currently has very limited handling of function reference +C currently has very limited handling of function reference and globs. It merely checks if they have the same referent. This may improve in the future. @@ -1185,7 +1186,7 @@ interfere with the test. note(@diagnostic_message); -Like diag(), except the message will not be seen when the test is run +Like C, except the message will not be seen when the test is run in a harness. It will only be visible in the verbose TAP stream. Handy for putting in notes which might be useful for debugging, but @@ -1232,7 +1233,7 @@ sub explain { Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented -(such as fork() on MacOS), some resource isn't available (like a +(such as C on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). @@ -1337,7 +1338,7 @@ because you haven't fixed a bug or haven't finished a new feature: With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating -they are "todo". Test::Harness will interpret failures as being ok. +they are "todo". L will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. @@ -1366,7 +1367,7 @@ inside an C with and using C. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C except the -tests will be marked as failing but todo. Test::Harness will +tests will be marked as failing but todo. L will interpret them as passing. =cut @@ -1394,7 +1395,7 @@ sub todo_skip { B, use SKIP. This includes optional modules that aren't installed, running under -an OS that doesn't have some feature (like fork() or symlinks), or maybe +an OS that doesn't have some feature (like C or symlinks), or maybe you need an Internet connection and one isn't available. B, use TODO. This @@ -1440,11 +1441,11 @@ sub BAIL_OUT { The use of the following functions is discouraged as they are not actually testing functions and produce no diagnostics to help figure -out what went wrong. They were written before is_deeply() existed +out what went wrong. They were written before C existed because I couldn't figure out how to display a useful diff of two arbitrary data structures. -These functions are usually used inside an ok(). +These functions are usually used inside an C. ok( eq_array(\@got, \@expected) ); @@ -1649,7 +1650,7 @@ sub _eq_hash { my $is_eq = eq_set(\@got, \@expected); -Similar to eq_array(), except the order of the elements is B +Similar to C, except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. @@ -1662,7 +1663,7 @@ Is better written: B By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. -B eq_set() does not know how to deal with references at the top +B C does not know how to deal with references at the top level. The following is an example of a comparison which might not work: eq_set([\1, \2], [\2, \1]); @@ -1700,13 +1701,13 @@ sub eq_set { =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, -Test::More is built on top of Test::Builder which provides a single, +Test::More is built on top of L which provides a single, unified backend for any test library to use. This means two test -libraries which both use Test::Builder B B be used together in the same program>. If you simply want to do a little tweaking of how the tests behave, -you can access the underlying Test::Builder object like so: +you can access the underlying L object like so: =over 4 @@ -1714,7 +1715,7 @@ you can access the underlying Test::Builder object like so: my $test_builder = Test::More->builder; -Returns the Test::Builder object underlying Test::More for you to play +Returns the L object underlying Test::More for you to play with. @@ -1723,10 +1724,10 @@ with. =head1 EXIT CODES -If all your tests passed, Test::Builder will exit with zero (which is +If all your tests passed, L will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Builder +will be considered failures. If no tests were ever run L will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. @@ -1785,8 +1786,9 @@ There is a full version history in the Changes file, and the Test::More versions =item utf8 / "Wide character in print" If you use utf8 or other non-ASCII characters with Test::More you -might get a "Wide character in print" warning. Using C will not fix it. Test::Builder (which powers +might get a "Wide character in print" warning. Using +C<< binmode STDOUT, ":utf8" >> will not fix it. +L (which powers Test::More) duplicates STDOUT and STDERR. So any changes to them, including changing their output disciplines, will not be seem by Test::More. @@ -1798,7 +1800,7 @@ as possible and before Test::More (or any other Test module) loads. use Test::More; A more direct work around is to change the filehandles used by -Test::Builder. +L. my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; @@ -1808,14 +1810,14 @@ Test::Builder. =item Overloaded objects -String overloaded objects are compared B (or in cmp_ok()'s +String overloaded objects are compared B (or in C's case, strings or numbers as appropriate to the comparison op). This prevents Test::More from piercing an object's interface allowing better blackbox testing. So if a function starts returning overloaded objects instead of bare strings your tests won't notice the difference. This is good. -However, it does mean that functions like is_deeply() cannot be used to +However, it does mean that functions like C cannot be used to test the internals of string overloaded objects. In this case I would suggest L which contains more flexible testing functions for complex data structures. @@ -1823,7 +1825,7 @@ complex data structures. =item Threads -Test::More will only be aware of threads if "use threads" has been done +Test::More will only be aware of threads if C has been done I Test::More is loaded. This is ok: use threads; @@ -1841,9 +1843,9 @@ This may cause problems: =head1 HISTORY -This is a case of convergent evolution with Joshua Pritikin's Test +This is a case of convergent evolution with Joshua Pritikin's L module. I was largely unaware of its existence when I'd first -written my own ok() routines. This module exists because I can't +written my own C routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). @@ -1856,18 +1858,29 @@ magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO +=head2 + +=head2 ALTERNATIVES + L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). -L is the test runner and output interpreter for Perl. -It's the thing that powers C and where the C utility -comes from. - L tests written with Test.pm, the original testing module, do not play well with other testing libraries. Test::Legacy emulates the Test.pm interface and does play well with others. +=head2 TESTING FRAMEWORKS + +L The Fennec framework is a testers toolbox. It uses L +under the hood. It brings enhancements for forking, defining state, and +mocking. Fennec enhances several modules to work better together than they +would if you loaded them individually on your own. + +L Provides enhanced (L) syntax for Fennec. + +=head2 ADDITIONAL LIBRARIES + L for more ways to test complex data structures. And it plays well with Test::More. @@ -1877,8 +1890,22 @@ L gives you more powerful complex data structure testing. L shows the idea of embedded testing. +L The ultimate mocking library. Easily spawn objects defined on +the fly. Can also override, block, or reimplement packages as needed. + +L Quickly define fixture data for unit tests. + +=head2 OTHER COMPONENTS + +L is the test runner and output interpreter for Perl. +It's the thing that powers C and where the C utility +comes from. + +=head2 BUNDLES + L installs a whole bunch of useful test modules. +L Most commonly needed test functions and features. =head1 AUTHORS diff --git a/cpan/Test-Simple/lib/Test/Simple.pm b/cpan/Test-Simple/lib/Test/Simple.pm index 8d123b4..68110d5 100644 --- a/cpan/Test-Simple/lib/Test/Simple.pm +++ b/cpan/Test-Simple/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.006; use strict; -our $VERSION = '1.001003'; +our $VERSION = '1.001006'; $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) use Test::Builder::Module 0.99; @@ -26,7 +26,7 @@ Test::Simple - Basic utilities for writing tests. =head1 DESCRIPTION -** If you are unfamiliar with testing B first! ** +** If you are unfamiliar with testing B first!> ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more @@ -35,7 +35,7 @@ for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass -or fail. You do this with the ok() function (see below). +or fail. You do this with the C function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the @@ -54,10 +54,10 @@ You must have a plan. ok( $foo eq $bar, $name ); ok( $foo eq $bar ); -ok() is given an expression (in this case C<$foo eq $bar>). If it's +C is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. -ok() prints out either "ok" or "not ok" along with a test number (it +C prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) @@ -84,7 +84,7 @@ sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange -format lets Test::Harness know how many tests you plan on running in +format lets L know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is @@ -185,13 +185,13 @@ he wasn't in Tony's kitchen). This is it. =item L More testing functions! Once you outgrow Test::Simple, look at -Test::More. Test::Simple is 100% forward compatible with Test::More -(i.e. you can just use Test::More instead of Test::Simple in your +L. Test::Simple is 100% forward compatible with L +(i.e. you can just use L instead of Test::Simple in your programs and things will still work). =back -Look in Test::More's SEE ALSO for more testing modules. +Look in L's SEE ALSO for more testing modules. =head1 AUTHORS diff --git a/cpan/Test-Simple/lib/Test/Tutorial.pod b/cpan/Test-Simple/lib/Test/Tutorial.pod index 8badf38..a71a9c1 100644 --- a/cpan/Test-Simple/lib/Test/Tutorial.pod +++ b/cpan/Test-Simple/lib/Test/Tutorial.pod @@ -90,7 +90,7 @@ along. [2] This is the hardest part of testing, where do you start? People often get overwhelmed at the apparent enormity of the task of testing a whole module. -The best place to start is at the beginning. C is an +The best place to start is at the beginning. L is an object-oriented module, and that means you start by making an object. Test C. @@ -176,18 +176,18 @@ Run that and you get: ok 8 - year() # Looks like you failed 1 tests of 8. -Whoops, a failure! [4] C helpfully lets us know on what line the +Whoops, a failure! [4] L helpfully lets us know on what line the failure occurred, but not much else. We were supposed to get 17, but we didn't. What did we get?? Dunno. You could re-run the test in the debugger or throw in some print statements to find out. -Instead, switch from L to L. C -does everything C does, and more! In fact, C does -things I the way C does. You can literally swap -C out and put C in its place. That's just what +Instead, switch from L to L. L +does everything L does, and more! In fact, L does +things I the way L does. You can literally swap +L out and put L in its place. That's just what we're going to do. -C does more than C. The most important difference at +L does more than L. The most important difference at this point is it provides more informative ways to say "ok". Although you can write almost any test with a generic C, it can't tell you what went wrong. The C function lets us declare that something is supposed to be @@ -210,7 +210,7 @@ the same as something else: is( $ical->month, 10, ' month()' ); is( $ical->year, 1964, ' year()' ); -"Is C<$ical-Esec> 47?" "Is C<$ical-Emin> 12?" With C in place, +"Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C in place, you get more information: 1..8 @@ -227,7 +227,7 @@ you get more information: ok 8 - year() # Looks like you failed 1 tests of 8. -Aha. C<$ical-Eday> returned 16, but we expected 17. A +Aha. C<< $ical->day >> returned 16, but we expected 17. A quick check shows that the code is working fine, we made a mistake when writing the tests. Change it to: @@ -297,7 +297,7 @@ Now we can test bunches of dates by just adding them to C<%ICal_Dates>. Now that it's less work to test with more dates, you'll be inclined to just throw more in as you think of them. Only problem is, every time we add to that we have to keep adjusting -the C ##> line. That can rapidly get +the L<< use Test::More tests => ## >> line. That can rapidly get annoying. There are ways to make this work better. First, we can calculate the plan dynamically using the C @@ -324,10 +324,10 @@ running some tests, don't know how many. [6] done_testing(); # reached the end safely -If you don't specify a plan, C expects to see C +If you don't specify a plan, L expects to see C before your program exits. It will warn you if you forget it. You can give C an optional number of tests you expected to run, and if the -number ran differs, C will give you another kind of warning. +number ran differs, L will give you another kind of warning. =head2 Informative names @@ -417,7 +417,7 @@ the test. A little bit of magic happens here. When running on anything but MacOS, all the tests run normally. But when on MacOS, C causes the entire contents of the SKIP block to be jumped over. It never runs. Instead, -C prints special output that tells C that the tests have +C prints special output that tells L that the tests have been skipped. 1..7 @@ -446,7 +446,7 @@ The tests are wholly and completely skipped. [10] This will work. =head2 Todo tests -While thumbing through the C man page, I came across this: +While thumbing through the L man page, I came across this: ical @@ -497,12 +497,12 @@ Now when you run, it's a little different: # got: '20010822T201551Z' # expected: '20201231Z' -C doesn't say "Looks like you failed 1 tests of 1". That '# -TODO' tells C "this is supposed to fail" and it treats a +L doesn't say "Looks like you failed 1 tests of 1". That '# +TODO' tells L "this is supposed to fail" and it treats a failure as a successful test. You can write tests even before you've fixed the underlying code. -If a TODO test passes, C will report it "UNEXPECTEDLY +If a TODO test passes, L will report it "UNEXPECTEDLY SUCCEEDED". When that happens, remove the TODO block with C and turn it into a real test. @@ -517,7 +517,7 @@ in mind, it's very important to ensure your module works under taint mode. It's very simple to have your tests run under taint mode. Just throw -a C<-T> into the C<#!> line. C will read the switches +a C<-T> into the C<#!> line. L will read the switches in C<#!> and use them to run your tests. #!/usr/bin/perl -Tw @@ -558,7 +558,7 @@ We'll get to testing the contents of lists later. But what happens if your test program dies halfway through?! Since we didn't say how many tests we're going to run, how can we know it -failed? No problem, C employs some magic to catch that death +failed? No problem, L employs some magic to catch that death and turn the test into a failure, even if every test passed up to that point. diff --git a/cpan/Test-Simple/t/dont_overwrite_die_handler.t b/cpan/Test-Simple/t/dont_overwrite_die_handler.t index 0657a06..cf9f907 100644 --- a/cpan/Test-Simple/t/dont_overwrite_die_handler.t +++ b/cpan/Test-Simple/t/dont_overwrite_die_handler.t @@ -1,4 +1,5 @@ #!/usr/bin/perl -w +use Config; # To prevent conflict with some strawberry-portable versions BEGIN { if( $ENV{PERL_CORE} ) { diff --git a/cpan/Test-Simple/t/subtest/args.t b/cpan/Test-Simple/t/subtest/args.t index 5271323..8ae26ba 100644 --- a/cpan/Test-Simple/t/subtest/args.t +++ b/cpan/Test-Simple/t/subtest/args.t @@ -3,6 +3,17 @@ use strict; use Test::Builder; +BEGIN { + if( $ENV{PERL_CORE} ) { + chdir 't'; + @INC = ( '../lib', 'lib' ); + } + else { + unshift @INC, 't/lib'; + } +} +use Test::Builder::NoOutput; + my $tb = Test::Builder->new; $tb->ok( !eval { $tb->subtest() } ); @@ -11,4 +22,12 @@ $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); $tb->ok( !eval { $tb->subtest("foo") } ); $tb->like( $@, qr/^\Qsubtest()'s second argument must be a code ref/ ); +$tb->subtest('Arg passing', sub { + my $foo = shift; + my $child = Test::Builder->new; + $child->is_eq($foo, 'foo'); + $child->done_testing; + $child->finalize; +}, 'foo'); + $tb->done_testing(); diff --git a/cpan/Time-HiRes/t/itimer.t b/cpan/Time-HiRes/t/itimer.t index 24374cd..a9ef80d 100644 --- a/cpan/Time-HiRes/t/itimer.t +++ b/cpan/Time-HiRes/t/itimer.t @@ -43,8 +43,7 @@ note "setitimer: ", join(" ", # Assume interval timer granularity of $limit * 0.5 seconds. Too bold? my $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); -ok defined $virt && abs($virt / 0.5) - 1 < $limit - or diag "virt=" . (defined $virt ? $virt : 'undef'); +ok defined $virt && abs($virt / 0.5) - 1 < $limit; note "getitimer: ", join(" ", Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); @@ -58,8 +57,7 @@ note "getitimer: ", join(" ", Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL)); $virt = Time::HiRes::getitimer(&Time::HiRes::ITIMER_VIRTUAL); -note "at end, i=$i"; -is($virt, 0, "time left should be zero"); +ok defined $virt && $virt == 0; $SIG{VTALRM} = 'DEFAULT'; diff --git a/cpan/Time-Piece/Piece.pm b/cpan/Time-Piece/Piece.pm index f913db9..aaf63ee 100644 --- a/cpan/Time-Piece/Piece.pm +++ b/cpan/Time-Piece/Piece.pm @@ -19,7 +19,7 @@ our %EXPORT_TAGS = ( ':override' => 'internal', ); -our $VERSION = '1.27'; +our $VERSION = '1.29'; bootstrap Time::Piece $VERSION; diff --git a/cpan/Time-Piece/Seconds.pm b/cpan/Time-Piece/Seconds.pm index b001f20..8e5b52b 100644 --- a/cpan/Time-Piece/Seconds.pm +++ b/cpan/Time-Piece/Seconds.pm @@ -2,7 +2,7 @@ package Time::Seconds; use strict; use vars qw/@EXPORT @EXPORT_OK/; -our $VERSION = '1.27'; +our $VERSION = '1.29'; use Exporter 5.57 'import'; @@ -160,7 +160,7 @@ sub pretty { if ($s >= ONE_HOUR) { if ($s >= ONE_DAY) { my $days = sprintf("%d", $s->days); # does a "floor" - $str = $days . " days, "; + $str .= $days . " days, "; $s -= ($days * ONE_DAY); } my $hours = sprintf("%d", $s->hours); diff --git a/cpan/Time-Piece/t/02core.t b/cpan/Time-Piece/t/02core.t index 3840e87..18dae7d 100644 --- a/cpan/Time-Piece/t/02core.t +++ b/cpan/Time-Piece/t/02core.t @@ -1,10 +1,11 @@ -use Test::More tests => 96; +use Test::More tests => 95; my $is_win32 = ($^O =~ /Win32/); my $is_qnx = ($^O eq 'qnx'); my $is_vos = ($^O eq 'vos'); -BEGIN { use_ok('Time::Piece'); } -ok(1); + +use Time::Piece; +use Time::Seconds; my $t = gmtime(951827696); # 2000-02-29T12:34:56 @@ -227,3 +228,5 @@ cmp_ok( 951827696 ); +my $s = Time::Seconds->new(-691050); +is($s->pretty, 'minus 7 days, 23 hours, 57 minutes, 30 seconds'); diff --git a/cpan/experimental/lib/experimental.pm b/cpan/experimental/lib/experimental.pm index 96f8a41..10a6a10 100644 --- a/cpan/experimental/lib/experimental.pm +++ b/cpan/experimental/lib/experimental.pm @@ -1,5 +1,5 @@ package experimental; -$experimental::VERSION = '0.008'; +$experimental::VERSION = '0.010'; use strict; use warnings; use version (); @@ -8,16 +8,35 @@ use feature (); use Carp qw/croak carp/; my %warnings = map { $_ => 1 } grep { /^experimental::/ } keys %warnings::Offsets; -my %features = map { $_ => 1 } keys %feature::feature; +my %features = map { $_ => 1 } $] > 5.015006 ? keys %feature::feature : do { + my @features; + if ($] >= 5.010) { + push @features, qw/switch say state/; + push @features, 'unicode_strings' if $] > 5.011002; + } + @features; +}; my %min_version = ( - array_base => version->new('5'), - autoderef => version->new('5.14.0'), - lexical_topic => version->new('5.10.0'), - regex_sets => version->new('5.18.0'), - smartmatch => version->new('5.10.1'), - signatures => version->new('5.20.0'), + array_base => '5', + autoderef => '5.14.0', + current_sub => '5.16.0', + evalbytes => '5.16.0', + fc => '5.16.0', + lexical_topic => '5.10.0', + lexical_subs => '5.18.0', + postderef => '5.20.0', + postderef_qq => '5.20.0', + regex_sets => '5.18.0', + say => '5.10.0', + smartmatch => '5.10.0', + signatures => '5.20.0', + state => '5.10.0', + switch => '5.10.0', + unicode_eval => '5.16.0', + unicode_strings => '5.12.0', ); +$_ = version->new($_) for values %min_version; my %additional = ( postderef => ['postderef_qq'], @@ -93,7 +112,7 @@ experimental - Experimental features made easy =head1 VERSION -version 0.008 +version 0.010 =head1 SYNOPSIS diff --git a/cpan/experimental/t/basic.t b/cpan/experimental/t/basic.t index bb1ed81..239225b 100644 --- a/cpan/experimental/t/basic.t +++ b/cpan/experimental/t/basic.t @@ -9,6 +9,7 @@ if ($] >= 5.010000) { use experimental 'lexical_topic'; my $_ = 1; is($_, 1, '$_ is 1'); + 1; END } else { @@ -16,10 +17,27 @@ else { } if ($] >= 5.010001) { + is (eval <<'END', 1, 'switch compiles') or diag $@; + use experimental 'switch'; + sub bar { 1 }; + given(1) { + when (\&bar) { + pass("bar matches 1"); + } + default { + fail("bar matches 1"); + } + } + 1; +END +} + +if ($] >= 5.010001) { is (eval <<'END', 1, 'smartmatch compiles') or diag $@; use experimental 'smartmatch'; sub bar { 1 }; is(1 ~~ \&bar, 1, "is 1"); + 1; END } diff --git a/cpan/version/lib/version.pm b/cpan/version/lib/version.pm index b337a90..f8afd84 100644 --- a/cpan/version/lib/version.pm +++ b/cpan/version/lib/version.pm @@ -6,7 +6,7 @@ use strict; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); -$VERSION = 0.9908; +$VERSION = 0.9909; $CLASS = 'version'; # avoid using Exporter diff --git a/cpan/version/lib/version/regex.pm b/cpan/version/lib/version/regex.pm index f92c78b..f732963 100644 --- a/cpan/version/lib/version/regex.pm +++ b/cpan/version/lib/version/regex.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION $CLASS $STRICT $LAX); -$VERSION = 0.9908; +$VERSION = 0.9909; #--------------------------------------------------------------------------# # Version regexp components diff --git a/cpan/version/lib/version/vpp.pm b/cpan/version/lib/version/vpp.pm index 3ac3f13..b821f92 100644 --- a/cpan/version/lib/version/vpp.pm +++ b/cpan/version/lib/version/vpp.pm @@ -122,7 +122,7 @@ use strict; use Config; use vars qw($VERSION $CLASS @ISA $LAX $STRICT); -$VERSION = 0.9908; +$VERSION = 0.9909; $CLASS = 'version::vpp'; require version::regex; diff --git a/cpan/version/t/00impl-pp.t b/cpan/version/t/00impl-pp.t index ba540c9..42b03c6 100644 --- a/cpan/version/t/00impl-pp.t +++ b/cpan/version/t/00impl-pp.t @@ -9,7 +9,7 @@ use Test::More qw/no_plan/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok('version::vpp', 0.9908); + use_ok('version::vpp', 0.9909); } BaseTests("version::vpp","new","qv"); diff --git a/cpan/version/t/01base.t b/cpan/version/t/01base.t index b452e3b..6174194 100644 --- a/cpan/version/t/01base.t +++ b/cpan/version/t/01base.t @@ -9,7 +9,7 @@ use Test::More qw/no_plan/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok('version', 0.9908); + use_ok('version', 0.9909); } BaseTests("version","new","qv"); diff --git a/cpan/version/t/02derived.t b/cpan/version/t/02derived.t index ee9e674..a5aa2e4 100644 --- a/cpan/version/t/02derived.t +++ b/cpan/version/t/02derived.t @@ -10,7 +10,7 @@ use File::Temp qw/tempfile/; BEGIN { (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm'; require $coretests; - use_ok("version", 0.9908); + use_ok("version", 0.9909); # If we made it this far, we are ok. } diff --git a/cpan/version/t/03require.t b/cpan/version/t/03require.t index c394728..f6100ef 100644 --- a/cpan/version/t/03require.t +++ b/cpan/version/t/03require.t @@ -14,7 +14,7 @@ BEGIN { # Don't want to use, because we need to make sure that the import doesn't # fire just yet (some code does this to avoid importing qv() and delare()). require_ok("version"); -is $version::VERSION, 0.9908, "Make sure we have the correct class"; +is $version::VERSION, 0.9909, "Make sure we have the correct class"; ok(!"main"->can("qv"), "We don't have the imported qv()"); ok(!"main"->can("declare"), "We don't have the imported declare()"); diff --git a/cpan/version/t/05sigdie.t b/cpan/version/t/05sigdie.t index 8b5b375..0b82313 100644 --- a/cpan/version/t/05sigdie.t +++ b/cpan/version/t/05sigdie.t @@ -14,7 +14,7 @@ BEGIN { } BEGIN { - use version 0.9908; + use version 0.9909; } pass "Didn't get caught by the wrong DIE handler, which is a good thing"; diff --git a/cpan/version/t/06noop.t b/cpan/version/t/06noop.t index 66baef4..ed24602 100644 --- a/cpan/version/t/06noop.t +++ b/cpan/version/t/06noop.t @@ -7,7 +7,7 @@ use Test::More qw/no_plan/; BEGIN { - use_ok('version', 0.9908); + use_ok('version', 0.9909); } my $v1 = version->new('1.2'); diff --git a/cpan/version/t/07locale.t b/cpan/version/t/07locale.t index d852aec..7af61b5 100644 --- a/cpan/version/t/07locale.t +++ b/cpan/version/t/07locale.t @@ -11,7 +11,7 @@ use Test::More tests => 7; use Config; BEGIN { - use_ok('version', 0.9908); + use_ok('version', 0.9909); } SKIP: { diff --git a/cpan/version/t/08_corelist.t b/cpan/version/t/08_corelist.t index 310c9cd..d7829c1 100644 --- a/cpan/version/t/08_corelist.t +++ b/cpan/version/t/08_corelist.t @@ -5,7 +5,7 @@ ######################### use Test::More tests => 3; -use_ok("version", 0.9908); +use_ok("version", 0.9909); # do strict lax tests in a sub to isolate a package to test importing SKIP: { diff --git a/cpan/version/t/09_list_util.t b/cpan/version/t/09_list_util.t index d0e3fa9..dbd387d 100644 --- a/cpan/version/t/09_list_util.t +++ b/cpan/version/t/09_list_util.t @@ -4,7 +4,7 @@ ######################### use strict; -use_ok("version", 0.9908); +use_ok("version", 0.9909); use Test::More; BEGIN { diff --git a/cv.h b/cv.h index 36afba7..8ba1c5c 100644 --- a/cv.h +++ b/cv.h @@ -49,8 +49,9 @@ See L. #define CvROOT(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_root #define CvXSUB(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_root_u.xcv_xsub #define CvXSUBANY(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_start_u.xcv_xsubany -#define CvGV(sv) S_CvGV((const CV *)(sv)) +#define CvGV(sv) S_CvGV(aTHX_ (CV *)(sv)) #define CvGV_set(cv,gv) Perl_cvgv_set(aTHX_ cv, gv) +#define CvHASGV(cv) cBOOL(SvANY(cv)->xcv_gv_u.xcv_gv) #define CvFILE(sv) ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_file #ifdef USE_ITHREADS # define CvFILE_set_from_cop(sv, cop) \ @@ -104,6 +105,7 @@ See L. #define CVf_AUTOLOAD 0x2000 /* SvPVX contains AUTOLOADed sub name */ #define CVf_HASEVAL 0x4000 /* contains string eval */ #define CVf_NAMED 0x8000 /* Has a name HEK */ +#define CVf_LEXICAL 0x10000 /* Omit package from name */ /* This symbol for optimised communication between toke.c and op.c: */ #define CVf_BUILTIN_ATTRS (CVf_METHOD|CVf_LVALUE) @@ -185,16 +187,13 @@ See L. #define CvNAMED_on(cv) (CvFLAGS(cv) |= CVf_NAMED) #define CvNAMED_off(cv) (CvFLAGS(cv) &= ~CVf_NAMED) +#define CvLEXICAL(cv) (CvFLAGS(cv) & CVf_LEXICAL) +#define CvLEXICAL_on(cv) (CvFLAGS(cv) |= CVf_LEXICAL) +#define CvLEXICAL_off(cv) (CvFLAGS(cv) &= ~CVf_LEXICAL) + /* Flags for newXS_flags */ #define XS_DYNAMIC_FILENAME 0x01 /* The filename isn't static */ -PERL_STATIC_INLINE GV * -S_CvGV(const CV *sv) -{ - return CvNAMED(sv) - ? 0 - : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; -} PERL_STATIC_INLINE HEK * CvNAME_HEK(CV *sv) { @@ -269,6 +268,12 @@ should print 123: typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *); +#define CALL_CHECKER_REQUIRE_GV MGf_REQUIRE_GV + +#ifdef PERL_CORE +# define CV_UNDEF_KEEP_NAME 1 +#endif + /* * Local variables: * c-indentation-style: bsd diff --git a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm index 4ae65d9..17c4bb7 100644 --- a/dist/Attribute-Handlers/lib/Attribute/Handlers.pm +++ b/dist/Attribute-Handlers/lib/Attribute/Handlers.pm @@ -4,7 +4,7 @@ use Carp; use warnings; use strict; use vars qw($VERSION $AUTOLOAD); -$VERSION = '0.96'; # remember to update version in POD! +$VERSION = '0.97'; # remember to update version in POD! # $DB::single=1; my %symcache; @@ -13,12 +13,16 @@ sub findsym { return $symcache{$pkg,$ref} if $symcache{$pkg,$ref}; $type ||= ref($ref); no strict 'refs'; - foreach my $sym ( values %{$pkg."::"} ) { + my $symtab = \%{$pkg."::"}; + for ( keys %$symtab ) { for my $sym ( $$symtab{$_} ) { + if (ref $sym && $sym == $ref) { + return $symcache{$pkg,$ref} = \*{"$pkg:\:$_"}; + } use strict; next unless ref ( \$sym ) eq 'GLOB'; return $symcache{$pkg,$ref} = \$sym if *{$sym}{$type} && *{$sym}{$type} == $ref; - } + }} } my %validtype = ( @@ -266,7 +270,7 @@ Attribute::Handlers - Simpler definition of attribute handlers =head1 VERSION -This document describes version 0.96 of Attribute::Handlers. +This document describes version 0.97 of Attribute::Handlers. =head1 SYNOPSIS diff --git a/dist/Data-Dumper/Dumper.pm b/dist/Data-Dumper/Dumper.pm index 9afeac7..520dfd4 100644 --- a/dist/Data-Dumper/Dumper.pm +++ b/dist/Data-Dumper/Dumper.pm @@ -10,7 +10,7 @@ package Data::Dumper; BEGIN { - $VERSION = '2.152'; # Don't forget to set version and release + $VERSION = '2.154'; # Don't forget to set version and release } # date in POD below! #$| = 1; @@ -56,6 +56,7 @@ $Useperl = 0 unless defined $Useperl; $Sortkeys = 0 unless defined $Sortkeys; $Deparse = 0 unless defined $Deparse; $Sparseseen = 0 unless defined $Sparseseen; +$Maxrecurse = 1000 unless defined $Maxrecurse; # # expects an arrayref of values to be dumped. @@ -92,6 +93,7 @@ sub new { 'bless' => $Bless, # keyword to use for "bless" # expdepth => $Expdepth, # cutoff depth for explicit dumping maxdepth => $Maxdepth, # depth beyond which we give up + maxrecurse => $Maxrecurse, # depth beyond which we abort useperl => $Useperl, # use the pure Perl implementation sortkeys => $Sortkeys, # flag or filter for sorting hash keys deparse => $Deparse, # use B::Deparse for coderefs @@ -350,6 +352,12 @@ sub _dump { return qq['$val']; } + # avoid recursing infinitely [perl #122111] + if ($s->{maxrecurse} > 0 + and $s->{level} >= $s->{maxrecurse}) { + die "Recursion limit of $s->{maxrecurse} exceeded"; + } + # we have a blessed ref my ($blesspad); if ($realpack and !$no_bless) { @@ -680,6 +688,11 @@ sub Maxdepth { defined($v) ? (($s->{'maxdepth'} = $v), return $s) : $s->{'maxdepth'}; } +sub Maxrecurse { + my($s, $v) = @_; + defined($v) ? (($s->{'maxrecurse'} = $v), return $s) : $s->{'maxrecurse'}; +} + sub Useperl { my($s, $v) = @_; defined($v) ? (($s->{'useperl'} = $v), return $s) : $s->{'useperl'}; @@ -1105,6 +1118,16 @@ no maximum depth. =item * +$Data::Dumper::Maxrecurse I $I->Maxrecurse(I<[NEWVAL]>) + +Can be set to a positive integer that specifies the depth beyond which +recursion into a structure will throw an exception. This is intended +as a security measure to prevent perl running out of stack space when +dumping an excessively deep structure. Can be set to 0 to remove the +limit. Default is 1000. + +=item * + $Data::Dumper::Useperl I $I->Useperl(I<[NEWVAL]>) Can be set to a boolean value which controls whether the pure Perl @@ -1398,7 +1421,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.153 (June 5 2014) +Version 2.154 (September 18 2014) =head1 SEE ALSO diff --git a/dist/Data-Dumper/Dumper.xs b/dist/Data-Dumper/Dumper.xs index 6356501..2ffa867 100644 --- a/dist/Data-Dumper/Dumper.xs +++ b/dist/Data-Dumper/Dumper.xs @@ -28,7 +28,7 @@ static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, - I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq); + I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq, IV maxrecurse); #ifndef HvNAME_get #define HvNAME_get HvNAME @@ -413,7 +413,7 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity, I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys, - int use_sparse_seen_hash, I32 useqq) + int use_sparse_seen_hash, I32 useqq, IV maxrecurse) { char tmpbuf[128]; Size_t i; @@ -590,6 +590,10 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, return 1; } + if (maxrecurse > 0 && *levelp >= maxrecurse) { + croak("Recursion limit of %" IVdf " exceeded", maxrecurse); + } + if (realpack && !no_bless) { /* we have a blessed ref */ STRLEN blesslen; const char * const blessstr = SvPV(bless, blesslen); @@ -676,7 +680,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth, sortkeys, use_sparse_seen_hash, useqq); + maxdepth, sortkeys, use_sparse_seen_hash, useqq, + maxrecurse); sv_catpvs(retval, ")}"); } /* plain */ else { @@ -684,7 +689,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth, sortkeys, use_sparse_seen_hash, useqq); + maxdepth, sortkeys, use_sparse_seen_hash, useqq, + maxrecurse); } SvREFCNT_dec(namesv); } @@ -696,7 +702,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth, sortkeys, use_sparse_seen_hash, useqq); + maxdepth, sortkeys, use_sparse_seen_hash, useqq, + maxrecurse); SvREFCNT_dec(namesv); } else if (realtype == SVt_PVAV) { @@ -769,7 +776,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav, levelp, indent, pad, xpad, apad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth, sortkeys, use_sparse_seen_hash, useqq); + maxdepth, sortkeys, use_sparse_seen_hash, + useqq, maxrecurse); if (ix < ixmax) sv_catpvs(retval, ","); } @@ -981,7 +989,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv, postav, levelp, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, - maxdepth, sortkeys, use_sparse_seen_hash, useqq); + maxdepth, sortkeys, use_sparse_seen_hash, useqq, + maxrecurse); SvREFCNT_dec(sname); Safefree(nkey_buffer); if (indent >= 2) @@ -1190,7 +1199,8 @@ DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv, seenhv, postav, &nlevel, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, bless, maxdepth, - sortkeys, use_sparse_seen_hash, useqq); + sortkeys, use_sparse_seen_hash, useqq, + maxrecurse); SvREFCNT_dec(e); } } @@ -1280,6 +1290,7 @@ Data_Dumper_Dumpxs(href, ...) SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname; SV *freezer, *toaster, *bless, *sortkeys; I32 purity, deepcopy, quotekeys, maxdepth = 0; + IV maxrecurse = 1000; char tmpbuf[1024]; I32 gimme = GIMME; int use_sparse_seen_hash = 0; @@ -1366,6 +1377,8 @@ Data_Dumper_Dumpxs(href, ...) bless = *svp; if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE))) maxdepth = SvIV(*svp); + if ((svp = hv_fetch(hv, "maxrecurse", 10, FALSE))) + maxrecurse = SvIV(*svp); if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) { sortkeys = *svp; if (! SvTRUE(sortkeys)) @@ -1445,7 +1458,8 @@ Data_Dumper_Dumpxs(href, ...) DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv, postav, &level, indent, pad, xpad, newapad, sep, pair, freezer, toaster, purity, deepcopy, quotekeys, - bless, maxdepth, sortkeys, use_sparse_seen_hash, useqq); + bless, maxdepth, sortkeys, use_sparse_seen_hash, + useqq, maxrecurse); SPAGAIN; if (indent >= 2 && !terse) diff --git a/dist/Data-Dumper/t/recurse.t b/dist/Data-Dumper/t/recurse.t new file mode 100644 index 0000000..275a89d --- /dev/null +++ b/dist/Data-Dumper/t/recurse.t @@ -0,0 +1,45 @@ +#!perl + +# Test the Maxrecurse option + +use strict; +use Test::More tests => 32; +use Data::Dumper; + +SKIP: { + skip "no XS available", 16 + if $Data::Dumper::Useperl; + local $Data::Dumper::Useperl = 1; + test_recursion(); +} + +test_recursion(); + +sub test_recursion { + my $pp = $Data::Dumper::Useperl ? "pure perl" : "XS"; + $Data::Dumper::Purity = 1; # make sure this has no effect + $Data::Dumper::Indent = 0; + $Data::Dumper::Maxrecurse = 1; + is(eval { Dumper([]) }, '$VAR1 = [];', "$pp: maxrecurse 1, []"); + is(eval { Dumper([[]]) }, undef, "$pp: maxrecurse 1, [[]]"); + ok($@, "exception thrown"); + is(eval { Dumper({}) }, '$VAR1 = {};', "$pp: maxrecurse 1, {}"); + is(eval { Dumper({ a => 1 }) }, q($VAR1 = {'a' => 1};), + "$pp: maxrecurse 1, { a => 1 }"); + is(eval { Dumper({ a => {} }) }, undef, "$pp: maxrecurse 1, { a => {} }"); + ok($@, "exception thrown"); + is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 1, \\1"); + is(eval { Dumper(\\1) }, undef, "$pp: maxrecurse 1, \\1"); + ok($@, "exception thrown"); + $Data::Dumper::Maxrecurse = 3; + is(eval { Dumper(\1) }, "\$VAR1 = \\1;", "$pp: maxrecurse 3, \\1"); + is(eval { Dumper(\(my $s = {})) }, "\$VAR1 = \\{};", "$pp: maxrecurse 3, \\{}"); + is(eval { Dumper(\(my $s = { a => [] })) }, "\$VAR1 = \\{'a' => []};", + "$pp: maxrecurse 3, \\{ a => [] }"); + is(eval { Dumper(\(my $s = { a => [{}] })) }, undef, + "$pp: maxrecurse 3, \\{ a => [{}] }"); + ok($@, "exception thrown"); + $Data::Dumper::Maxrecurse = 0; + is(eval { Dumper([[[[[]]]]]) }, q($VAR1 = [[[[[]]]]];), + "$pp: check Maxrecurse doesn't set limit to 0 recursion"); +} diff --git a/dist/ExtUtils-CBuilder/Changes b/dist/ExtUtils-CBuilder/Changes index 5c03667..8c5ab45 100644 --- a/dist/ExtUtils-CBuilder/Changes +++ b/dist/ExtUtils-CBuilder/Changes @@ -1,5 +1,24 @@ Revision history for Perl extension ExtUtils::CBuilder. +0.280219 - 2014-09-01 + + Fixed: + + - Fixed regression on Android (thanks to Brian Fraser) + +0.280218 - 2014-09-01 + + Fixed: + + - Mispelled 'starup' key in BCC support was fixed. #79574 + - Fixed the version in the PM file (thanks to Jim Keenan) + +0.280217 - 2014-08-22 + + Fixed: + + - Quoted perl path for Windows support #98245 [Alberto Simões] + 0.280216 - 2014-03-07 Added: diff --git a/dist/ExtUtils-CBuilder/Makefile.PL b/dist/ExtUtils-CBuilder/Makefile.PL index fb429cd..ba0ca08 100644 --- a/dist/ExtUtils-CBuilder/Makefile.PL +++ b/dist/ExtUtils-CBuilder/Makefile.PL @@ -1,20 +1,19 @@ -# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.013. +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v5.020. use strict; use warnings; -use ExtUtils::MakeMaker 6.30; +use ExtUtils::MakeMaker ; my %WriteMakefileArgs = ( "ABSTRACT" => "Compile and link C code for Perl modules", "AUTHOR" => "Ken Williams , The Perl 5 Porters", - "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { - "ExtUtils::MakeMaker" => "6.30" + "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "ExtUtils-CBuilder", "EXE_FILES" => [], @@ -34,7 +33,7 @@ my %WriteMakefileArgs = ( "TEST_REQUIRES" => { "Test::More" => "0.47" }, - "VERSION" => "0.280216", + "VERSION" => "0.280219", "test" => { "TESTS" => "t/*.t" } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm index 98a68a0..43de8a9 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm @@ -1,13 +1,11 @@ package ExtUtils::CBuilder; - +$ExtUtils::CBuilder::VERSION = '0.280219'; use File::Spec (); use File::Path (); use File::Basename (); use Perl::OSType qw/os_type/; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; -$VERSION = eval $VERSION; +use vars qw(@ISA); # We only use this once - don't waste a symbol table entry on it. # More importantly, don't make it an inheritable method. diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm index 4392b7f..d52b705 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm @@ -1,5 +1,5 @@ package ExtUtils::CBuilder::Base; - +$ExtUtils::CBuilder::Base::VERSION = '0.280219'; use strict; use File::Spec; use File::Basename; @@ -9,9 +9,6 @@ use Text::ParseWords; use IPC::Cmd qw(can_run); use File::Temp qw(tempfile); -use vars qw($VERSION); -$VERSION = '0.280217'; - # More details about C/C++ compilers: # http://developers.sun.com/sunstudio/documentation/product/compiler.jsp # http://gcc.gnu.org/ diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm index d948bbf..fcc0d73 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -1,10 +1,9 @@ package ExtUtils::CBuilder::Platform::Unix; - +$ExtUtils::CBuilder::Platform::Unix::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Base; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Base); sub link_executable { diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm index d296bab..fc8f9e4 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -1,10 +1,9 @@ package ExtUtils::CBuilder::Platform::VMS; - +$ExtUtils::CBuilder::Platform::VMS::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Base; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Base); use File::Spec::Functions qw(catfile catdir); diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm index f9e4070..e8ad286 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -1,5 +1,5 @@ package ExtUtils::CBuilder::Platform::Windows; - +$ExtUtils::CBuilder::Platform::Windows::VERSION = '0.280219'; use strict; use warnings; @@ -9,8 +9,7 @@ use File::Spec; use ExtUtils::CBuilder::Base; use IO::File; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Base); =begin comment diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm index aab1437..2a18cdb 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -1,8 +1,5 @@ package ExtUtils::CBuilder::Platform::Windows::BCC; - -use vars qw($VERSION); -$VERSION = '0.280217'; - +$ExtUtils::CBuilder::Platform::Windows::BCC::VERSION = '0.280219'; sub format_compiler_cmd { my ($self, %spec) = @_; @@ -64,7 +61,7 @@ sub format_linker_cmd { } push( @{$spec{startup}}, 'c0d32.obj' ) - unless ( $spec{starup} && @{$spec{startup}} ); + unless ( $spec{startup} && @{$spec{startup}} ); %spec = $self->write_linker_script(%spec) if $spec{use_scripts}; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm index b8a32a8..b45cada 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -1,8 +1,5 @@ package ExtUtils::CBuilder::Platform::Windows::GCC; - -use vars qw($VERSION); -$VERSION = '0.280217'; - +$ExtUtils::CBuilder::Platform::Windows::GCC::VERSION = '0.280219'; sub format_compiler_cmd { my ($self, %spec) = @_; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm index 3d4b5ab..170b057 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -1,8 +1,5 @@ package ExtUtils::CBuilder::Platform::Windows::MSVC; - -use vars qw($VERSION); -$VERSION = '0.280217'; - +$ExtUtils::CBuilder::Platform::Windows::MSVC::VERSION = '0.280219'; sub arg_exec_file { my ($self, $file) = @_; return "/OUT:$file"; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm index ecc14f8..e9904a1 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -1,11 +1,10 @@ package ExtUtils::CBuilder::Platform::aix; - +$ExtUtils::CBuilder::Platform::aix::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm index e2be516..d0b2180 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/android.pm @@ -1,12 +1,10 @@ package ExtUtils::CBuilder::Platform::android; - +$ExtUtils::CBuilder::Platform::android::VERSION = '0.280219'; use strict; -use Config; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # The Android linker will not recognize symbols from diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm index 43e6a47..10a2e9c 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -1,11 +1,10 @@ package ExtUtils::CBuilder::Platform::cygwin; - +$ExtUtils::CBuilder::Platform::cygwin::VERSION = '0.280219'; use strict; use File::Spec; use ExtUtils::CBuilder::Platform::Unix; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # TODO: If a specific exe_file name is requested, if the exe created diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm index bc4f188..9969a8a 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -1,10 +1,9 @@ package ExtUtils::CBuilder::Platform::darwin; - +$ExtUtils::CBuilder::Platform::darwin::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Platform::Unix; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub compile { diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm index f16fc01..95e2905 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -1,12 +1,11 @@ package ExtUtils::CBuilder::Platform::dec_osf; - +$ExtUtils::CBuilder::Platform::dec_osf::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Platform::Unix; use File::Spec; -use vars qw($VERSION @ISA); +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); -$VERSION = '0.280217'; sub link_executable { my $self = shift; diff --git a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm index 3d4867c..0d46aeb 100644 --- a/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm +++ b/dist/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -1,10 +1,9 @@ package ExtUtils::CBuilder::Platform::os2; - +$ExtUtils::CBuilder::Platform::os2::VERSION = '0.280219'; use strict; use ExtUtils::CBuilder::Platform::Unix; -use vars qw($VERSION @ISA); -$VERSION = '0.280217'; +use vars qw(@ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/dist/ExtUtils-CBuilder/t/00-have-compiler.t b/dist/ExtUtils-CBuilder/t/00-have-compiler.t index ffb1b04..1661812 100644 --- a/dist/ExtUtils-CBuilder/t/00-have-compiler.t +++ b/dist/ExtUtils-CBuilder/t/00-have-compiler.t @@ -4,6 +4,7 @@ use File::Spec; my $perl; BEGIN { $perl = File::Spec->rel2abs($^X); + $perl = qq{"$perl"}; # So it doesn't fail when there are spaces. } use strict; diff --git a/dist/ExtUtils-ParseXS/lib/perlxs.pod b/dist/ExtUtils-ParseXS/lib/perlxs.pod index 122933b..8d4132c 100644 --- a/dist/ExtUtils-ParseXS/lib/perlxs.pod +++ b/dist/ExtUtils-ParseXS/lib/perlxs.pod @@ -14,6 +14,8 @@ or statically linked into perl. The XS interface description is written in the XS language and is the core component of the Perl extension interface. +Before writing XS, read the L section below. + An B forms the basic unit of the XS interface. After compilation by the B compiler, each XSUB amounts to a C function definition which will provide the glue between Perl calling conventions and C @@ -2120,6 +2122,96 @@ File C: Perl test program for the RPC extension. print "time = $a\n"; print "netconf = $netconf\n"; +=head1 CAVEATS + +XS code has full access to system calls including C library functions. +It thus has the capability of interfering with things that the Perl core +or other modules have set up, such as signal handlers or file handles. +It could mess with the memory, or any number of harmful things. Don't. + +Some modules have an event loop, waiting for user-input. It is highly +unlikely that two such modules would work adequately together in a +single Perl application. + +In general, the perl interpreter views itself as the center of the +universe as far as the Perl program goes. XS code is viewed as a +help-mate, to accomplish things that perl doesn't do, or doesn't do fast +enough, but always subservient to perl. The closer XS code adheres to +this model, the less likely conflicts will occur. + +One area where there has been conflict is in regards to C locales. (See +L.) perl, with one exception and unless told otherwise, +sets up the underlying locale the program is running in to that passed +into it from the environment. As of v5.20, this underlying locale is +completely hidden from pure perl code outside the lexical scope of +C>; except a couple of function calls in the POSIX +module of necessity use it. But the underlying locale, with that one +exception is exposed to XS code, affecting all C library routines whose +behavior is locale-dependent. The exception is the +L|perllocale/Category LC_NUMERIC: Numeric Formatting> +locale category, and the reason it is an exception is that experience +has shown that it can be problematic for XS code, whereas we have not +had reports of problems with the +L. And the reason +for this one category being problematic is that the character used as a +decimal point can vary. Many European languages use a comma, whereas +English, and hence Perl are expecting a dot (U+002E: FULL STOP). Many +modules can handle only the radix character being a dot, and so perl +attempts to make it so. Up through Perl v5.20, the attempt was merely +to set C upon startup to the C<"C"> locale. Any +L otherwise would change +it; this caused some failures. Therefore, starting in v5.22, perl tries +to keep C always set to C<"C"> for XS code. + +To summarize, here's what to expect and how to handle locales in XS code: + +=over + +=item Non-locale-aware XS code + +Keep in mind that even if you think your code is not locale-aware, it +may call a C library function that is. Hopefully the man page for such +a function will indicate that dependency, but the documentation is +imperfect. + +The current locale is exposed to XS code except possibly C. +There have not been reports of problems with these other categories. + +Up through v5.20, Perl initializes things on start-up so that +C is set to the "C" locale. But if any code anywhere +changes it, it will stay changed. This means that your module can't +count on C being something in particular, and you can't +expect floating point numbers (including version strings) to have dots +in them. If you don't allow for a non-dot, your code could break if +anyone anywhere changes the locale. For this reason, v5.22 is changing +the behavior so that Perl tries to keep C in the "C" locale +except around the operations internally where it should be something +else. Misbehaving XS code will always be able to change the locale +anyway, but the most common instance of this is checked for and +handled. + +=item Locale-aware XS code + +If the locale from the user's environment is desired, there should be no +need for XS code to set the locale except for C, as perl has +already set it up. XS code should avoid changing the locale, as it can +adversely affect other, unrelated, code and may not be thread safe. +However, some alien libraries that may be called do set it, such as +C. This can cause problems for the perl core and other modules. +Starting in v5.20.1, calling the function +L from XS should be sufficient to +avoid most of these problems. Prior to this, you need a pure Perl +segment that does this: + + POSIX::setlocale(LC_ALL, POSIX::setlocale(LC_ALL)); + +Macros are provided for XS code to temporarily change to use the +underlying C locale when necessary. An API is being +developed for this, but has not yet been nailed down, but will be during +the course of v5.21. Send email to L for +guidance. + +=back =head1 XS VERSION diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm index 36c028a..296b097 100644 --- a/dist/IO/IO.pm +++ b/dist/IO/IO.pm @@ -7,7 +7,7 @@ use Carp; use strict; use warnings; -our $VERSION = "1.33"; +our $VERSION = "1.34"; XSLoader::load 'IO', $VERSION; sub import { diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs index 5e30795..c1b7e91 100644 --- a/dist/IO/IO.xs +++ b/dist/IO/IO.xs @@ -61,6 +61,10 @@ typedef FILE * OutputStream; # define dVAR dNOOP #endif +#ifndef OP_SIBLING +# define OP_SIBLING(o) (o)->op_sibling +#endif + static int not_here(const char *s) __attribute__noreturn__; static int not_here(const char *s) diff --git a/dist/IO/t/io_linenum.t b/dist/IO/t/io_linenum.t index 259f736..2d44f50 100644 --- a/dist/IO/t/io_linenum.t +++ b/dist/IO/t/io_linenum.t @@ -10,9 +10,7 @@ BEGIN { require strict; import strict; } -use Test; - -BEGIN { plan tests => 12 } +use Test::More tests => 12; use IO::File; @@ -32,42 +30,42 @@ open (F, $File) or die $!; my $io = IO::File->new($File) or die $!; for (1 .. 10); -ok(lineno($io), "10 0 10"); +is(lineno($io), "10 0 10"); $io->getline for (1 .. 5); -ok(lineno($io), "5 5 5"); +is(lineno($io), "5 5 5"); ; -ok(lineno($io), "11 5 11"); +is(lineno($io), "11 5 11"); $io->getline; -ok(lineno($io), "6 6 6"); +is(lineno($io), "6 6 6"); $t = tell F; # tell F; provokes a warning -ok(lineno($io), "11 6 11"); +is(lineno($io), "11 6 11"); ; -ok(lineno($io), "12 6 12"); +is(lineno($io), "12 6 12"); select F; -ok(lineno($io), "12 6 12"); +is(lineno($io), "12 6 12"); for (1 .. 10); -ok(lineno($io), "22 6 22"); +is(lineno($io), "22 6 22"); $io->getline for (1 .. 5); -ok(lineno($io), "11 11 11"); +is(lineno($io), "11 11 11"); $t = tell F; # We used to have problems here before local $. worked. # input_line_number() used to use select and tell. When we did the -# same, that mechanism broke. It should work now. -ok(lineno($io), "22 11 22"); +# same, that mechanism brise. It should work now. +is(lineno($io), "22 11 22"); { local $.; $io->getline for (1 .. 5); - ok(lineno($io), "16 16 16"); + is(lineno($io), "16 16 16"); } -ok(lineno($io), "22 16 22"); +is(lineno($io), "22 16 22"); diff --git a/dist/Math-BigInt/lib/Math/BigFloat.pm b/dist/Math-BigInt/lib/Math/BigFloat.pm index e022949..1c31496 100644 --- a/dist/Math-BigInt/lib/Math/BigFloat.pm +++ b/dist/Math-BigInt/lib/Math/BigFloat.pm @@ -12,7 +12,7 @@ package Math::BigFloat; # _a : accuracy # _p : precision -$VERSION = '1.9996'; +$VERSION = '1.9997'; require 5.006002; require Exporter; diff --git a/dist/Math-BigInt/lib/Math/BigInt.pm b/dist/Math-BigInt/lib/Math/BigInt.pm index 69fd320..62f1be9 100644 --- a/dist/Math-BigInt/lib/Math/BigInt.pm +++ b/dist/Math-BigInt/lib/Math/BigInt.pm @@ -18,7 +18,7 @@ package Math::BigInt; my $class = "Math::BigInt"; use 5.006002; -$VERSION = '1.9996'; +$VERSION = '1.9997'; @ISA = qw(Exporter); @EXPORT_OK = qw(objectify bgcd blcm); @@ -4793,13 +4793,13 @@ change. Examples for rounding: use Math::BigFloat; - use Test; + use Test::More; $x = Math::BigFloat->new(123.4567); $y = Math::BigFloat->new(123.456789); Math::BigFloat->accuracy(4); # no more A than 4 - ok ($x->copy()->fround(),123.4); # even rounding + is ($x->copy()->fround(),123.4); # even rounding print $x->copy()->fround(),"\n"; # 123.4 Math::BigFloat->round_mode('odd'); # round to odd print $x->copy()->fround(),"\n"; # 123.5 @@ -5030,8 +5030,8 @@ known to be troublesome: Both C and C as well as automated stringify via overload now drop the leading '+'. The old code would return '+3', the new returns '3'. This is to be consistent with Perl and to make C (especially with -overloading) to work as you expect. It also solves problems with C, -because its C uses 'eq' internally. +overloading) to work as you expect. It also solves problems with C +and L, which stringify arguments before comparing them. Mark Biggar said, when asked about to drop the '+' altogether, or make only C work: @@ -5043,14 +5043,13 @@ C work: So, the following examples will now work all as expected: - use Test; - BEGIN { plan tests => 1 } + use Test::More tests => 1; use Math::BigInt; my $x = new Math::BigInt 3*3; my $y = new Math::BigInt 3*3; - ok ($x,3*3); + is ($x,3*3, 'multiplication'); print "$x eq 9" if $x eq $y; print "$x eq 9" if $x eq '9'; print "$x eq 9" if $x eq 3*3; @@ -5067,15 +5066,14 @@ for comparison, but Perl will represent some numbers as 100 and others as 1e+308. If in doubt, convert both arguments to Math::BigInt before comparing them as strings: - use Test; - BEGIN { plan tests => 3 } + use Test::More tests => 3; use Math::BigInt; $x = Math::BigInt->new('1e56'); $y = 1e56; - ok ($x,$y); # will fail - ok ($x->bsstr(),$y); # okay + is ($x,$y); # will fail + is ($x->bsstr(),$y); # okay $y = Math::BigInt->new($y); - ok ($x,$y); # okay + is ($x,$y); # okay Alternatively, simply use C<< <=> >> for comparisons, this will get it always right. There is not yet a way to get a number automatically represented diff --git a/dist/Math-BigInt/lib/Math/BigInt/Calc.pm b/dist/Math-BigInt/lib/Math/BigInt/Calc.pm index 588e2ac..d511bab 100644 --- a/dist/Math-BigInt/lib/Math/BigInt/Calc.pm +++ b/dist/Math-BigInt/lib/Math/BigInt/Calc.pm @@ -4,7 +4,7 @@ use 5.006002; use strict; # use warnings; # do not use warnings for older Perls -our $VERSION = '1.9996'; +our $VERSION = '1.9997'; # Package to store unsigned big integers in decimal and do math with them diff --git a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm index 1a83f09..9bf3e07 100644 --- a/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm +++ b/dist/Math-BigInt/lib/Math/BigInt/CalcEmu.pm @@ -5,7 +5,7 @@ use strict; # use warnings; # do not use warnings for older Perls use vars qw/$VERSION/; -$VERSION = '1.9996'; +$VERSION = '1.9997'; package Math::BigInt; diff --git a/dist/Module-CoreList/Changes b/dist/Module-CoreList/Changes index b95dca2..b4d1ba7 100644 --- a/dist/Module-CoreList/Changes +++ b/dist/Module-CoreList/Changes @@ -1,3 +1,9 @@ +5.20140920 + - Updated for v5.21.4 + +5.20140914 + - Updated for v5.20.1 + 5.021003 - Prepared for v5.21.3 diff --git a/dist/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index 4fec3e9..da3019b 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -4,7 +4,7 @@ use vars qw/$VERSION %released %version %families %upstream %bug_tracker %deprecated %delta/; use Module::CoreList::TieHashDelta; use version; -$VERSION = '5.021003'; +$VERSION = '5.20140920'; my $dumpinc = 0; sub import { @@ -253,6 +253,8 @@ sub changes_between { 5.021001 => '2014-06-20', 5.021002 => '2014-07-20', 5.021003 => '2014-08-20', + 5.020001 => '2014-09-14', + 5.021004 => '2014-09-20', ); for my $version ( sort { $a <=> $b } keys %released ) { @@ -10130,6 +10132,226 @@ for my $version ( sort { $a <=> $b } keys %released ) { removed => { } }, + 5.020001 => { + delta_from => 5.020000, + changed => { + 'Config' => '5.020001', + 'Config::Perl::V' => '0.22', + 'Cwd' => '3.48', + 'Exporter' => '5.71', + 'Exporter::Heavy' => '5.71', + 'ExtUtils::CBuilder' => '0.280217', + 'ExtUtils::CBuilder::Base'=> '0.280217', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280217', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280217', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280217', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280217', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280217', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280217', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280217', + 'ExtUtils::CBuilder::Platform::android'=> '0.280217', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280217', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280217', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280217', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280217', + 'File::Copy' => '2.30', + 'File::Spec' => '3.48', + 'File::Spec::Cygwin' => '3.48', + 'File::Spec::Epoc' => '3.48', + 'File::Spec::Functions' => '3.48', + 'File::Spec::Mac' => '3.48', + 'File::Spec::OS2' => '3.48', + 'File::Spec::Unix' => '3.48', + 'File::Spec::VMS' => '3.48', + 'File::Spec::Win32' => '3.48', + 'Module::CoreList' => '5.020001', + 'Module::CoreList::TieHashDelta'=> '5.020001', + 'Module::CoreList::Utils'=> '5.020001', + 'PerlIO::via' => '0.15', + 'Unicode::UCD' => '0.58', + 'XS::APItest' => '0.60_01', + 'utf8' => '1.13_01', + 'version' => '0.9909', + 'version::regex' => '0.9909', + 'version::vpp' => '0.9909', + }, + removed => { + } + }, + 5.021004 => { + delta_from => 5.021003, + changed => { + 'App::Prove' => '3.33', + 'App::Prove::State' => '3.33', + 'App::Prove::State::Result'=> '3.33', + 'App::Prove::State::Result::Test'=> '3.33', + 'Archive::Tar' => '2.02', + 'Archive::Tar::Constant'=> '2.02', + 'Archive::Tar::File' => '2.02', + 'Attribute::Handlers' => '0.97', + 'B' => '1.51', + 'B::Concise' => '0.993', + 'B::Deparse' => '1.28', + 'B::Op_private' => '5.021004', + 'CPAN::Meta::Requirements'=> '2.128', + 'Config' => '5.021004', + 'Cwd' => '3.50', + 'Data::Dumper' => '2.154', + 'ExtUtils::CBuilder' => '0.280219', + 'ExtUtils::CBuilder::Base'=> '0.280219', + 'ExtUtils::CBuilder::Platform::Unix'=> '0.280219', + 'ExtUtils::CBuilder::Platform::VMS'=> '0.280219', + 'ExtUtils::CBuilder::Platform::Windows'=> '0.280219', + 'ExtUtils::CBuilder::Platform::Windows::BCC'=> '0.280219', + 'ExtUtils::CBuilder::Platform::Windows::GCC'=> '0.280219', + 'ExtUtils::CBuilder::Platform::Windows::MSVC'=> '0.280219', + 'ExtUtils::CBuilder::Platform::aix'=> '0.280219', + 'ExtUtils::CBuilder::Platform::android'=> '0.280219', + 'ExtUtils::CBuilder::Platform::cygwin'=> '0.280219', + 'ExtUtils::CBuilder::Platform::darwin'=> '0.280219', + 'ExtUtils::CBuilder::Platform::dec_osf'=> '0.280219', + 'ExtUtils::CBuilder::Platform::os2'=> '0.280219', + 'ExtUtils::Install' => '2.04', + 'ExtUtils::Installed' => '2.04', + 'ExtUtils::Liblist::Kid'=> '6.98_01', + 'ExtUtils::Manifest' => '1.68', + 'ExtUtils::Packlist' => '2.04', + 'File::Find' => '1.28', + 'File::Spec' => '3.50', + 'File::Spec::Cygwin' => '3.50', + 'File::Spec::Epoc' => '3.50', + 'File::Spec::Functions' => '3.50', + 'File::Spec::Mac' => '3.50', + 'File::Spec::OS2' => '3.50', + 'File::Spec::Unix' => '3.50', + 'File::Spec::VMS' => '3.50', + 'File::Spec::Win32' => '3.50', + 'Getopt::Std' => '1.11', + 'HTTP::Tiny' => '0.049', + 'IO' => '1.34', + 'IO::Socket::IP' => '0.32', + 'List::Util' => '1.41', + 'List::Util::XS' => '1.41', + 'Locale::Codes' => '3.32', + 'Locale::Codes::Constants'=> '3.32', + 'Locale::Codes::Country'=> '3.32', + 'Locale::Codes::Country_Codes'=> '3.32', + 'Locale::Codes::Country_Retired'=> '3.32', + 'Locale::Codes::Currency'=> '3.32', + 'Locale::Codes::Currency_Codes'=> '3.32', + 'Locale::Codes::Currency_Retired'=> '3.32', + 'Locale::Codes::LangExt'=> '3.32', + 'Locale::Codes::LangExt_Codes'=> '3.32', + 'Locale::Codes::LangExt_Retired'=> '3.32', + 'Locale::Codes::LangFam'=> '3.32', + 'Locale::Codes::LangFam_Codes'=> '3.32', + 'Locale::Codes::LangFam_Retired'=> '3.32', + 'Locale::Codes::LangVar'=> '3.32', + 'Locale::Codes::LangVar_Codes'=> '3.32', + 'Locale::Codes::LangVar_Retired'=> '3.32', + 'Locale::Codes::Language'=> '3.32', + 'Locale::Codes::Language_Codes'=> '3.32', + 'Locale::Codes::Language_Retired'=> '3.32', + 'Locale::Codes::Script' => '3.32', + 'Locale::Codes::Script_Codes'=> '3.32', + 'Locale::Codes::Script_Retired'=> '3.32', + 'Locale::Country' => '3.32', + 'Locale::Currency' => '3.32', + 'Locale::Language' => '3.32', + 'Locale::Script' => '3.32', + 'Math::BigFloat' => '1.9997', + 'Math::BigInt' => '1.9997', + 'Math::BigInt::Calc' => '1.9997', + 'Math::BigInt::CalcEmu' => '1.9997', + 'Module::CoreList' => '5.20140920', + 'Module::CoreList::TieHashDelta'=> '5.20140920', + 'Module::CoreList::Utils'=> '5.20140920', + 'POSIX' => '1.43', + 'Pod::Perldoc' => '3.24', + 'Pod::Perldoc::BaseTo' => '3.24', + 'Pod::Perldoc::GetOptsOO'=> '3.24', + 'Pod::Perldoc::ToANSI' => '3.24', + 'Pod::Perldoc::ToChecker'=> '3.24', + 'Pod::Perldoc::ToMan' => '3.24', + 'Pod::Perldoc::ToNroff' => '3.24', + 'Pod::Perldoc::ToPod' => '3.24', + 'Pod::Perldoc::ToRtf' => '3.24', + 'Pod::Perldoc::ToTerm' => '3.24', + 'Pod::Perldoc::ToText' => '3.24', + 'Pod::Perldoc::ToTk' => '3.24', + 'Pod::Perldoc::ToXml' => '3.24', + 'Scalar::Util' => '1.41', + 'Sub::Util' => '1.41', + 'TAP::Base' => '3.33', + 'TAP::Formatter::Base' => '3.33', + 'TAP::Formatter::Color' => '3.33', + 'TAP::Formatter::Console'=> '3.33', + 'TAP::Formatter::Console::ParallelSession'=> '3.33', + 'TAP::Formatter::Console::Session'=> '3.33', + 'TAP::Formatter::File' => '3.33', + 'TAP::Formatter::File::Session'=> '3.33', + 'TAP::Formatter::Session'=> '3.33', + 'TAP::Harness' => '3.33', + 'TAP::Harness::Env' => '3.33', + 'TAP::Object' => '3.33', + 'TAP::Parser' => '3.33', + 'TAP::Parser::Aggregator'=> '3.33', + 'TAP::Parser::Grammar' => '3.33', + 'TAP::Parser::Iterator' => '3.33', + 'TAP::Parser::Iterator::Array'=> '3.33', + 'TAP::Parser::Iterator::Process'=> '3.33', + 'TAP::Parser::Iterator::Stream'=> '3.33', + 'TAP::Parser::IteratorFactory'=> '3.33', + 'TAP::Parser::Multiplexer'=> '3.33', + 'TAP::Parser::Result' => '3.33', + 'TAP::Parser::Result::Bailout'=> '3.33', + 'TAP::Parser::Result::Comment'=> '3.33', + 'TAP::Parser::Result::Plan'=> '3.33', + 'TAP::Parser::Result::Pragma'=> '3.33', + 'TAP::Parser::Result::Test'=> '3.33', + 'TAP::Parser::Result::Unknown'=> '3.33', + 'TAP::Parser::Result::Version'=> '3.33', + 'TAP::Parser::Result::YAML'=> '3.33', + 'TAP::Parser::ResultFactory'=> '3.33', + 'TAP::Parser::Scheduler'=> '3.33', + 'TAP::Parser::Scheduler::Job'=> '3.33', + 'TAP::Parser::Scheduler::Spinner'=> '3.33', + 'TAP::Parser::Source' => '3.33', + 'TAP::Parser::SourceHandler'=> '3.33', + 'TAP::Parser::SourceHandler::Executable'=> '3.33', + 'TAP::Parser::SourceHandler::File'=> '3.33', + 'TAP::Parser::SourceHandler::Handle'=> '3.33', + 'TAP::Parser::SourceHandler::Perl'=> '3.33', + 'TAP::Parser::SourceHandler::RawTAP'=> '3.33', + 'TAP::Parser::YAMLish::Reader'=> '3.33', + 'TAP::Parser::YAMLish::Writer'=> '3.33', + 'Term::ReadLine' => '1.15', + 'Test::Builder' => '1.001006', + 'Test::Builder::Module' => '1.001006', + 'Test::Builder::Tester' => '1.24', + 'Test::Builder::Tester::Color'=> '1.24', + 'Test::Harness' => '3.33', + 'Test::More' => '1.001006', + 'Test::Simple' => '1.001006', + 'Time::Piece' => '1.29', + 'Time::Seconds' => '1.29', + 'XS::APItest' => '0.64', + '_charnames' => '1.42', + 'attributes' => '0.23', + 'bigint' => '0.37', + 'bignum' => '0.38', + 'bigrat' => '0.37', + 'constant' => '1.32', + 'experimental' => '0.010', + 'overload' => '1.23', + 'threads' => '1.96', + 'version' => '0.9909', + 'version::regex' => '0.9909', + 'version::vpp' => '0.9909', + }, + removed => { + } + }, ); sub is_core @@ -10559,6 +10781,20 @@ for my $version (sort { $a <=> $b } keys %delta) { removed => { } }, + 5.020001 => { + delta_from => 5.020000, + changed => { + }, + removed => { + } + }, + 5.021004 => { + delta_from => 5.021003, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %deprecated) { @@ -10863,6 +11099,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Pod::Usage' => 'cpan', 'Scalar::Util' => 'cpan', 'Socket' => 'cpan', + 'Sub::Util' => 'cpan', 'Sys::Syslog' => 'cpan', 'Sys::Syslog::Win32' => 'cpan', 'TAP::Base' => 'cpan', @@ -11053,8 +11290,8 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'ExtUtils::Constant::ProxySubs'=> undef, 'ExtUtils::Constant::Utils'=> undef, 'ExtUtils::Constant::XS'=> undef, - 'ExtUtils::Install' => 'http://rt.perl.org/rt3/', - 'ExtUtils::Installed' => 'http://rt.perl.org/rt3/', + 'ExtUtils::Install' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', + 'ExtUtils::Installed' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', 'ExtUtils::Liblist' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::Liblist::Kid'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::MM' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', @@ -11077,10 +11314,10 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'ExtUtils::MY' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::MakeMaker' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::MakeMaker::Config'=> 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::Manifest' => 'http://rt.perl.org/rt3/', + 'ExtUtils::Manifest' => 'http://github.com/Perl-Toolchain-Gang/ExtUtils-Manifest/issues', 'ExtUtils::Mkbootstrap' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'ExtUtils::Mksymlists' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', - 'ExtUtils::Packlist' => 'http://rt.perl.org/rt3/', + 'ExtUtils::Packlist' => 'https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-Install', 'ExtUtils::testlib' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker', 'Fatal' => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=autodie', 'File::Fetch' => undef, @@ -11250,6 +11487,7 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Pod::Usage' => undef, 'Scalar::Util' => undef, 'Socket' => undef, + 'Sub::Util' => undef, 'Sys::Syslog' => undef, 'Sys::Syslog::Win32' => undef, 'TAP::Base' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness', @@ -11300,8 +11538,8 @@ for my $version (sort { $a <=> $b } keys %deprecated) { 'Test' => undef, 'Test::Builder' => 'http://github.com/Test-More/test-more/issues/', 'Test::Builder::Module' => 'http://github.com/Test-More/test-more/issues/', - 'Test::Builder::Tester' => 'http://github.com/schwern/test-more/issues', - 'Test::Builder::Tester::Color'=> 'http://github.com/schwern/test-more/issues', + 'Test::Builder::Tester' => 'http://github.com/Test-More/test-more/issues/', + 'Test::Builder::Tester::Color'=> 'http://github.com/Test-More/test-more/issues/', 'Test::Harness' => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Test-Harness', 'Test::More' => 'http://github.com/Test-More/test-more/issues/', 'Test::Simple' => 'http://github.com/Test-More/test-more/issues/', diff --git a/dist/Module-CoreList/lib/Module/CoreList.pod b/dist/Module-CoreList/lib/Module/CoreList.pod index 2f3573c..56263aa 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pod +++ b/dist/Module-CoreList/lib/Module/CoreList.pod @@ -230,7 +230,8 @@ Module::CoreList currently covers the 5.000, 5.001, 5.002, 5.003_07, 5.15.9, 5.16.0, 5.16.1, 5.16.2, 5.16.3, 5.17.0, 5.17.1, 5.17.2, 5.17.3, 5.17.4, 5.17.5, 5.17.6, 5.17.7, 5.17.8, 5.17.9, 5.17.10, 5.17.11, 5.18.0, 5.19.0, 5.19.1, 5.19.2, 5.19.3, 5.19.4, 5.19.5, 5.19.6, 5.19.7, 5.19.8, -5.19.9, 5.19.10, 5.19.11, 5.20.0, 5.21.0, 5.21.1, 5.21.2 and 5.21.3 releases of perl. +5.19.9, 5.19.10, 5.19.11, 5.20.0, 5.21.0, 5.21.1, 5.21.2, 5.21.3, 5.20.1 +and 5.21.4 releases of perl. =head1 HISTORY diff --git a/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm b/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm index 470f42d..dd42919 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/TieHashDelta.pm @@ -3,7 +3,7 @@ package Module::CoreList::TieHashDelta; use strict; use vars qw($VERSION); -$VERSION = '5.021003'; +$VERSION = '5.20140920'; sub TIEHASH { my ($class, $changed, $removed, $parent) = @_; diff --git a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm index 483f481..907606c 100644 --- a/dist/Module-CoreList/lib/Module/CoreList/Utils.pm +++ b/dist/Module-CoreList/lib/Module/CoreList/Utils.pm @@ -6,7 +6,7 @@ use vars qw[$VERSION %utilities]; use Module::CoreList; use Module::CoreList::TieHashDelta; -$VERSION = '5.021003'; +$VERSION = '5.20140920'; sub utilities { my $perl = shift; @@ -950,6 +950,20 @@ my %delta = ( removed => { } }, + 5.020001 => { + delta_from => 5.02, + changed => { + }, + removed => { + } + }, + 5.021004 => { + delta_from => 5.021003, + changed => { + }, + removed => { + } + }, ); for my $version (sort { $a <=> $b } keys %delta) { diff --git a/dist/Module-CoreList/t/corevers.t b/dist/Module-CoreList/t/corevers.t deleted file mode 100644 index 09d5d72..0000000 --- a/dist/Module-CoreList/t/corevers.t +++ /dev/null @@ -1,21 +0,0 @@ -#!perl -w -use strict; -use Test::More; - -plan skip_all => 'This is perl core-only test' unless $ENV{PERL_CORE}; -plan skip_all => 'Special case v5.21.1 because rjbs' if sprintf("v%vd", $^V) eq 'v5.21.1'; - -my @modules = qw[ - Module::CoreList - Module::CoreList::Utils - Module::CoreList::TieHashDelta -]; - -plan tests => scalar @modules; - -foreach my $mod ( @modules ) { - eval "require $mod"; - my $vers = eval $mod->VERSION; - ok( !( $vers < $] || $vers > $] ), "$mod version should match perl version in core" ) - or diag("$mod $vers doesn't match $]"); -} diff --git a/dist/PathTools/Cwd.pm b/dist/PathTools/Cwd.pm index 461e94d..5e85be8 100644 --- a/dist/PathTools/Cwd.pm +++ b/dist/PathTools/Cwd.pm @@ -171,7 +171,7 @@ use strict; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); -$VERSION = '3.49'; +$VERSION = '3.50'; my $xs_version = $VERSION; $VERSION =~ tr/_//; @@ -244,7 +244,7 @@ sub _vms_efs { # If loading the XS stuff doesn't work, we can fall back to pure perl if(! defined &getcwd && defined &DynaLoader::boot_DynaLoader) { eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.49 + #"Cwd object version 3.48 does not match bootstrap parameter 3.50 #at lib/DynaLoader.pm line 216." by having this eval if ( $] >= 5.006 ) { require XSLoader; diff --git a/dist/PathTools/Cwd.xs b/dist/PathTools/Cwd.xs index 4ddbdac..1f174bf 100644 --- a/dist/PathTools/Cwd.xs +++ b/dist/PathTools/Cwd.xs @@ -197,7 +197,7 @@ bsd_realpath(const char *path, char resolved[MAXPATHLEN]) symlink[slen] = '/'; symlink[slen + 1] = 0; } - left_len = my_strlcat(symlink, left, sizeof(left)); + left_len = my_strlcat(symlink, left, sizeof(symlink)); if (left_len >= sizeof(left)) { errno = ENAMETOOLONG; return (NULL); diff --git a/dist/PathTools/lib/File/Spec.pm b/dist/PathTools/lib/File/Spec.pm index e5cb815..5545c52 100644 --- a/dist/PathTools/lib/File/Spec.pm +++ b/dist/PathTools/lib/File/Spec.pm @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; my %module = (MacOS => 'Mac', diff --git a/dist/PathTools/lib/File/Spec/Cygwin.pm b/dist/PathTools/lib/File/Spec/Cygwin.pm index ef3b0a2..6c67db7 100644 --- a/dist/PathTools/lib/File/Spec/Cygwin.pm +++ b/dist/PathTools/lib/File/Spec/Cygwin.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Epoc.pm b/dist/PathTools/lib/File/Spec/Epoc.pm index 4dbc13d..5794616 100644 --- a/dist/PathTools/lib/File/Spec/Epoc.pm +++ b/dist/PathTools/lib/File/Spec/Epoc.pm @@ -3,7 +3,7 @@ package File::Spec::Epoc; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; require File::Spec::Unix; diff --git a/dist/PathTools/lib/File/Spec/Functions.pm b/dist/PathTools/lib/File/Spec/Functions.pm index 1bbfaae..52e2286 100644 --- a/dist/PathTools/lib/File/Spec/Functions.pm +++ b/dist/PathTools/lib/File/Spec/Functions.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; require Exporter; diff --git a/dist/PathTools/lib/File/Spec/Mac.pm b/dist/PathTools/lib/File/Spec/Mac.pm index 42a5d4a..96253d0 100644 --- a/dist/PathTools/lib/File/Spec/Mac.pm +++ b/dist/PathTools/lib/File/Spec/Mac.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/OS2.pm b/dist/PathTools/lib/File/Spec/OS2.pm index 9202c3c..df65d0c 100644 --- a/dist/PathTools/lib/File/Spec/OS2.pm +++ b/dist/PathTools/lib/File/Spec/OS2.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Unix.pm b/dist/PathTools/lib/File/Spec/Unix.pm index 3a3537c..71545d4 100644 --- a/dist/PathTools/lib/File/Spec/Unix.pm +++ b/dist/PathTools/lib/File/Spec/Unix.pm @@ -3,14 +3,14 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '3.49'; +$VERSION = '3.50'; my $xs_version = $VERSION; $VERSION =~ tr/_//; #dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { eval {#eval is questionable since we are handling potential errors like - #"Cwd object version 3.48 does not match bootstrap parameter 3.49 + #"Cwd object version 3.48 does not match bootstrap parameter 3.50 #at lib/DynaLoader.pm line 216." by having this eval if ( $] >= 5.006 ) { require XSLoader; diff --git a/dist/PathTools/lib/File/Spec/VMS.pm b/dist/PathTools/lib/File/Spec/VMS.pm index 82801f4..4e98aad 100644 --- a/dist/PathTools/lib/File/Spec/VMS.pm +++ b/dist/PathTools/lib/File/Spec/VMS.pm @@ -4,7 +4,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/PathTools/lib/File/Spec/Win32.pm b/dist/PathTools/lib/File/Spec/Win32.pm index 7195a31..18bfd9c 100644 --- a/dist/PathTools/lib/File/Spec/Win32.pm +++ b/dist/PathTools/lib/File/Spec/Win32.pm @@ -5,7 +5,7 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.49'; +$VERSION = '3.50'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/dist/Safe/t/safeops.t b/dist/Safe/t/safeops.t index cc25bcb..cb37445 100644 --- a/dist/Safe/t/safeops.t +++ b/dist/Safe/t/safeops.t @@ -446,7 +446,6 @@ egrent endgrent getlogin getlogin syscall syscall lock SKIP -threadsv SKIP setstate SKIP method_named $x->y() dor $x // $y diff --git a/dist/Term-ReadLine/lib/Term/ReadLine.pm b/dist/Term-ReadLine/lib/Term/ReadLine.pm index 80a0d4b..db08947 100644 --- a/dist/Term-ReadLine/lib/Term/ReadLine.pm +++ b/dist/Term-ReadLine/lib/Term/ReadLine.pm @@ -233,9 +233,9 @@ sub findConsole { my $console; my $consoleOUT; - if (-e "/dev/tty" and $^O ne 'MSWin32') { + if ($^O ne 'MSWin32' and -e "/dev/tty") { $console = "/dev/tty"; - } elsif (-e "con" or $^O eq 'MSWin32' or $^O eq 'msys') { + } elsif ($^O eq 'MSWin32' or $^O eq 'msys' or -e "con") { $console = 'CONIN$'; $consoleOUT = 'CONOUT$'; } elsif ($^O eq 'VMS') { @@ -320,7 +320,7 @@ sub Features { \%features } package Term::ReadLine; # So late to allow the above code be defined? -our $VERSION = '1.14'; +our $VERSION = '1.15'; my ($which) = exists $ENV{PERL_RL} ? split /\s+/, $ENV{PERL_RL} : undef; if ($which) { diff --git a/dist/bignum/lib/bigint.pm b/dist/bignum/lib/bigint.pm index 993ea91..0d7bde9 100644 --- a/dist/bignum/lib/bigint.pm +++ b/dist/bignum/lib/bigint.pm @@ -1,7 +1,7 @@ package bigint; use 5.006; -$VERSION = '0.36'; +$VERSION = '0.37'; use Exporter; @ISA = qw( Exporter ); @EXPORT_OK = qw( PI e bpi bexp hex oct ); @@ -248,8 +248,7 @@ sub import # see if we can find Math::BigInt::Lite if (!defined $a && !defined $p) # rounding won't work to well { - eval 'require Math::BigInt::Lite;'; - if ($@ eq '') + if (eval { require Math::BigInt::Lite; 1 }) { @import = ( ); # :constant in Lite, not MBI Math::BigInt::Lite->import( ':constant' ); diff --git a/dist/bignum/lib/bignum.pm b/dist/bignum/lib/bignum.pm index 40aedce..33150a7 100644 --- a/dist/bignum/lib/bignum.pm +++ b/dist/bignum/lib/bignum.pm @@ -1,7 +1,7 @@ package bignum; use 5.006; -$VERSION = '0.37'; +$VERSION = '0.38'; use Exporter; @ISA = qw( bigint ); @EXPORT_OK = qw( PI e bexp bpi hex oct ); @@ -155,8 +155,7 @@ sub import # see if we can find Math::BigInt::Lite if (!defined $a && !defined $p) # rounding won't work to well { - eval 'require Math::BigInt::Lite;'; - if ($@ eq '') + if (eval { require Math::BigInt::Lite; 1 }) { @import = ( ); # :constant in Lite, not MBI Math::BigInt::Lite->import( ':constant' ); diff --git a/dist/bignum/lib/bigrat.pm b/dist/bignum/lib/bigrat.pm index adbeff4..5845523 100644 --- a/dist/bignum/lib/bigrat.pm +++ b/dist/bignum/lib/bigrat.pm @@ -1,7 +1,7 @@ package bigrat; use 5.006; -$VERSION = '0.36'; +$VERSION = '0.37'; require Exporter; @ISA = qw( bigint ); @EXPORT_OK = qw( PI e bpi bexp hex oct ); @@ -148,8 +148,7 @@ sub import # see if we can find Math::BigInt::Lite if (!defined $a && !defined $p) # rounding won't work to well { - eval 'require Math::BigInt::Lite;'; - if ($@ eq '') + if (eval { require Math::BigInt::Lite; 1 }) { @import = ( ); # :constant in Lite, not MBI Math::BigInt::Lite->import( ':constant' ); diff --git a/dist/bignum/t/bn_lite.t b/dist/bignum/t/bn_lite.t index 28e38c5..c2a04cd 100644 --- a/dist/bignum/t/bn_lite.t +++ b/dist/bignum/t/bn_lite.t @@ -5,8 +5,7 @@ use strict; use Test::More; -eval 'require Math::BigInt::Lite;'; -if ($@ eq '') +if (eval { require Math::BigInt::Lite; 1 }) { plan (tests => 1); # can use Lite, so let bignum try it diff --git a/dist/bignum/t/br_lite.t b/dist/bignum/t/br_lite.t index fd63252..4e75356 100644 --- a/dist/bignum/t/br_lite.t +++ b/dist/bignum/t/br_lite.t @@ -5,8 +5,7 @@ use strict; use Test::More; -eval 'require Math::BigInt::Lite;'; -if ($@ eq '') +if (eval { require Math::BigInt::Lite; 1 }) { plan (tests => 1); # can use Lite, so let bignum try it diff --git a/dist/bignum/t/option_l.t b/dist/bignum/t/option_l.t index d8c6b87..b5eddec 100644 --- a/dist/bignum/t/option_l.t +++ b/dist/bignum/t/option_l.t @@ -15,32 +15,32 @@ no warnings 'redefine'; *Carp::carp = sub { push @W, $_[0]; }; } -my $rc = eval ('bignum->import( "l" => "foo" );'); +my $rc = eval { bignum->import( "l" => "foo" ) }; is ($@,''); # shouldn't die is (scalar @W, 1, 'one warning'); like ($W[0], qr/fallback to Math::/, 'got fallback'); -$rc = eval ('bignum->import( "lib" => "foo" );'); +$rc = eval { bignum->import( "lib" => "foo" ) }; is ($@,''); # ditto is (scalar @W, 2, 'two warnings'); like ($W[1], qr/fallback to Math::/, 'got fallback'); -$rc = eval ('bignum->import( "try" => "foo" );'); +$rc = eval { bignum->import( "try" => "foo" ) }; is ($@,''); # shouldn't die -$rc = eval ('bignum->import( "try" => "foo" );'); +$rc = eval { bignum->import( "try" => "foo" ) }; is ($@,''); # ditto -$rc = eval ('bignum->import( "foo" => "bar" );'); +$rc = eval { bignum->import( "foo" => "bar" ) }; like ($@, qr/^Unknown option foo/i, 'died'); # should die -$rc = eval ('bignum->import( "only" => "bar" );'); +$rc = eval { bignum->import( "only" => "bar" ) }; like ($@, qr/fallback disallowed/i, 'died'); # should die # test that options are only lowercase (don't see a reason why allow UPPER) foreach (qw/L LIB Lib T Trace TRACE V Version VERSION/) { - $rc = eval ('bignum->import( "$_" => "bar" );'); + $rc = eval { bignum->import( $_ => "bar" ) }; like ($@, qr/^Unknown option $_/i, 'died'); # should die } diff --git a/dist/constant/lib/constant.pm b/dist/constant/lib/constant.pm index 5d0d547..d03ab5f 100644 --- a/dist/constant/lib/constant.pm +++ b/dist/constant/lib/constant.pm @@ -4,7 +4,7 @@ use strict; use warnings::register; use vars qw($VERSION %declared); -$VERSION = '1.31'; +$VERSION = '1.32'; #======================================================================= @@ -24,7 +24,8 @@ my $boolean = qr/^[01]?\z/; BEGIN { # We'd like to do use constant _CAN_PCS => $] > 5.009002 # but that's a bit tricky before we load the constant module :-) - # By doing this, we save 1 run time check for *every* call to import. + # By doing this, we save several run time checks for *every* call + # to import. my $const = $] > 5.009002; my $downgrade = $] < 5.015004; # && $] >= 5.008 my $constarray = exists &_make_const; @@ -56,13 +57,13 @@ sub import { return unless @_; # Ignore 'use constant;' my $constants; my $multiple = ref $_[0]; - my $pkg = caller; + my $caller = caller; my $flush_mro; my $symtab; if (_CAN_PCS) { no strict 'refs'; - $symtab = \%{$pkg . '::'}; + $symtab = \%{$caller . '::'}; }; if ( $multiple ) { @@ -80,6 +81,20 @@ sub import { } foreach my $name ( keys %$constants ) { + my $pkg; + my $symtab = $symtab; + my $orig_name = $name; + if ($name =~ s/(.*)(?:::|')(?=.)//s) { + $pkg = $1; + if (_CAN_PCS && $pkg ne $caller) { + no strict 'refs'; + $symtab = \%{$pkg . '::'}; + } + } + else { + $pkg = $caller; + } + # Normal constant name if ($name =~ $normal_constant_name and !$forbidden{$name}) { # Everything is okay @@ -127,7 +142,7 @@ sub import { my $full_name = "${pkg}::$name"; $declared{$full_name}++; if ($multiple || @_ == 1) { - my $scalar = $multiple ? $constants->{$name} : $_[0]; + my $scalar = $multiple ? $constants->{$orig_name} : $_[0]; if (_DOWNGRADE) { # for 5.8 to 5.14 # Work around perl bug #31991: Sub names (actually glob @@ -147,9 +162,9 @@ sub import { # The check in Perl_ck_rvconst knows that inlinable # constants from cv_const_sv are read only. So we have to: Internals::SvREADONLY($scalar, 1); - if ($symtab && !exists $symtab->{$name}) { + if (!exists $symtab->{$name}) { $symtab->{$name} = \$scalar; - ++$flush_mro; + ++$flush_mro->{$pkg}; } else { local $constant::{_dummy} = \$scalar; @@ -163,9 +178,9 @@ sub import { if (_CAN_PCS_FOR_ARRAY) { _make_const($list[$_]) for 0..$#list; _make_const(@list); - if ($symtab && !exists $symtab->{$name}) { + if (!exists $symtab->{$name}) { $symtab->{$name} = \@list; - $flush_mro++; + $flush_mro->{$pkg}++; } else { local $constant::{_dummy} = \@list; @@ -179,7 +194,9 @@ sub import { } } # Flush the cache exactly once if we make any direct symbol table changes. - mro::method_changed_in($pkg) if _CAN_PCS && $flush_mro; + if (_CAN_PCS && $flush_mro) { + mro::method_changed_in($_) for keys %$flush_mro; + } } 1; @@ -252,10 +269,6 @@ point to data which may be changed, as this code shows. ARRAY->[1] = " be changed"; print ARRAY->[1]; -Dereferencing constant references incorrectly (such as using an array -subscript on a constant hash reference, or vice versa) will be trapped at -compile time. - Constants belong to the package they are defined in. To refer to a constant defined in another package, specify the full package name, as in C. Constants may be exported by modules, @@ -264,6 +277,13 @@ as C<< Some::Package->CONSTANT >> or as C<< $obj->CONSTANT >> where C<$obj> is an instance of C. Subclasses may define their own constants to override those in their base class. +As of version 1.32 of this module, constants can be defined in packages +other than the caller, by including the package name in the name of the +constant: + + use constant "OtherPackage::FWIBBLE" => 7865; + constant->import("Other::FWOBBLE",$value); # dynamically at run time + The use of all caps for constant names is merely a convention, although it is recommended in order to make constants stand out and to help avoid collisions with other barewords, keywords, and diff --git a/dist/constant/t/constant.t b/dist/constant/t/constant.t index 111a8e1..00eddfb 100644 --- a/dist/constant/t/constant.t +++ b/dist/constant/t/constant.t @@ -9,7 +9,7 @@ END { @warnings && print STDERR join "\n- ", "accumulated warnings:", @warnings use strict; -use Test::More tests => 105; +use Test::More tests => 109; my $TB = Test::More->builder; BEGIN { use_ok('constant'); } @@ -122,7 +122,7 @@ print $output CCODE->($curr_test+4); $TB->current_test($curr_test+4); eval q{ CCODE->{foo} }; -ok scalar($@ =~ /^Constant is not a HASH/); +ok scalar($@ =~ /^Constant is not a HASH|Not a HASH reference/); # Allow leading underscore @@ -414,3 +414,10 @@ SKIP: { is $values[1], $values[0], 'modifying list const elements does not affect future retavls'; } + +use constant { "tahi" => 1, "rua::rua" => 2, "toru'toru" => 3 }; +use constant "wha::wha" => 4; +is tahi, 1, 'unqualified constant declared with constants in other pkgs'; +is rua::rua, 2, 'constant declared with ::'; +is toru::toru, 3, "constant declared with '"; +is wha::wha, 4, 'constant declared by itself with ::'; diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index ff41a20..c4e434e 100644 --- a/dist/threads/lib/threads.pm +++ b/dist/threads/lib/threads.pm @@ -5,7 +5,7 @@ use 5.008; use strict; use warnings; -our $VERSION = '1.95'; +our $VERSION = '1.96'; my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -134,7 +134,7 @@ threads - Perl interpreter-based threads =head1 VERSION -This document describes threads version 1.92 +This document describes threads version 1.96 =head1 WARNING diff --git a/dist/threads/t/exit.t b/dist/threads/t/exit.t index 2879e2b..4ccde34 100644 --- a/dist/threads/t/exit.t +++ b/dist/threads/t/exit.t @@ -48,7 +48,7 @@ my $rc = $thr->join(); ok(! defined($rc), 'Exited: threads->exit()'); -run_perl(prog => 'use threads 1.92;' . +run_perl(prog => 'use threads 1.96;' . 'threads->exit(86);' . 'exit(99);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -98,7 +98,7 @@ $rc = $thr->join(); ok(! defined($rc), 'Exited: $thr->set_thread_exit_only'); -run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . +run_perl(prog => 'use threads 1.96 qw(exit thread_only);' . 'threads->create(sub { exit(99); })->join();' . 'exit(86);', nolib => ($ENV{PERL_CORE}) ? 0 : 1, @@ -108,7 +108,7 @@ run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . is($?>>8, 86, "'use threads 'exit' => 'thread_only'"); } -my $out = run_perl(prog => 'use threads 1.92;' . +my $out = run_perl(prog => 'use threads 1.96;' . 'threads->create(sub {' . ' exit(99);' . '});' . @@ -124,7 +124,7 @@ my $out = run_perl(prog => 'use threads 1.92;' . like($out, qr/1 finished and unjoined/, "exit(status) in thread"); -$out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . +$out = run_perl(prog => 'use threads 1.96 qw(exit thread_only);' . 'threads->create(sub {' . ' threads->set_thread_exit_only(0);' . ' exit(99);' . @@ -141,7 +141,7 @@ $out = run_perl(prog => 'use threads 1.92 qw(exit thread_only);' . like($out, qr/1 finished and unjoined/, "set_thread_exit_only(0)"); -run_perl(prog => 'use threads 1.92;' . +run_perl(prog => 'use threads 1.96;' . 'threads->create(sub {' . ' $SIG{__WARN__} = sub { exit(99); };' . ' die();' . diff --git a/dist/threads/t/thread.t b/dist/threads/t/thread.t index f8eb3fa..e668e62 100644 --- a/dist/threads/t/thread.t +++ b/dist/threads/t/thread.t @@ -161,7 +161,7 @@ package main; # bugid #24165 -run_perl(prog => 'use threads 1.92;' . +run_perl(prog => 'use threads 1.96;' . 'sub a{threads->create(shift)} $t = a sub{};' . '$t->tid; $t->join; $t->tid', nolib => ($ENV{PERL_CORE}) ? 0 : 1, diff --git a/doop.c b/doop.c index 6a136d9..3b6f1e7 100644 --- a/doop.c +++ b/doop.c @@ -1215,6 +1215,9 @@ finish: SvTAINT(sv); } + +/* used for: pp_keys(), pp_values() */ + OP * Perl_do_kv(pTHX) { diff --git a/dump.c b/dump.c index d15aee6..c848dcd 100644 --- a/dump.c +++ b/dump.c @@ -751,6 +751,10 @@ S_sequence_num(pTHX_ const OP *o) return PL_op_seq; } + + + + const struct flag_to_name op_flags_names[] = { {OPf_KIDS, ",KIDS"}, {OPf_PARENS, ",PARENS"}, @@ -760,240 +764,6 @@ const struct flag_to_name op_flags_names[] = { {OPf_SPECIAL, ",SPECIAL"} }; -const struct flag_to_name op_trans_names[] = { - {OPpTRANS_FROM_UTF, ",FROM_UTF"}, - {OPpTRANS_TO_UTF, ",TO_UTF"}, - {OPpTRANS_IDENTICAL, ",IDENTICAL"}, - {OPpTRANS_SQUASH, ",SQUASH"}, - {OPpTRANS_COMPLEMENT, ",COMPLEMENT"}, - {OPpTRANS_GROWS, ",GROWS"}, - {OPpTRANS_DELETE, ",DELETE"} -}; - -const struct flag_to_name op_entersub_names[] = { - {OPpENTERSUB_DB, ",DB"}, - {OPpENTERSUB_HASTARG, ",HASTARG"}, - {OPpENTERSUB_AMPER, ",AMPER"}, - {OPpENTERSUB_NOPAREN, ",NOPAREN"}, - {OPpENTERSUB_INARGS, ",INARGS"} -}; - -const struct flag_to_name op_const_names[] = { - {OPpCONST_NOVER, ",NOVER"}, - {OPpCONST_SHORTCIRCUIT, ",SHORTCIRCUIT"}, - {OPpCONST_STRICT, ",STRICT"}, - {OPpCONST_ENTERED, ",ENTERED"}, - {OPpCONST_BARE, ",BARE"} -}; - -const struct flag_to_name op_sort_names[] = { - {OPpSORT_NUMERIC, ",NUMERIC"}, - {OPpSORT_INTEGER, ",INTEGER"}, - {OPpSORT_REVERSE, ",REVERSE"}, - {OPpSORT_INPLACE, ",INPLACE"}, - {OPpSORT_DESCEND, ",DESCEND"}, - {OPpSORT_QSORT, ",QSORT"}, - {OPpSORT_STABLE, ",STABLE"} -}; - -const struct flag_to_name op_open_names[] = { - {OPpOPEN_IN_RAW, ",IN_RAW"}, - {OPpOPEN_IN_CRLF, ",IN_CRLF"}, - {OPpOPEN_OUT_RAW, ",OUT_RAW"}, - {OPpOPEN_OUT_CRLF, ",OUT_CRLF"} -}; - -const struct flag_to_name op_sassign_names[] = { - {OPpASSIGN_BACKWARDS, ",BACKWARDS"}, - {OPpASSIGN_CV_TO_GV, ",CV2GV"} -}; - -const struct flag_to_name op_leave_names[] = { - {OPpREFCOUNTED, ",REFCOUNTED"}, - {OPpLVALUE, ",LVALUE"} -}; - -#define OP_PRIVATE_ONCE(op, flag, name) \ - const struct flag_to_name CAT2(op, _names)[] = { \ - {(flag), (name)} \ - } - -OP_PRIVATE_ONCE(op_leavesub, OPpREFCOUNTED, ",REFCOUNTED"); -OP_PRIVATE_ONCE(op_repeat, OPpREPEAT_DOLIST, ",DOLIST"); -OP_PRIVATE_ONCE(op_reverse, OPpREVERSE_INPLACE, ",INPLACE"); -OP_PRIVATE_ONCE(op_rv2cv, OPpLVAL_INTRO, ",INTRO"); -OP_PRIVATE_ONCE(op_flip, OPpFLIP_LINENUM, ",LINENUM"); -OP_PRIVATE_ONCE(op_gv, OPpEARLY_CV, ",EARLY_CV"); -OP_PRIVATE_ONCE(op_list, OPpLIST_GUESSED, ",GUESSED"); -OP_PRIVATE_ONCE(op_delete, OPpSLICE, ",SLICE"); -OP_PRIVATE_ONCE(op_exists, OPpEXISTS_SUB, ",EXISTS_SUB"); -OP_PRIVATE_ONCE(op_die, OPpHUSH_VMSISH, ",HUSH_VMSISH"); -OP_PRIVATE_ONCE(op_split, OPpSPLIT_IMPLIM, ",IMPLIM"); -OP_PRIVATE_ONCE(op_dbstate, OPpHUSH_VMSISH, ",HUSH_VMSISH"); - -struct op_private_by_op { - U16 op_type; - U16 len; - const struct flag_to_name *start; -}; - -const struct op_private_by_op op_private_names[] = { - {OP_LEAVESUB, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_LEAVE, C_ARRAY_LENGTH(op_leave_names), op_leave_names }, - {OP_LEAVESUBLV, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_LEAVEWRITE, C_ARRAY_LENGTH(op_leavesub_names), op_leavesub_names }, - {OP_DIE, C_ARRAY_LENGTH(op_die_names), op_die_names }, - {OP_DELETE, C_ARRAY_LENGTH(op_delete_names), op_delete_names }, - {OP_EXISTS, C_ARRAY_LENGTH(op_exists_names), op_exists_names }, - {OP_FLIP, C_ARRAY_LENGTH(op_flip_names), op_flip_names }, - {OP_FLOP, C_ARRAY_LENGTH(op_flip_names), op_flip_names }, - {OP_GV, C_ARRAY_LENGTH(op_gv_names), op_gv_names }, - {OP_LIST, C_ARRAY_LENGTH(op_list_names), op_list_names }, - {OP_SASSIGN, C_ARRAY_LENGTH(op_sassign_names), op_sassign_names }, - {OP_REPEAT, C_ARRAY_LENGTH(op_repeat_names), op_repeat_names }, - {OP_RV2CV, C_ARRAY_LENGTH(op_rv2cv_names), op_rv2cv_names }, - {OP_TRANS, C_ARRAY_LENGTH(op_trans_names), op_trans_names }, - {OP_CONST, C_ARRAY_LENGTH(op_const_names), op_const_names }, - {OP_SORT, C_ARRAY_LENGTH(op_sort_names), op_sort_names }, - {OP_OPEN, C_ARRAY_LENGTH(op_open_names), op_open_names }, - {OP_SPLIT, C_ARRAY_LENGTH(op_split_names), op_split_names }, - {OP_DBSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names }, - {OP_NEXTSTATE, C_ARRAY_LENGTH(op_dbstate_names), op_dbstate_names }, - {OP_BACKTICK, C_ARRAY_LENGTH(op_open_names), op_open_names } -}; - -static bool -S_op_private_to_names(pTHX_ SV *tmpsv, U32 optype, U32 op_private) { - const struct op_private_by_op *start = op_private_names; - const struct op_private_by_op *const end = C_ARRAY_END(op_private_names); - - /* This is a linear search, but no worse than the code that it replaced. - It's debugging code - size is more important than speed. */ - do { - if (optype == start->op_type) { - S_append_flags(aTHX_ tmpsv, op_private, start->start, - start->start + start->len); - return TRUE; - } - } while (++start < end); - return FALSE; -} - -#define DUMP_OP_FLAGS(o,level,file) \ - if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { \ - SV * const tmpsv = newSVpvs(""); \ - switch (o->op_flags & OPf_WANT) { \ - case OPf_WANT_VOID: \ - sv_catpv(tmpsv, ",VOID"); \ - break; \ - case OPf_WANT_SCALAR: \ - sv_catpv(tmpsv, ",SCALAR"); \ - break; \ - case OPf_WANT_LIST: \ - sv_catpv(tmpsv, ",LIST"); \ - break; \ - default: \ - sv_catpv(tmpsv, ",UNKNOWN"); \ - break; \ - } \ - append_flags(tmpsv, o->op_flags, op_flags_names); \ - if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); \ - if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); \ - if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); \ - if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); \ - if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); \ - Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", \ - SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); \ - } - -#define DUMP_OP_PRIVATE(o,level,file) \ - if (o->op_private) { \ - U32 optype = o->op_type; \ - U32 oppriv = o->op_private; \ - SV * const tmpsv = newSVpvs(""); \ - if (PL_opargs[optype] & OA_TARGLEX) { \ - if (oppriv & OPpTARGET_MY) \ - sv_catpv(tmpsv, ",TARGET_MY"); \ - } \ - else if (optype == OP_ENTERSUB || \ - optype == OP_RV2SV || \ - optype == OP_GVSV || \ - optype == OP_RV2AV || \ - optype == OP_RV2HV || \ - optype == OP_RV2GV || \ - optype == OP_AELEM || \ - optype == OP_HELEM ) \ - { \ - if (optype == OP_ENTERSUB) { \ - append_flags(tmpsv, oppriv, op_entersub_names); \ - } \ - else { \ - switch (oppriv & OPpDEREF) { \ - case OPpDEREF_SV: \ - sv_catpv(tmpsv, ",SV"); \ - break; \ - case OPpDEREF_AV: \ - sv_catpv(tmpsv, ",AV"); \ - break; \ - case OPpDEREF_HV: \ - sv_catpv(tmpsv, ",HV"); \ - break; \ - } \ - if (oppriv & OPpMAYBE_LVSUB) \ - sv_catpv(tmpsv, ",MAYBE_LVSUB"); \ - } \ - if (optype == OP_AELEM || optype == OP_HELEM) { \ - if (oppriv & OPpLVAL_DEFER) \ - sv_catpv(tmpsv, ",LVAL_DEFER"); \ - } \ - else if (optype == OP_RV2HV || optype == OP_PADHV) { \ - if (oppriv & OPpMAYBE_TRUEBOOL) \ - sv_catpvs(tmpsv, ",OPpMAYBE_TRUEBOOL"); \ - if (oppriv & OPpTRUEBOOL) \ - sv_catpvs(tmpsv, ",OPpTRUEBOOL"); \ - } \ - else { \ - if (oppriv & HINT_STRICT_REFS) \ - sv_catpv(tmpsv, ",STRICT_REFS"); \ - if (oppriv & OPpOUR_INTRO) \ - sv_catpv(tmpsv, ",OUR_INTRO"); \ - } \ - } \ - else if (S_op_private_to_names(aTHX_ tmpsv, optype, oppriv)) { \ - } \ - else if (OP_IS_FILETEST(o->op_type)) { \ - if (oppriv & OPpFT_ACCESS) \ - sv_catpv(tmpsv, ",FT_ACCESS"); \ - if (oppriv & OPpFT_STACKED) \ - sv_catpv(tmpsv, ",FT_STACKED"); \ - if (oppriv & OPpFT_STACKING) \ - sv_catpv(tmpsv, ",FT_STACKING"); \ - if (oppriv & OPpFT_AFTER_t) \ - sv_catpv(tmpsv, ",AFTER_t"); \ - } \ - else if (o->op_type == OP_AASSIGN) { \ - if (oppriv & OPpASSIGN_COMMON) \ - sv_catpvs(tmpsv, ",COMMON"); \ - if (oppriv & OPpMAYBE_LVSUB) \ - sv_catpvs(tmpsv, ",MAYBE_LVSUB"); \ - } \ - if (o->op_flags & OPf_MOD && oppriv & OPpLVAL_INTRO) \ - sv_catpv(tmpsv, ",INTRO"); \ - if (o->op_type == OP_PADRANGE) \ - Perl_sv_catpvf(aTHX_ tmpsv, ",COUNT=%"UVuf, \ - (UV)(oppriv & OPpPADRANGE_COUNTMASK)); \ - if ( (o->op_type == OP_RV2HV || o->op_type == OP_RV2AV || \ - o->op_type == OP_PADAV || o->op_type == OP_PADHV || \ - o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) \ - && oppriv & OPpSLICEWARNING ) \ - sv_catpvs(tmpsv, ",SLICEWARNING"); \ - if (SvCUR(tmpsv)) { \ - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); \ - } else \ - Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", \ - (UV)oppriv); \ - } - void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) @@ -1054,9 +824,114 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); #endif - DUMP_OP_FLAGS(o,level,file); - DUMP_OP_PRIVATE(o,level,file); + if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { + SV * const tmpsv = newSVpvs(""); + switch (o->op_flags & OPf_WANT) { + case OPf_WANT_VOID: + sv_catpv(tmpsv, ",VOID"); + break; + case OPf_WANT_SCALAR: + sv_catpv(tmpsv, ",SCALAR"); + break; + case OPf_WANT_LIST: + sv_catpv(tmpsv, ",LIST"); + break; + default: + sv_catpv(tmpsv, ",UNKNOWN"); + break; + } + append_flags(tmpsv, o->op_flags, op_flags_names); + if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); + if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); + if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); + if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); + if (o->op_lastsib) sv_catpvs(tmpsv, ",LASTSIB"); + Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", + SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); + } + + if (o->op_private) { + U16 oppriv = o->op_private; + I16 op_ix = PL_op_private_bitdef_ix[o->op_type]; + SV * tmpsv = NULL; + + if (op_ix != -1) { + U16 stop = 0; + tmpsv = newSVpvs(""); + for (; !stop; op_ix++) { + U16 entry = PL_op_private_bitdefs[op_ix]; + U16 bit = (entry >> 2) & 7; + U16 ix = entry >> 5; + + stop = (entry & 1); + + if (entry & 2) { + /* bitfield */ + I16 const *p = &PL_op_private_bitfields[ix]; + U16 bitmin = (U16) *p++; + I16 label = *p++; + I16 enum_label; + U16 mask = 0; + U16 i; + U16 val; + + for (i = bitmin; i<= bit; i++) + mask |= (1<>= bit; + enum_label = -1; + while (*p != -1) { + if (val == *p++) { + enum_label = *p; + break; + } + p++; + } + if (val == 0 && enum_label == -1) + /* don't display anonymous zero values */ + continue; + + sv_catpv(tmpsv, ","); + if (label != -1) { + sv_catpv(tmpsv, &PL_op_private_labels[label]); + sv_catpv(tmpsv, "="); + } + sv_catpv(tmpsv, &PL_op_private_labels[enum_label]); + } + else { + /* bit flag */ + if ( oppriv & (1<IDir) #define PL_Env (vTHX->IEnv) #define PL_HasMultiCharFold (vTHX->IHasMultiCharFold) +#define PL_InBitmap (vTHX->IInBitmap) #define PL_LIO (vTHX->ILIO) #define PL_Latin1 (vTHX->ILatin1) #define PL_Mem (vTHX->IMem) @@ -97,6 +98,7 @@ #define PL_comppad_name (vTHX->Icomppad_name) #define PL_comppad_name_fill (vTHX->Icomppad_name_fill) #define PL_comppad_name_floor (vTHX->Icomppad_name_floor) +#define PL_constpadix (vTHX->Iconstpadix) #define PL_cop_seqmax (vTHX->Icop_seqmax) #define PL_cryptseen (vTHX->Icryptseen) #define PL_curcop (vTHX->Icurcop) @@ -260,6 +262,7 @@ #define PL_savestack (vTHX->Isavestack) #define PL_savestack_ix (vTHX->Isavestack_ix) #define PL_savestack_max (vTHX->Isavestack_max) +#define PL_sawalias (vTHX->Isawalias) #ifndef PL_sawampersand #define PL_sawampersand (vTHX->Isawampersand) #endif diff --git a/ext/B/B.pm b/ext/B/B.pm index c908f51..d50a9d6 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -15,7 +15,7 @@ require Exporter; # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.50'; + $B::VERSION = '1.51'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. @@ -35,7 +35,7 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs parents comppadlist sv_undef compile_stats timing_info begin_av init_av check_av end_av regex_padav dowarn defstash curstash warnhook diehook inc_gv @optype - @specialsv_name unitcheck_av)); + @specialsv_name unitcheck_av safename)); @B::SV::ISA = 'B::OBJECT'; @B::NULL::ISA = 'B::SV'; @@ -85,7 +85,11 @@ push @B::EXPORT_OK, (qw(minus_c ppname save_BEGINs } sub B::GV::SAFENAME { - my $name = (shift())->NAME; + safename(shift()->NAME); +} + +sub safename { + my $name = shift; # The regex below corresponds to the isCONTROLVAR macro # from toke.c @@ -537,6 +541,13 @@ be used as a string in C source code. Returns a double-quote-surrounded escaped version of STR which can be used as a string in Perl source code. +=item safename(STR) + +This function returns the string with the first character modified if it +is a control character. It converts it to ^X format first, so that "\cG" +becomes "^G". This is used internally by L, but +you can call it directly. + =item class(OBJ) Returns the class of an object without the part of the classname @@ -545,8 +556,8 @@ C<"UNOP"> for example. =item threadsv_names -In a perl compiled for threads, this returns a list of the special -per-thread threadsv variables. +This used to provide support for the old 5.005 threading module. It now +does nothing. =back diff --git a/ext/B/B.xs b/ext/B/B.xs index a130ad3..17614cb 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -676,7 +676,7 @@ struct OP_methods { #if PERL_VERSION >= 17 { STR_WITH_LEN("code_list"),OPp, STRUCT_OFFSET(struct pmop, op_code_list),},/*13*/ #else - { STR_WITH_LEN("code_list"),op_offset_special, 0, + { STR_WITH_LEN("code_list"),op_offset_special, 0, }, /*13*/ #endif { STR_WITH_LEN("sv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*14*/ { STR_WITH_LEN("gv"), SVp, STRUCT_OFFSET(struct svop, op_sv), },/*15*/ @@ -1028,11 +1028,11 @@ next(o) if (op_methods[ix].type == op_offset_special) switch (ix) { - case 1: /* op_sibling */ + case 1: /* B::OP::op_sibling */ ret = make_op_object(aTHX_ OP_SIBLING(o)); break; - case 8: /* pmreplstart */ + case 8: /* B::PMOP::pmreplstart */ ret = make_op_object(aTHX_ cPMOPo->op_type == OP_SUBST ? cPMOPo->op_pmstashstartu.op_pmreplstart @@ -1040,22 +1040,22 @@ next(o) ); break; #ifdef USE_ITHREADS - case 21: /* filegv */ + case 21: /* B::COP::filegv */ ret = make_sv_object(aTHX_ (SV *)CopFILEGV((COP*)o)); break; #endif #ifndef USE_ITHREADS - case 22: /* file */ + case 22: /* B::COP::file */ ret = sv_2mortal(newSVpv(CopFILE((COP*)o), 0)); break; #endif #ifdef USE_ITHREADS - case 23: /* stash */ + case 23: /* B::COP::stash */ ret = make_sv_object(aTHX_ (SV *)CopSTASH((COP*)o)); break; #endif #if PERL_VERSION >= 17 || !defined USE_ITHREADS - case 24: /* stashpv */ + case 24: /* B::COP::stashpv */ # if PERL_VERSION >= 17 ret = sv_2mortal(CopSTASH((COP*)o) && SvTYPE(CopSTASH((COP*)o)) == SVt_PVHV @@ -1066,15 +1066,15 @@ next(o) # endif break; #endif - case 26: /* size */ + case 26: /* B::OP::size */ ret = sv_2mortal(newSVuv((UV)(opsizes[cc_opclass(aTHX_ o)]))); break; - case 27: /* name */ - case 28: /* desc */ + case 27: /* B::OP::name */ + case 28: /* B::OP::desc */ ret = sv_2mortal(newSVpv( (char *)(ix == 28 ? OP_DESC(o) : OP_NAME(o)), 0)); break; - case 29: /* ppaddr */ + case 29: /* B::OP::ppaddr */ { int i; ret = sv_2mortal(Perl_newSVpvf(aTHX_ "PL_ppaddr[OP_%s]", @@ -1083,16 +1083,16 @@ next(o) SvPVX(ret)[i] = toUPPER(SvPVX(ret)[i]); } break; - case 30: /* type */ - case 31: /* opt */ - case 32: /* spare */ + case 30: /* B::OP::type */ + case 31: /* B::OP::opt */ + case 32: /* B::OP::spare */ #if PERL_VERSION >= 17 - case 47: /* slabbed */ - case 48: /* savefree */ - case 49: /* static */ + case 47: /* B::OP::slabbed */ + case 48: /* B::OP::savefree */ + case 49: /* B::OP::static */ #if PERL_VERSION >= 19 - case 50: /* folded */ - case 51: /* lastsib */ + case 50: /* B::OP::folded */ + case 51: /* B::OP::lastsib */ #endif #endif /* These are all bitfields, so we can't take their addresses */ @@ -1106,7 +1106,7 @@ next(o) : ix == 51 ? o->op_lastsib : o->op_spare))); break; - case 33: /* children */ + case 33: /* B::LISTOP::children */ { OP *kid; UV i = 0; @@ -1115,7 +1115,7 @@ next(o) ret = sv_2mortal(newSVuv(i)); } break; - case 34: /* pmreplroot */ + case 34: /* B::PMOP::pmreplroot */ if (cPMOPo->op_type == OP_PUSHRE) { #ifdef USE_ITHREADS ret = sv_newmortal(); @@ -1134,16 +1134,16 @@ next(o) } break; #ifdef USE_ITHREADS - case 35: /* pmstashpv */ + case 35: /* B::PMOP::pmstashpv */ ret = sv_2mortal(newSVpv(PmopSTASHPV(cPMOPo),0)); break; #else - case 36: /* pmstash */ + case 36: /* B::PMOP::pmstash */ ret = make_sv_object(aTHX_ (SV *) PmopSTASH(cPMOPo)); break; #endif - case 37: /* precomp */ - case 38: /* reflags */ + case 37: /* B::PMOP::precomp */ + case 38: /* B::PMOP::reflags */ { REGEXP *rx = PM_GETRE(cPMOPo); ret = sv_newmortal(); @@ -1159,22 +1159,17 @@ next(o) } } break; - case 39: /* sv */ - case 40: /* gv */ - /* It happens that the output typemaps for B::SV and B::GV - * are identical. The "smarts" are in make_sv_object(), - * which determines which class to use based on SvTYPE(), - * rather than anything baked in at compile time. */ - if (cPADOPo->op_padix) { - ret = PAD_SVl(cPADOPo->op_padix); - if (ix == 40 && SvTYPE(ret) != SVt_PVGV) - ret = NULL; - } else { - ret = NULL; - } - ret = make_sv_object(aTHX_ ret); + case 39: /* B::PADOP::sv */ + case 40: /* B::PADOP::gv */ + /* PADOPs should only be created on threaded builds. + * They don't have an sv or gv field, just an op_padix + * field. Leave it to the caller to retrieve padix + * and look up th value in the pad. Don't do it here, + * becuase PL_curpad is the pad of the caller, not the + * pad of the sub the op is part of */ + ret = make_sv_object(aTHX_ NULL); break; - case 41: /* pv */ + case 41: /* B::PVOP::pv */ /* OP_TRANS uses op_pv to point to a table of 256 or >=258 * shorts whereas other PVOPs point to a null terminated * string. */ @@ -1193,24 +1188,24 @@ next(o) else ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP); break; - case 42: /* label */ + case 42: /* B::COP::label */ ret = sv_2mortal(newSVpv(CopLABEL(cCOPo),0)); break; - case 43: /* arybase */ + case 43: /* B::COP::arybase */ ret = sv_2mortal(newSVuv(0)); break; - case 44: /* warnings */ + case 44: /* B::COP::warnings */ ret = make_warnings_object(aTHX_ cCOPo); break; - case 45: /* io */ + case 45: /* B::COP::io */ ret = make_cop_io_object(aTHX_ cCOPo); break; - case 46: /* hints_hash */ + case 46: /* B::COP::hints_hash */ ret = sv_newmortal(); sv_setiv(newSVrv(ret, "B::RHE"), PTR2IV(CopHINTHASH_get(cCOPo))); break; - case 52: /* parent */ + case 52: /* B::OP::parent */ ret = make_op_object(aTHX_ op_parent(o)); break; default: diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index 6c818a4..b531ce8 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -14,7 +14,7 @@ use warnings; # uses #3 and #4, since warnings uses Carp use Exporter (); # use #5 -our $VERSION = "0.992"; +our $VERSION = "0.993"; our @ISA = qw(Exporter); our @EXPORT_OK = qw( set_style set_style_standard add_callback concise_subref concise_cv concise_main @@ -592,73 +592,13 @@ sub fmt_line { # generate text-line for op. return $text; # suppress empty lines } -our %priv; # used to display each opcode's BASEOP.op_private values - -$priv{$_}{128} = "LVINTRO" - for qw(pos substr vec threadsv gvsv rv2sv rv2hv rv2gv rv2av rv2arylen - aelem helem aslice hslice padsv padav padhv enteriter entersub - padrange pushmark); -$priv{$_}{64} = "REFC" for qw(leave leavesub leavesublv leavewrite); -$priv{$_}{128} = "LV" for qw(leave leaveloop); -@{$priv{aassign}}{32,64} = qw(STATE COMMON); -@{$priv{sassign}}{32,64,128} = qw(STATE BKWARD CV2GV); -$priv{$_}{64} = "RTIME" for qw(match subst substcont qr); -@{$priv{$_}}{1,2,4,8,16,64} = qw(UTF IDENT SQUASH DEL COMPL GROWS) - for qw(trans transr); -$priv{repeat}{64} = "DOLIST"; -$priv{leaveloop}{64} = "CONT"; -@{$priv{$_}}{32,64,96} = qw(DREFAV DREFHV DREFSV) - for qw(rv2gv rv2sv padsv aelem helem); -$priv{$_}{16} = "STATE" for qw(padav padhv padsv); -@{$priv{rv2gv}}{4,16} = qw(NOINIT FAKE); -@{$priv{entersub}}{1,4,16,32,64} = qw(INARGS TARG DBG DEREF); -@{$priv{rv2cv}}{1,8,128} = qw(CONST AMPER NO()); -$priv{gv}{32} = "EARLYCV"; -$priv{$_}{16} = "LVDEFER" for qw(aelem helem); -$priv{$_}{16} = "OURINTR" for qw(gvsv rv2sv rv2av rv2hv r2gv enteriter); -$priv{$_}{8} = "LVSUB" - for qw(rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice - av2arylen keys rkeys substr pos vec); -$priv{$_}{4} = "SLICEWARN" - for qw(rv2hv rv2av padav padhv hslice aslice); -@{$priv{$_}}{32,64} = qw(BOOL BOOL?) for qw(rv2hv padhv); -$priv{substr}{16} = "REPL1ST"; -$priv{$_}{16} = "TARGMY" - for map(($_,"s$_"), qw(chop chomp)), - map(($_,"i_$_"), qw(postinc postdec multiply divide modulo add - subtract negate)), - qw(pow concat stringify left_shift right_shift bit_and bit_xor - bit_or complement atan2 sin cos rand exp log sqrt int hex oct - abs length index rindex sprintf ord chr crypt quotemeta join - push unshift flock chdir chown chroot unlink chmod utime rename - link symlink mkdir rmdir wait waitpid system exec kill getppid - getpgrp setpgrp getpriority setpriority time sleep); -$priv{$_}{4} = "REVERSED" for qw(enteriter iter); -@{$priv{const}}{2,4,8,16,64} = qw(NOVER SHORT STRICT ENTERED BARE); -$priv{$_}{64} = "LINENUM" for qw(flip flop); -$priv{list}{64} = "GUESSED"; -$priv{delete}{64} = "SLICE"; -$priv{exists}{64} = "SUB"; -@{$priv{sort}}{1,2,4,8,16,32,64} = qw(NUM INT REV INPLACE DESC QSORT STABLE); -$priv{reverse}{8} = "INPLACE"; -$priv{threadsv}{64} = "SVREFd"; -@{$priv{$_}}{16,32,64,128} = qw(INBIN INCR OUTBIN OUTCR) - for qw(open backtick); -$priv{$_}{32} = "HUSH" for qw(nextstate dbstate); -$priv{$_}{2} = "FTACCESS" - for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec); -@{$priv{entereval}}{2,4,8,16} = qw(HAS_HH UNI BYTES COPHH); -@{$priv{$_}}{4,8,16} = qw(FTSTACKED FTSTACKING FTAFTERt) - for qw(ftrread ftrwrite ftrexec fteread ftewrite fteexec ftis fteowned - ftrowned ftzero ftsize ftmtime ftatime ftctime ftsock ftchr - ftblk ftfile ftdir ftpipe ftlink ftsuid ftsgid ftsvtx fttty - fttext ftbinary); -$priv{$_}{2} = "GREPLEX" - for qw(mapwhile mapstart grepwhile grepstart); -$priv{$_}{128} = "+1" for qw(caller wantarray runcv); -@{$priv{coreargs}}{1,2,64,128} = qw(DREF1 DREF2 $MOD MARK); -$priv{$_}{128} = "UTF" for qw(last redo next goto dump); -$priv{split}{128} = "IMPLIM"; + + +# use require rather than use here to avoid disturbing tests that dump +# BEGIN blocks +require B::Op_private; + + our %hints; # used to display each COP's op_hints values @@ -688,9 +628,61 @@ sub _flags { return join(",", @s); } +# return a string like 'LVINTRO,1' for the op $name with op_private +# value $x + sub private_flags { my($name, $x) = @_; - _flags($priv{$name}, $x); + my $entry = $B::Op_private::bits{$name}; + return $x ? "$x" : '' unless $entry; + + my @flags; + my $bit; + for ($bit = 7; $bit >= 0; $bit--) { + next unless exists $entry->{$bit}; + my $e = $entry->{$bit}; + if (ref($e) eq 'HASH') { + # bit field + + my ($bitmin, $bitmax, $bitmask, $enum, $label) = + @{$e}{qw(bitmin bitmax bitmask enum label)}; + $bit = $bitmin; + next if defined $label && $label eq '-'; # display as raw number + + my $val = $x & $bitmask; + $x &= ~$bitmask; + $val >>= $bitmin; + + if (defined $enum) { + # try to convert numeric $val into symbolic + my @enum = @$enum; + while (@enum) { + my $ix = shift @enum; + my $name = shift @enum; + my $label = shift @enum; + if ($val == $ix) { + $val = $label; + last; + } + } + } + next if $val eq '0'; # don't display anonymous zero values + push @flags, defined $label ? "$label=$val" : $val; + + } + else { + # flag bit + my $label = $B::Op_private::labels{$e}; + next if defined $label && $label eq '-'; # display as raw number + if ($x & (1<<$bit)) { + $x -= (1<<$bit); + push @flags, $label; + } + } + } + + push @flags, $x if $x; # display unknown bits numerically + return join ",", @flags; } sub hints_flags { @@ -779,18 +771,25 @@ sub concise_op { $h{class} = class($op); $h{extarg} = $h{targ} = $op->targ; $h{extarg} = "" unless $h{extarg}; + $h{privval} = $op->private; + $h{private} = private_flags($h{name}, $op->private); + if ($op->folded) { + $h{private} &&= "$h{private},"; + $h{private} .= "FOLD"; + } + if ($h{name} eq "null" and $h{targ}) { # targ holds the old type $h{exname} = "ex-" . substr(ppname($h{targ}), 3); $h{extarg} = ""; - } elsif ($op->name =~ /^leave(sub(lv)?|write)?$/) { - # targ potentially holds a reference count - if ($op->private & 64) { - my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); - $h{targarglife} = $h{targarg} = "$h{targ} $refs"; - } + } elsif ($h{private} =~ /\bREFC\b/) { + # targ holds a reference count + my $refs = "ref" . ($h{targ} != 1 ? "s" : ""); + $h{targarglife} = $h{targarg} = "$h{targ} $refs"; } elsif ($h{targ}) { - my $count = $h{name} eq 'padrange' ? ($op->private & 127) : 1; + my $count = $h{name} eq 'padrange' + ? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'}) + : 1; my (@targarg, @targarglife); for my $i (0..$count-1) { my ($targarg, $targarglife); @@ -916,12 +915,6 @@ sub concise_op { $h{classsym} = $opclass{$h{class}}; $h{flagval} = $op->flags; $h{flags} = op_flags($op->flags); - $h{privval} = $op->private; - $h{private} = private_flags($h{name}, $op->private); - if ($op->folded) { - $h{private} &&= "$h{private},"; - $h{private} .= "FOLD"; - } if ($op->can("hints")) { $h{hintsval} = $op->hints; $h{hints} = hints_flags($h{hintsval}); @@ -1413,10 +1406,7 @@ Private flags, if any are set for an opcode, are displayed after a '/' They're opcode specific, and occur less often than the public ones, so they're represented by short mnemonics instead of single-chars; see -F for gory details, or try this quick 2-liner: - - $> perl -MB::Concise -de 1 - DB<1> |x \%B::Concise::priv +B::Op_private and F for more details. =head1 FORMATTING SPECIFICATIONS diff --git a/ext/B/Makefile.PL b/ext/B/Makefile.PL index 8767b5e..308b015 100644 --- a/ext/B/Makefile.PL +++ b/ext/B/Makefile.PL @@ -32,6 +32,7 @@ foreach my $tuple (['cop.h'], ['cv.h', 'CVf'], ['gv.h', 'GVf'], ['op.h'], + ['opcode.h', 'OPp'], ['op_reg_common.h','(?:(?:RXf_)?PMf_)'], ['regexp.h','RXf_'], ['sv.h', 'SV(?:[fps]|pad)_'], diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 27b4105..271eb37 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -300,6 +300,8 @@ foo can_ok $f, 'LINES'; } +is B::safename("\cLAST_FH"), "^LAST_FH", 'basic safename test'; + my $sub1 = sub {die}; { no warnings 'once'; no strict; *Peel:: = *{"Pe\0e\x{142}::"} } my $sub2 = eval 'package Peel; sub {die}'; @@ -404,10 +406,10 @@ SKIP: my $cv = B::svref_2object(\&bar); ok($cv, "make a B::CV from a lexical sub reference"); isa_ok($cv, "B::CV"); - my $gv = $cv->GV; - isa_ok($gv, "B::SPECIAL", "GV on a lexical sub"); my $hek = $cv->NAME_HEK; is($hek, "bar", "check the NAME_HEK"); + my $gv = $cv->GV; + isa_ok($gv, "B::GV", "GV on a lexical sub"); } 1; EOS @@ -441,4 +443,42 @@ SKIP: { } +# make sure ->sv, -gv methods do the right thing on threaded builds +{ + + # for some reason B::walkoptree only likes a sub name, not a code ref + my ($gv, $sv); + sub gvsv_const { + # make the early pad slots something unlike a threaded const or + # gvsv + my ($dummy1, $dummy2, $dummy3, $dummy4) = qw(foo1 foo2 foo3 foo4); + my $self = shift; + if ($self->name eq 'gvsv') { + $gv = $self->gv; + } + elsif ($self->name eq 'const') { + $sv = $self->sv; + } + }; + + B::walkoptree(B::svref_2object(sub {our $x = 1})->ROOT, "::gvsv_const"); + ok(defined $gv, "gvsv->gv seen"); + ok(defined $sv, "const->sv seen"); + if ($Config::Config{useithreads}) { + # should get NULLs + is(ref($gv), "B::SPECIAL", "gvsv->gv is special"); + is(ref($sv), "B::SPECIAL", "const->sv is special"); + is($$gv, 0, "gvsv->gv special is 0 (NULL)"); + is($$sv, 0, "const->sv special is 0 (NULL)"); + } + else { + is(ref($gv), "B::GV", "gvsv->gv is GV"); + is(ref($sv), "B::IV", "const->sv is IV"); + pass(); + pass(); + } + +} + + done_testing(); diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t index ca82cbd..c2258f7 100644 --- a/ext/B/t/concise-xs.t +++ b/ext/B/t/concise-xs.t @@ -138,7 +138,7 @@ my $testpkgs = { perl => [qw( walksymtable walkoptree_slow walkoptree_exec timing_info savesym peekop parents objsym debug - compile_stats clearsym class + compile_stats clearsym class safename )], XS => [qw( warnhook walkoptree_debug walkoptree threadsv_names @@ -171,7 +171,7 @@ my $testpkgs = { PMf_MULTILINE PMf_ONCE PMf_SINGLELINE POSTFIX SVf_FAKE SVf_IOK SVf_NOK SVf_POK SVf_ROK SVpad_OUR SVs_RMG SVs_SMG SWAP_CHILDREN OPpPAD_STATE - OPpCONST_ARYBASE RXf_SKIPWHITE/, + OPpCONST_ARYBASE RXf_SKIPWHITE SVpad_TYPED/, $] >= 5.015 ? qw( OP_GLOB PMf_SKIPWHITE RXf_PMf_CHARSET RXf_PMf_KEEPCOPY OPpEVAL_BYTES OPpSUBSTR_REPL_FIRST) : (), @@ -190,6 +190,21 @@ my $testpkgs = { qw /WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WSTOPSIG WTERMSIG/, 'int_macro_int', # Removed in POSIX 1.16 + + 'strtold', # platform varying (C99) + + qw/fegetround fesetround/, + + # C99 math + qw/acosh asinh atanh cbrt copysign cosh erf + erfc exp2 expm1 fdim fma fmax fmin fpclassify + hypot ilogb isfinite isgreater isgreaterequal + isinf isless islessequal islessgreater isnan + isnormal isunordered j0 j1 jn lgamma log1p + log2 logb lrint lround nan nearbyint nextafter + nexttoward remainder remquo rint round scalbn + signbit sinh tanh tgamma trunc y0 y1 yn/, + ], perl => [qw/ import croak AUTOLOAD /, $] >= 5.015 diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index a7a9c26..88b871c 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -170,7 +170,7 @@ checkOptree(note => q{}, # c <1> rv2av[t6] sKRM/1 # d <#> gv[*_] s # e <1> rv2gv sKRM/1 -# f <{> enteriter(next->q last->t redo->g) lKS/8 +# f <{> enteriter(next->q last->t redo->g) lKS/DEF # r <0> iter s # s <|> and(other->g) K/1 # g <;> nextstate(main 475 (eval 10):1) v:{ @@ -204,7 +204,7 @@ EOT_EOT # c <1> rv2av[t3] sKRM/1 # d <$> gv(*_) s # e <1> rv2gv sKRM/1 -# f <{> enteriter(next->q last->t redo->g) lKS/8 +# f <{> enteriter(next->q last->t redo->g) lKS/DEF # r <0> iter s # s <|> and(other->g) K/1 # g <;> nextstate(main 559 (eval 15):1) v:{ diff --git a/ext/B/t/optree_concise.t b/ext/B/t/optree_concise.t index aa28ebb..f9a2729 100644 --- a/ext/B/t/optree_concise.t +++ b/ext/B/t/optree_concise.t @@ -264,7 +264,7 @@ checkOptree ( name => 'cmdline self-strict compile err using prog', prog => 'use strict; sort @a', bcopts => [qw/ -basic -concise -exec /], - errs => 'Global symbol "@a" requires explicit package name at -e line 1.', + errs => 'Global symbol "@a" requires explicit package name (did you forget to declare "my @a"?) at -e line 1.', expect => 'nextstate', expect_nt => 'nextstate', noanchors => 1, # allow simple expectations to work @@ -274,7 +274,9 @@ checkOptree ( name => 'cmdline self-strict compile err using code', code => 'use strict; sort @a', bcopts => [qw/ -basic -concise -exec /], - errs => qr/Global symbol "\@a" requires explicit package name at .*? line 1\./, + errs => qr/Global symbol "\@a" requires explicit package (?x: + )name \(did you forget to declare "my \@a"\?\) at (?x: + ).*? line 1\./, note => 'this test relys on a kludge which copies $@ to rendering when empty', expect => 'Global symbol', expect_nt => 'Global symbol', diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 2a9c010..61b0d18 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -240,7 +240,7 @@ checkOptree ( name => '-exec sub { foreach (1..10) {print "foo $_"} }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->d last->g redo->7) lKS/8 +# 6 <{> enteriter(next->d last->g redo->7) lKS/DEF # e <0> iter s # f <|> and(other->7) K/1 # 7 <;> nextstate(main 442 optree.t:158) v:>,<,% @@ -259,7 +259,7 @@ EOT_EOT # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->d last->g redo->7) lKS/8 +# 6 <{> enteriter(next->d last->g redo->7) lKS/DEF # e <0> iter s # f <|> and(other->7) K/1 # 7 <;> nextstate(main 443 optree_samples.t:182) v:>,<,% @@ -283,7 +283,7 @@ checkOptree ( name => '-basic sub { print "foo $_" foreach (1..10) }', # - <@> lineseq KP ->g # 1 <;> nextstate(main 445 optree.t:167) v:>,<,% ->2 # f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d +# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF ->d # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 @@ -308,7 +308,7 @@ EOT_EOT # - <@> lineseq KP ->g # 1 <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2 # f <2> leaveloop K/2 ->g -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 ->d +# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF ->d # - <0> ex-pushmark s ->2 # - <1> ex-list lK ->5 # 2 <0> pushmark s ->3 @@ -341,7 +341,7 @@ checkOptree ( name => '-exec -e foreach (1..10) {print qq{foo $_}}', # 4 <$> const[IV 1] s # 5 <$> const[IV 10] s # 6 <#> gv[*_] s -# 7 <{> enteriter(next->e last->h redo->8) lKS/8 +# 7 <{> enteriter(next->e last->h redo->8) lKS/DEF # f <0> iter s # g <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% @@ -361,7 +361,7 @@ EOT_EOT # 4 <$> const(IV 1) s # 5 <$> const(IV 10) s # 6 <$> gv(*_) s -# 7 <{> enteriter(next->e last->h redo->8) lKS/8 +# 7 <{> enteriter(next->e last->h redo->8) lKS/DEF # f <0> iter s # g <|> and(other->8) vK/1 # 8 <;> nextstate(main 1 -e:1) v:>,<,% @@ -386,7 +386,7 @@ checkOptree ( name => '-exec sub { print "foo $_" foreach (1..10) }', # 3 <$> const[IV 1] s # 4 <$> const[IV 10] s # 5 <#> gv[*_] s -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 +# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF # d <0> iter s # e <|> and(other->7) K/1 # 7 <0> pushmark s @@ -404,7 +404,7 @@ EOT_EOT # 3 <$> const(IV 1) s # 4 <$> const(IV 10) s # 5 <$> gv(*_) s -# 6 <{> enteriter(next->c last->f redo->7) lKS/8 +# 6 <{> enteriter(next->c last->f redo->7) lKS/DEF # d <0> iter s # e <|> and(other->7) K/1 # 7 <0> pushmark s @@ -530,7 +530,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # a <1> rv2av[t6] sKRM/1 # b <#> gv[*_] s # c <1> rv2gv sKRM/1 -# d <{> enteriter(next->o last->r redo->e) lKS/8 +# d <{> enteriter(next->o last->r redo->e) lKS/DEF # p <0> iter s # q <|> and(other->e) K/1 # e <;> nextstate(main 505 (eval 24):1) v:{ @@ -561,7 +561,7 @@ EOT_EOT # a <1> rv2av[t3] sKRM/1 # b <$> gv(*_) s # c <1> rv2gv sKRM/1 -# d <{> enteriter(next->o last->r redo->e) lKS/8 +# d <{> enteriter(next->o last->r redo->e) lKS/DEF # p <0> iter s # q <|> and(other->e) K/1 # e <;> nextstate(main 505 (eval 24):1) v:{ diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t index 3cf354c..414fa79 100644 --- a/ext/B/t/optree_specials.t +++ b/ext/B/t/optree_specials.t @@ -48,7 +48,7 @@ checkOptree ( name => 'BEGIN', # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/TARG,STRICT ->a # 5 <0> pushmark s ->6 # 6 <$> const[PV "strict"] sM ->7 # 7 <$> const[PV "refs"] sM ->8 @@ -62,7 +62,7 @@ checkOptree ( name => 'BEGIN', # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/TARG,STRICT ->k # f <0> pushmark s ->g # g <$> const[PV "strict"] sM ->h # h <$> const[PV "refs"] sM ->i @@ -76,7 +76,7 @@ checkOptree ( name => 'BEGIN', # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/TARG,STRICT ->u # p <0> pushmark s ->q # q <$> const[PV "warnings"] sM ->r # r <$> const[PV "qw"] sM ->s @@ -98,7 +98,7 @@ EOT_EOT # 4 <;> nextstate(B::Concise -275 Concise.pm:356) v:*,&,{,x*,x&,x$,$ ->5 # - <@> lineseq K ->- # - <0> null ->5 -# 9 <1> entersub[t1] KS*/TARG,2 ->a +# 9 <1> entersub[t1] KS*/TARG,STRICT ->a # 5 <0> pushmark s ->6 # 6 <$> const(PV "strict") sM ->7 # 7 <$> const(PV "refs") sM ->8 @@ -112,7 +112,7 @@ EOT_EOT # e <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ ->f # - <@> lineseq K ->- # - <0> null ->f -# j <1> entersub[t1] KS*/TARG,2 ->k +# j <1> entersub[t1] KS*/TARG,STRICT ->k # f <0> pushmark s ->g # g <$> const(PV "strict") sM ->h # h <$> const(PV "refs") sM ->i @@ -126,7 +126,7 @@ EOT_EOT # o <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ ->p # - <@> lineseq K ->- # - <0> null ->p -# t <1> entersub[t1] KS*/TARG,2 ->u +# t <1> entersub[t1] KS*/TARG,STRICT ->u # p <0> pushmark s ->q # q <$> const(PV "warnings") sM ->r # r <$> const(PV "qw") sM ->s @@ -246,7 +246,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ @@ -257,7 +257,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ @@ -268,7 +268,7 @@ checkOptree ( name => 'all of BEGIN END INIT CHECK UNITCHECK -exec', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -305,7 +305,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ @@ -316,7 +316,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ @@ -327,7 +327,7 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 # BEGIN 4: # v <;> nextstate(main 2 -e:1) v:>,<,%,{ @@ -374,7 +374,7 @@ checkOptree ( name => 'regression test for patch 25352', # 6 <$> const[PV "strict"] sM # 7 <$> const[PV "refs"] sM # 8 <$> method_named[PV "unimport"] -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ @@ -385,7 +385,7 @@ checkOptree ( name => 'regression test for patch 25352', # g <$> const[PV "strict"] sM # h <$> const[PV "refs"] sM # i <$> method_named[PV "unimport"] -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ @@ -396,7 +396,7 @@ checkOptree ( name => 'regression test for patch 25352', # q <$> const[PV "warnings"] sM # r <$> const[PV "qw"] sM # s <$> method_named[PV "unimport"] -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 EOT_EOT # BEGIN 1: @@ -408,7 +408,7 @@ EOT_EOT # 6 <$> const(PV "strict") sM # 7 <$> const(PV "refs") sM # 8 <$> method_named(PV "unimport") -# 9 <1> entersub[t1] KS*/TARG,2 +# 9 <1> entersub[t1] KS*/TARG,STRICT # a <1> leavesub[1 ref] K/REFC,1 # BEGIN 2: # b <;> nextstate(B::Concise -265 Concise.pm:367) v:*,&,x*,x&,x$,$ @@ -419,7 +419,7 @@ EOT_EOT # g <$> const(PV "strict") sM # h <$> const(PV "refs") sM # i <$> method_named(PV "unimport") -# j <1> entersub[t1] KS*/TARG,2 +# j <1> entersub[t1] KS*/TARG,STRICT # k <1> leavesub[1 ref] K/REFC,1 # BEGIN 3: # l <;> nextstate(B::Concise -254 Concise.pm:386) v:*,&,{,x*,x&,x$,$ @@ -430,6 +430,6 @@ EOT_EOT # q <$> const(PV "warnings") sM # r <$> const(PV "qw") sM # s <$> method_named(PV "unimport") -# t <1> entersub[t1] KS*/TARG,2 +# t <1> entersub[t1] KS*/TARG,STRICT # u <1> leavesub[1 ref] K/REFC,1 EONT_EONT diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 0cc6717..34c654c 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -331,8 +331,8 @@ do_test('reference to named subroutine without prototype', RV = $ADDR SV = PVCV\\($ADDR\\) at $ADDR REFCNT = (3|4) - FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr - FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr + FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr + FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 COMP_STASH = $ADDR\\t"main" @@ -340,13 +340,14 @@ do_test('reference to named subroutine without prototype', ROOT = $ADDR XSUB = 0x0 # $] < 5.009 XSUBANY = 0 # $] < 5.009 - GVGV::GV = $ADDR\\t"main" :: "do_test" + NAME = "do_test" # $] >=5.021004 + GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004 FILE = ".*\\b(?i:peek\\.t)" DEPTH = 1(?: MUTEXP = $ADDR OWNER = $ADDR)? - FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr - FLAGS = 0x[145]000 # $] >= 5.015 && thr + FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr + FLAGS = 0x[cd145]000 # $] >= 5.015 && thr OUTSIDE_SEQ = \\d+ PADLIST = $ADDR PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) @@ -492,6 +493,7 @@ do_test('typeglob', NAME = "a" NAMELEN = 1 GvSTASH = $ADDR\\t"main" + FLAGS = $ADDR # $] >=5.021004 GP = $ADDR SV = $ADDR REFCNT = 1 @@ -502,9 +504,10 @@ do_test('typeglob', CV = 0x0 CVGEN = 0x0 GPFLAGS = 0x0 # $] < 5.009 + GPFLAGS = 0x0 \(\) # $] >= 5.021004 LINE = \\d+ FILE = ".*\\b(?i:peek\\.t)" - FLAGS = $ADDR + FLAGS = $ADDR # $] < 5.021004 EGV = $ADDR\\t"a"'); if (ord('A') == 193) { @@ -698,7 +701,8 @@ do_test('constant subroutine', IV = 0 # $] < 5.009 NV = 0 # $] < 5.009 PROTOTYPE = "" - COMP_STASH = 0x0 + COMP_STASH = 0x0 # $] < 5.021004 + COMP_STASH = $ADDR "main" # $] >=5.021004 ROOT = 0x0 # $] < 5.009 XSUB = $ADDR XSUBANY = $ADDR \\(CONST SV\\) @@ -1474,6 +1478,7 @@ for my $test ( } +my $runperl_args = { switches => ['-Ilib'] }; sub test_DumpProg { my ($prog, $expected, $name, $test) = @_; $test ||= 'like'; @@ -1487,10 +1492,10 @@ sub test_DumpProg { utf8::encode($prog); if ( $test eq 'is' ) { - t::fresh_perl_is($prog . $u, $expected, undef, $name) + t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name) } else { - t::fresh_perl_like($prog . $u, $expected, undef, $name) + t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name) } $builder->current_test(t::curr_test() - 1); @@ -1528,7 +1533,7 @@ dumpindent is 4 at - line 1. 1 TYPE = leave ===> NULL TARG = 1 FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB) - PRIVATE = (REFCOUNTED) + PRIVATE = (REFC) REFCNT = 1 { 2 TYPE = enter ===> 3 @@ -1542,9 +1547,9 @@ dumpindent is 4 at - line 1. } { 5 TYPE = entersub ===> 1 - TARG = TARGS_REPLACE + TARG = 1 FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB) - PRIVATE = (HASTARG) + PRIVATE = (TARG) { 6 TYPE = null ===> (5) (was list) @@ -1557,6 +1562,7 @@ dumpindent is 4 at - line 1. 8 TYPE = null ===> (6) (was rv2cv) FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB) + PRIVATE = (0x1) { 7 TYPE = gv ===> 5 FLAGS = (SCALAR,SLABBED,LASTSIB) @@ -1568,8 +1574,8 @@ dumpindent is 4 at - line 1. } EODUMP -$e =~ s/TARGS_REPLACE/$threads ? 3 : 1/e; $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e; +$e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004; test_DumpProg("package t;", $e, "DumpProg() has no 'Attempt to free X prematurely' warning", "is" ); diff --git a/ext/File-Find/lib/File/Find.pm b/ext/File-Find/lib/File/Find.pm index 6cfdb59..61eb3da 100644 --- a/ext/File-Find/lib/File/Find.pm +++ b/ext/File-Find/lib/File/Find.pm @@ -3,7 +3,7 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.27'; +our $VERSION = '1.28'; require Exporter; require Cwd; @@ -1055,21 +1055,42 @@ sub _find_dir_symlnk($$$) { sub wrap_wanted { my $wanted = shift; if ( ref($wanted) eq 'HASH' ) { + # RT #122547 + my %valid_options = map {$_ => 1} qw( + wanted + bydepth + preprocess + postprocess + follow + follow_fast + follow_skip + dangling_symlinks + no_chdir + untaint + untaint_pattern + untaint_skip + ); + my @invalid_options = (); + for my $v (keys %{$wanted}) { + push @invalid_options, $v unless exists $valid_options{$v}; + } + warn "Invalid option(s): @invalid_options" if @invalid_options; + unless( exists $wanted->{wanted} and ref( $wanted->{wanted} ) eq 'CODE' ) { die 'no &wanted subroutine given'; } - if ( $wanted->{follow} || $wanted->{follow_fast}) { - $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; - } - if ( $wanted->{untaint} ) { - $wanted->{untaint_pattern} = $File::Find::untaint_pattern - unless defined $wanted->{untaint_pattern}; - $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; - } - return $wanted; + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = $File::Find::untaint_pattern + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; } elsif( ref( $wanted ) eq 'CODE' ) { - return { wanted => $wanted }; + return { wanted => $wanted }; } else { die 'no &wanted subroutine given'; diff --git a/ext/File-Find/t/find.t b/ext/File-Find/t/find.t index 4b52f1e..390f39d 100644 --- a/ext/File-Find/t/find.t +++ b/ext/File-Find/t/find.t @@ -24,7 +24,7 @@ BEGIN { } my $symlink_exists = eval { symlink("",""); 1 }; -my $test_count = 102; +my $test_count = 109; $test_count += 127 if $symlink_exists; $test_count += 26 if $^O eq 'MSWin32'; $test_count += 2 if $^O eq 'MSWin32' and $symlink_exists; @@ -80,6 +80,46 @@ finddepth({wanted => sub { ++$::count_taint if $_ eq 'taint.t'; } }, File::Spec->curdir); is($::count_taint, 1, "'finddepth' found exactly 1 file named 'taint.t'"); +##### RT #122547 ##### +# Do find() and finddepth() correctly warn on invalid options? +{ + my $bad_option = 'foobar'; + my $second_bad_option = 'really_foobar'; + + $::count_taint = 0; + local $SIG{__WARN__} = sub { $warn_msg = $_[0]; }; + { + find( + { + wanted => sub { ++$::count_taint if $_ eq 'taint.t'; }, + $bad_option => undef, + }, + File::Spec->curdir + ); + }; + like($warn_msg, qr/Invalid option/s, "Got warning for invalid option"); + like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option"); + is($::count_taint, 1, "count_taint incremented"); + undef $warn_msg; + + $::count_taint = 0; + { + finddepth( + { + wanted => sub { ++$::count_taint if $_ eq 'taint.t'; }, + $bad_option => undef, + $second_bad_option => undef, + }, + File::Spec->curdir + ); + }; + like($warn_msg, qr/Invalid option/s, "Got warning for invalid option"); + like($warn_msg, qr/$bad_option/s, "Got warning for $bad_option"); + like($warn_msg, qr/$second_bad_option/s, "Got warning for $second_bad_option"); + is($::count_taint, 1, "count_taint incremented"); + undef $warn_msg; +} + my $FastFileTests_OK = 0; sub cleanup { diff --git a/ext/POSIX/Makefile.PL b/ext/POSIX/Makefile.PL index 77ebae7..5a24a34 100644 --- a/ext/POSIX/Makefile.PL +++ b/ext/POSIX/Makefile.PL @@ -12,11 +12,17 @@ if ($Config{sig_name} =~ /\bRTMIN\b/ && $Config{sig_name} =~ /\bRTMAX\b/) { my @libs; if ($^O ne 'MSWin32' && $^O ne 'freemint') { - @libs = ('LIBS' => ["-lm -lposix -lcposix"]); + push @libs, qw(m posix cposix); +} +if ($^O eq 'solaris') { + push @libs, qw(sunmath); +} +if ($^O eq 'aix' && $Config{uselongdouble}) { + push @libs, qw(c128); } WriteMakefile( NAME => 'POSIX', - @libs, + @libs ? ( 'LIBS' => [ join(" ", map { "-l$_" } @libs) ] ) : (), XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'lib/POSIX.pm', ABSTRACT_FROM => 'lib/POSIX.pod', @@ -88,6 +94,12 @@ END #endif '}); +push @names, + {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1}, + {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1}, + {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1}, + {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1}; + push @names, {name=>$_, type=>"UV"} foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART SA_SIGINFO UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX)); @@ -101,6 +113,14 @@ push @names, {name=>$_, type=>"NV"} FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX LDBL_DIG LDBL_MANT_DIG LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN_10_EXP LDBL_MIN_EXP)); +push @names, {name=>$_, type=>"NV"} + foreach (qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL + FP_SUBNORMAL FP_ZERO M_1_PI M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 + M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2)); + +push @names, {name=>$_, type=>"IV"} + foreach (qw(FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD)); + push @names, {name=>$_, type=>"IV", default=>["IV", "0"]} foreach (qw(_POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT _POSIX_NAME_MAX diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index e3dac9b..dcda631 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -34,6 +34,9 @@ #ifdef I_FLOAT #include #endif +#ifdef I_FENV +#include +#endif #ifdef I_LIMITS #include #endif @@ -54,6 +57,875 @@ #include #endif +#if defined(USE_QUADMATH) && defined(I_QUADMATH) + +# undef M_E +# undef M_LOG2E +# undef M_LOG10E +# undef M_LN2 +# undef M_LN10 +# undef M_PI +# undef M_PI_2 +# undef M_PI_4 +# undef M_1_PI +# undef M_2_PI +# undef M_2_SQRTPI +# undef M_SQRT2 +# undef M_SQRT1_2 + +# define M_E M_Eq +# define M_LOG2E M_LOG2Eq +# define M_LOG10E M_LOG10Eq +# define M_LN2 M_LN2q +# define M_LN10 M_LN10q +# define M_PI M_PIq +# define M_PI_2 M_PI_2q +# define M_PI_4 M_PI_4q +# define M_1_PI M_1_PIq +# define M_2_PI M_2_PIq +# define M_2_SQRTPI M_2_SQRTPIq +# define M_SQRT2 M_SQRT2q +# define M_SQRT1_2 M_SQRT1_2q + +#else + +# ifndef M_E +# define M_E 2.71828182845904523536028747135266250 +# endif +# ifndef M_LOG2E +# define M_LOG2E 1.44269504088896340735992468100189214 +# endif +# ifndef M_LOG10E +# define M_LOG10E 0.434294481903251827651128918916605082 +# endif +# ifndef M_LN2 +# define M_LN2 0.693147180559945309417232121458176568 +# endif +# ifndef M_LN10 +# define M_LN10 2.30258509299404568401799145468436421 +# endif +# ifndef M_PI +# define M_PI 3.14159265358979323846264338327950288 +# endif +# ifndef M_PI_2 +# define M_PI_2 1.57079632679489661923132169163975144 +# endif +# ifndef M_PI_4 +# define M_PI_4 0.785398163397448309615660845819875721 +# endif +# ifndef M_1_PI +# define M_1_PI 0.318309886183790671537767526745028724 +# endif +# ifndef M_2_PI +# define M_2_PI 0.636619772367581343075535053490057448 +# endif +# ifndef M_2_SQRTPI +# define M_2_SQRTPI 1.12837916709551257389615890312154517 +# endif +# ifndef M_SQRT2 +# define M_SQRT2 1.41421356237309504880168872420969808 +# endif +# ifndef M_SQRT1_2 +# define M_SQRT1_2 0.707106781186547524400844362104849039 +# endif + +#endif + +#if !defined(INFINITY) && defined(NV_INF) +# define INFINITY NV_INF +#endif + +#if !defined(NAN) && defined(NV_NAN) +# define NAN NV_NAN +#endif + +#if !defined(Inf) && defined(NV_INF) +# define Inf NV_INF +#endif + +#if !defined(NaN) && defined(NV_NAN) +# define NaN NV_NAN +#endif + +/* We will have an emulation. */ +#ifndef FP_INFINITE +# define FP_INFINITE 0 +# define FP_NAN 1 +# define FP_NORMAL 2 +# define FP_SUBNORMAL 3 +# define FP_ZERO 4 +#endif + +/* We will have an emulation. */ +#ifndef FE_TONEAREST +# define FE_TONEAREST 0 +# define FE_TOWARDZERO 1 +# define FE_DOWNWARD 2 +# define FE_UPWARD 3 +#endif + +/* C89 math.h: + + acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp + log log10 modf pow sin sinh sqrt tan tanh + + * Implemented in core: + + atan2 cos exp log pow sin sqrt + + * C99 math.h added: + + acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax + fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf + isless islessequal islessgreater isnan isnormal isunordered lgamma + log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder + remquo rint round scalbn signbit tgamma trunc + + See: + http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html + + * Berkeley/SVID extensions: + + j0 j1 jn y0 y1 yn + + * Configure already (5.21.0) scans for: + + fpclassify isfinite isinf isnan ilogb*l* signbit + + * For floating-point round mode (which matters for e.g. lrint and rint) + + fegetround fesetround + +*/ + +/* XXX Constant FP_FAST_FMA (if true, FMA is faster) */ + +/* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */ + +/* XXX Beware old gamma() -- one cannot know whether that is the + * gamma or the log of gamma, that's why the new tgamma and lgamma. + * Though also remember tgamma_r and lgamma_r. */ + +/* XXX The truthiness of acosh() is the canary for all of the + * C99 math. This is very likely wrong, especially in non-UNIX lands + * like Win32 and VMS, but also older UNIXes have issues. For Win32, + * and other non-fully-C99, we later do some undefines for these interfaces. + * + * But we are very trying very hard to avoid introducing separate Configure + * symbols for all the 40-ish new math symbols. Especially since the set + * of missing functions doesn't seem to follow any patterns. */ + +#ifdef HAS_ACOSH + +/* Certain AIX releases have the C99 math, but not in long double. + * The has them, e.g. __expl128, but no library has them! + * + * See the comments in hints/aix.sh about long doubles. + * + * AIX 5 releases before 5.3 unknown, AIX releases 7 unknown */ +# if defined(_AIX53) || defined(_AIX61) +# define NO_C99_LONG_DOUBLE_MATH +# endif + +# if defined(USE_QUADMATH) && defined(I_QUADMATH) +# define c99_acosh acoshq +# define c99_asinh asinhq +# define c99_atanh atanhq +# define c99_cbrt cbrtq +# define c99_copysign copysignq +# define c99_erf erfq +# define c99_erfc erfcq +/* no exp2q */ +# define c99_expm1 expm1q +# define c99_fdim fdimq +# define c99_fma fmaq +# define c99_fmax fmaxq +# define c99_fmin fminq +# define c99_hypot hypotq +# define c99_ilogb ilogbq +# define c99_lgamma lgammaq +# define c99_log1p log1pq +# define c99_log2 log2q +/* no logbq */ +/* no llrintq */ +/* no llroundq */ +# define c99_lrint lrintq +# define c99_lround lroundq +# define c99_nan nanq +# define c99_nearbyint nearbyintq +# define c99_nextafter nextafterq +/* no nexttowardq */ +# define c99_remainder remainderq +# define c99_remquo remquoq +# define c99_rint rintq +# define c99_round roundq +# define c99_scalbn scalbnq +# define c99_signbit signbitq +# define c99_tgamma tgammal +# define c99_trunc truncq +# define bessel_j0 j0q +# define bessel_j1 j1q +# define bessel_jn jnq +# define bessel_y0 y0q +# define bessel_y1 y1q +# define bessel_yn ynq +# elif defined(USE_LONG_DOUBLE) && \ + !defined(NO_C99_LONG_DOUBLE_MATH) && \ + defined(HAS_ILOGBL) +/* There's already a symbol for ilogbl, we will use its truthiness + * as the canary for all the *l variants being defined. */ +# define c99_acosh acoshl +# define c99_asinh asinhl +# define c99_atanh atanhl +# define c99_cbrt cbrtl +# define c99_copysign copysignl +# define c99_erf erfl +# define c99_erfc erfcl +# define c99_exp2 exp2l +# define c99_expm1 expm1l +# define c99_fdim fdiml +# define c99_fma fmal +# define c99_fmax fmaxl +# define c99_fmin fminl +# define c99_hypot hypotl +# define c99_ilogb ilogbl +# define c99_lgamma lgammal +# define c99_log1p log1pl +# define c99_log2 log2l +# define c99_logb logbl +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lrint llrintl +# else +# define c99_lrint lrintl +# endif +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lround llroundl +# else +# define c99_lround lroundl +# endif +# define c99_nan nanl +# define c99_nearbyint nearbyintl +# define c99_nextafter nextafterl +# define c99_nexttoward nexttowardl +# define c99_remainder remainderl +# define c99_remquo remquol +# define c99_rint rintl +# define c99_round roundl +# define c99_scalbn scalbnl +# ifdef HAS_SIGNBIT /* possibly bad assumption */ +# define c99_signbit signbitl +# endif +# define c99_tgamma tgammal +# define c99_trunc truncl +# else +# define c99_acosh acosh +# define c99_asinh asinh +# define c99_atanh atanh +# define c99_cbrt cbrt +# define c99_copysign copysign +# define c99_erf erf +# define c99_erfc erfc +# define c99_exp2 exp2 +# define c99_expm1 expm1 +# define c99_fdim fdim +# define c99_fma fma +# define c99_fmax fmax +# define c99_fmin fmin +# define c99_hypot hypot +# define c99_ilogb ilogb +# define c99_lgamma lgamma +# define c99_log1p log1p +# define c99_log2 log2 +# define c99_logb logb +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lrint llrint +# else +# define c99_lrint lrint +# endif +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lround llround +# else +# define c99_lround lround +# endif +# define c99_nan nan +# define c99_nearbyint nearbyint +# define c99_nextafter nextafter +# define c99_nexttoward nexttoward +# define c99_remainder remainder +# define c99_remquo remquo +# define c99_rint rint +# define c99_round round +# define c99_scalbn scalbn +/* We already define Perl_signbit in perl.h. */ +# ifdef HAS_SIGNBIT +# define c99_signbit signbit +# endif +# define c99_tgamma tgamma +# define c99_trunc trunc +# endif + +# ifndef isunordered +# ifdef Perl_isnan +# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y)) +# elif defined(HAS_UNORDERED) +# define isunordered(x, y) unordered(x, y) +# endif +# endif + +# if !defined(isgreater) && defined(isunordered) +# define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y)) +# define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y)) +# define isless(x, y) (!isunordered((x), (y)) && (x) < (y)) +# define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y)) +# define islessgreater(x, y) (!isunordered((x), (y)) && \ + ((x) > (y) || (y) > (x))) +# endif + +/* Check both the Configure symbol and the macro-ness (like C99 promises). */ +# if defined(HAS_FPCLASSIFY) && defined(fpclassify) +# define c99_fpclassify fpclassify +# endif +/* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99 + and also (sizeof-arg-aware) macros, but they are already well taken + care of by Configure et al, and defined in perl.h as + Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */ +# ifdef isnormal +# define c99_isnormal isnormal +# endif +# ifdef isgreater /* canary for all the C99 is** macros. */ +# define c99_isgreater isgreater +# define c99_isgreaterequal isgreaterequal +# define c99_isless isless +# define c99_islessequal islessequal +# define c99_islessgreater islessgreater +# define c99_isunordered isunordered +# endif +#endif + +/* If on legacy platforms, and not using gcc, some C99 math interfaces + * might be missing, turn them off so that the emulations hopefully + * kick in. This is admittedly nasty, and fragile, but the alternative + * is to have Configure scans for all the 40+ interfaces. + * + * For some platforms, also the gcc implementations are missing + * certain interfaces. + * + * In other words: if you have an incomplete (or broken) C99 math interface, + * #undef the c99_foo here, and let the emulations kick in. */ + +#ifdef __GNUC__ + +/* using gcc */ + +# if defined(__hpux) && (defined(__hppa) || defined(_PA_RISC)) +# undef c99_nexttoward +# undef c99_tgamma +# endif + +#else + +/* not using gcc */ + +# if defined(_AIX53) || defined(_AIX61) /* AIX 7 has nexttoward */ +# undef c99_nexttoward +# endif + +/* HP-UX on PA-RISC is missing certain C99 math functions, + * but on IA64 (Integrity) these do exist, and even on + * recent enough HP-UX (cc) releases. */ +# if defined(__hpux) && (defined(__hppa) || defined(_PA_RISC)) +/* lowest known release, could be lower */ +# if defined(__HP_cc) && __HP_cc >= 111120 +# undef c99_fma +# undef c99_nexttoward +# undef c99_tgamma +# else +# undef c99_exp2 +# undef c99_fdim +# undef c99_fma +# undef c99_fmax +# undef c99_fmin +# undef c99_fpclassify /* hpux 10.20 has fpclassify but different api */ +# undef c99_lrint +# undef c99_lround +# undef c99_nan +# undef c99_nearbyint +# undef c99_nexttoward +# undef c99_remquo +# undef c99_round +# undef c99_scalbn +# undef c99_tgamma +# undef c99_trunc +# endif +# endif + +# if defined(__irix__) +# undef c99_ilogb +# undef c99_exp2 +# endif + +# if defined(__osf__) /* Tru64 */ +# undef c99_fdim +# undef c99_fma +# undef c99_fmax +# undef c99_fmin +# undef c99_fpclassify +# undef c99_isfinite +# undef c99_isinf +# undef c99_isunordered +# undef c99_lrint +# undef c99_lround +# undef c99_nearbyint +# undef c99_nexttoward +# undef c99_remquo +# undef c99_round +# undef c99_scalbn +# endif + +#endif + +/* XXX Regarding C99 math.h, VMS seems to be missing these: + + lround nan nearbyint round scalbn llrint + */ + +#ifdef __VMS +# undef c99_lround +# undef c99_nan +# undef c99_nearbyint +# undef c99_round +# undef c99_scalbn +/* Have lrint but not llrint. */ +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# undef c99_lrint +# endif +#endif + +/* XXX Regarding C99 math.h, Win32 seems to be missing these: + + erf erfc exp2 fdim fma fmax fmin fpclassify ilogb lgamma log1p log2 lrint + remquo rint signbit tgamma trunc + + Win32 does seem to have these: + + acosh asinh atanh cbrt copysign cosh expm1 hypot log10 nan + nearbyint nextafter nexttoward remainder round scalbn + + And the Bessel functions are defined like _this. +*/ + +#ifdef WIN32 +# undef c99_erf +# undef c99_erfc +# undef c99_exp2 +# undef c99_fdim +# undef c99_fma +# undef c99_fmax +# undef c99_fmin +# undef c99_ilogb +# undef c99_lgamma +# undef c99_log1p +# undef c99_log2 +# undef c99_lrint +# undef c99_lround +# undef c99_remquo +# undef c99_rint +# undef c99_signbit +# undef c99_tgamma +# undef c99_trunc + +/* Some APIs exist under Win32 with "underbar" names. */ +# undef c99_hypot +# undef c99_logb +# undef c99_nextafter +# define c99_hypot _hypot +# define c99_logb _logb +# define c99_nextafter _nextafter + +# define bessel_j0 _j0 +# define bessel_j1 _j1 +# define bessel_jn _jn +# define bessel_y0 _y0 +# define bessel_y1 _y1 +# define bessel_yn _yn + +#endif + +#ifdef __CYGWIN__ +# undef c99_nexttoward +#endif + +/* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */ +#if defined(HAS_J0) && !defined(bessel_j0) +# if defined(USE_LONG_DOUBLE) && defined(HAS_J0L) +# define bessel_j0 j0l +# define bessel_j1 j1l +# define bessel_jn jnl +# define bessel_y0 y0l +# define bessel_y1 y1l +# define bessel_yn ynl +# else +# define bessel_j0 j0 +# define bessel_j1 j1 +# define bessel_jn jn +# define bessel_y0 y0 +# define bessel_y1 y1 +# define bessel_yn yn +# endif +#endif + +/* Emulations for missing math APIs. + * + * Keep in mind that the point of many of these functions is that + * they, if available, are supposed to give more precise/more + * numerically stable results. + * + * See e.g. http://www.johndcook.com/math_h.html + */ + +#ifndef c99_acosh +static NV my_acosh(NV x) +{ + return Perl_log(x + Perl_sqrt(x * x - 1)); +} +# define c99_acosh my_acosh +#endif + +#ifndef c99_asinh +static NV my_asinh(NV x) +{ + return Perl_log(x + Perl_sqrt(x * x + 1)); +} +# define c99_asinh my_asinh +#endif + +#ifndef c99_atanh +static NV my_atanh(NV x) +{ + return (Perl_log(1 + x) - Perl_log(1 - x)) / 2; +} +# define c99_atanh my_atanh +#endif + +#ifndef c99_cbrt +static NV my_cbrt(NV x) +{ + static const NV one_third = (NV)1.0/3; + return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third); +} +# define c99_cbrt my_cbrt +#endif + +#ifndef c99_copysign +static NV my_copysign(NV x, NV y) +{ + return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x); +} +# define c99_copysign my_copysign +#endif + +/* XXX cosh (though c89) */ + +#ifndef c99_erf +static NV my_erf(NV x) +{ + /* http://www.johndcook.com/cpp_erf.html -- public domain */ + NV a1 = 0.254829592; + NV a2 = -0.284496736; + NV a3 = 1.421413741; + NV a4 = -1.453152027; + NV a5 = 1.061405429; + NV p = 0.3275911; + NV t, y; + int sign = x < 0 ? -1 : 1; /* Save the sign. */ + x = PERL_ABS(x); + + /* Abramowitz and Stegun formula 7.1.26 */ + t = 1.0 / (1.0 + p * x); + y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x); + + return sign * y; +} +# define c99_erf my_erf +#endif + +#ifndef c99_erfc +static NV my_erfc(NV x) { + /* This is not necessarily numerically stable, but better than nothing. */ + return 1.0 - c99_erf(x); +} +# define c99_erfc my_erfc +#endif + +#ifndef c99_exp2 +static NV my_exp2(NV x) +{ + return Perl_pow((NV)2.0, x); +} +# define c99_exp2 my_exp2 +#endif + +#ifndef c99_expm1 +static NV my_expm1(NV x) +{ + if (PERL_ABS(x) < 1e-5) + /* http://www.johndcook.com/cpp_expm1.html -- public domain. + * Taylor series, the first four terms (the last term quartic). */ + /* Probably not enough for long doubles. */ + return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0))); + else + return Perl_exp(x) - 1; +} +# define c99_expm1 my_expm1 +#endif + +#ifndef c99_fdim +static NV my_fdim(NV x, NV y) +{ + return x > y ? x - y : 0; +} +# define c99_fdim my_fdim +#endif + +#ifndef c99_fmax +static NV my_fmax(NV x, NV y) +{ + if (Perl_isnan(x)) { + return Perl_isnan(y) ? NV_NAN : y; + } else if (Perl_isnan(y)) { + return x; + } + return x > y ? x : y; +} +# define c99_fmax my_fmax +#endif + +#ifndef c99_fmin +static NV my_fmin(NV x, NV y) +{ + if (Perl_isnan(x)) { + return Perl_isnan(y) ? NV_NAN : y; + } else if (Perl_isnan(y)) { + return x; + } + return x < y ? x : y; +} +# define c99_fmin my_fmin +#endif + +#ifndef c99_fpclassify + +static IV my_fpclassify(NV x) +{ +#ifdef Perl_fp_class_inf + if (Perl_fp_class_inf(x)) return FP_INFINITE; + if (Perl_fp_class_nan(x)) return FP_NAN; + if (Perl_fp_class_norm(x)) return FP_NORMAL; + if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL; + if (Perl_fp_class_zero(x)) return FP_ZERO; +# define c99_fpclassify my_fpclassify +#endif + return -1; +} + +#endif + +#ifndef c99_hypot +static NV my_hypot(NV x, NV y) +{ + /* http://en.wikipedia.org/wiki/Hypot */ + NV t; + x = PERL_ABS(x); /* Take absolute values. */ + if (y == 0) + return x; + if (Perl_isnan(y)) + return NV_INF; + y = PERL_ABS(y); + if (x < y) { /* Swap so that y is less. */ + t = x; + x = y; + y = t; + } + t = y / x; + return x * Perl_sqrt(1.0 + t * t); +} +# define c99_hypot my_hypot +#endif + +#ifndef c99_ilogb +static IV my_ilogb(NV x) +{ + return (IV)(Perl_log(x) * M_LOG2E); +} +# define c99_ilogb my_ilogb +#endif + +/* XXX lgamma -- non-trivial */ + +#ifndef c99_log1p +static NV my_log1p(NV x) +{ + /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain. + * Taylor series, the first four terms (the last term quartic). */ + if (x < -1.0) + return NV_NAN; + if (x == -1.0) + return -NV_INF; + if (PERL_ABS(x) > 1e-4) + return Perl_log(1.0 + x); + else + /* Probably not enough for long doubles. */ + return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0))); +} +# define c99_log1p my_log1p +#endif + +#ifndef c99_log2 +static NV my_log2(NV x) +{ + return Perl_log(x) * M_LOG2E; +} +# define c99_log2 my_log2 +#endif + +/* XXX nextafter */ + +/* XXX nexttoward */ + +static int my_fegetround() +{ +#ifdef HAS_FEGETROUND + return fegetround(); +#elif defined(FLT_ROUNDS) + return FLT_ROUNDS; +#elif defined(HAS_FPGETROUND) + switch (fpgetround()) { + default: + case FP_RN: return FE_TONEAREST; + case FP_RZ: return FE_TOWARDZERO; + case FP_RM: return FE_DOWNWARD; + case FE_RP: return FE_UPWARD; + } +#else + return -1; +#endif +} + +/* Toward closest integer. */ +#define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5))) + +/* Toward zero. */ +#define MY_ROUND_TRUNC(x) ((NV)((IV)(x))) + +/* Toward minus infinity. */ +#define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5))) + +/* Toward plus infinity. */ +#define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x)))) + +static NV my_rint(NV x) +{ +#ifdef FE_TONEAREST + switch (my_fegetround()) { + default: + case FE_TONEAREST: return MY_ROUND_NEAREST(x); + case FE_TOWARDZERO: return MY_ROUND_TRUNC(x); + case FE_DOWNWARD: return MY_ROUND_DOWN(x); + case FE_UPWARD: return MY_ROUND_UP(x); + } +#elif defined(HAS_FPGETROUND) + switch (fpgetround()) { + default: + case FP_RN: return MY_ROUND_NEAREST(x); + case FP_RZ: return MY_ROUND_TRUNC(x); + case FP_RM: return MY_ROUND_DOWN(x); + case FE_RP: return MY_ROUND_UP(x); + } +#else + return NV_NAN; +#endif +} + +/* XXX nearbyint() and rint() are not really identical -- but the difference + * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point + * exceptions, while rint() is defined to MAYBE raise them. At the moment + * Perl is blissfully unaware of such fine detail of floating point. */ +#ifndef c99_nearbyint +# ifdef FE_TONEAREST +# define c99_nearbyrint my_rint +# endif +#endif + +#ifndef c99_lrint +# ifdef FE_TONEAREST +static IV my_lrint(NV x) +{ + return (IV)my_rint(x); +} +# define c99_lrint my_lrint +# endif +#endif + +#ifndef c99_lround +static IV my_lround(NV x) +{ + return (IV)MY_ROUND_NEAREST(x); +} +# define c99_lround my_lround +#endif + +/* XXX remainder */ + +/* XXX remquo */ + +#ifndef c99_rint +# ifdef FE_TONEAREST +# define c99_rint my_rint +# endif +#endif + +#ifndef c99_round +static NV my_round(NV x) +{ + return MY_ROUND_NEAREST(x); +} +# define c99_round my_round +#endif + +#ifndef c99_scalbn +# if defined(Perl_ldexp) && FLT_RADIX == 2 +static NV my_scalbn(NV x, int y) +{ + return Perl_ldexp(x, y); +} +# define c99_scalbn my_scalbn +# endif +#endif + +/* XXX sinh (though c89) */ + +#ifndef c99_tgamma +# ifdef c99_lgamma +static NV my_tgamma(NV x) +{ + double l = c99_lgamma(x); + return signgam * Perl_exp(l); /* XXX evil global signgam, need lgamma_r */ +} +# define c99_tgamma my_tgamma +/* XXX tgamma without lgamma -- non-trivial */ +# endif +#endif + +/* XXX tanh (though c89) */ + +#ifndef c99_trunc +static NV my_trunc(NV x) +{ + return MY_ROUND_TRUNC(x); +} +# define c99_trunc my_trunc +#endif + /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD @@ -133,6 +1005,7 @@ char *tzname[] = { "" , "" }; # define setuid(a) not_here("setuid") # define setgid(a) not_here("setgid") #endif /* NETWARE */ +# define strtold(s1,s2) not_here("strtold") #else # ifndef HAS_MKFIFO @@ -189,6 +1062,9 @@ START_EXTERN_C double strtod (const char *, char **); long strtol (const char *, char **, int); unsigned long strtoul (const char *, char **, int); +#ifdef HAS_STRTOLD +long double strtold (const char *, char **); +#endif END_EXTERN_C #endif @@ -227,6 +1103,9 @@ END_EXTERN_C #ifndef HAS_STRTOD #define strtod(s1,s2) not_here("strtod") #endif +#ifndef HAS_STRTOLD +#define strtold(s1,s2) not_here("strtold") +#endif #ifndef HAS_STRTOL #define strtol(s1,s2,b) not_here("strtol") #endif @@ -1090,54 +1969,455 @@ NV acos(x) NV x ALIAS: - asin = 1 - atan = 2 - ceil = 3 - cosh = 4 - floor = 5 - log10 = 6 - sinh = 7 - tan = 8 - tanh = 9 + acosh = 1 + asin = 2 + asinh = 3 + atan = 4 + atanh = 5 + cbrt = 6 + ceil = 7 + cosh = 8 + erf = 9 + erfc = 10 + exp2 = 11 + expm1 = 12 + floor = 13 + j0 = 14 + j1 = 15 + lgamma = 16 + log10 = 17 + log1p = 18 + log2 = 19 + logb = 20 + nearbyint = 21 + rint = 22 + round = 23 + sinh = 24 + tan = 25 + tanh = 26 + tgamma = 27 + trunc = 28 + y0 = 29 + y1 = 30 CODE: + RETVAL = NV_NAN; switch (ix) { case 0: - RETVAL = acos(x); + RETVAL = Perl_acos(x); /* C89 math */ break; case 1: - RETVAL = asin(x); +#ifdef c99_acosh + RETVAL = c99_acosh(x); +#else + not_here("acosh"); +#endif break; case 2: - RETVAL = atan(x); + RETVAL = Perl_asin(x); /* C89 math */ break; case 3: - RETVAL = ceil(x); +#ifdef c99_asinh + RETVAL = c99_asinh(x); +#else + not_here("asinh"); +#endif break; case 4: - RETVAL = cosh(x); + RETVAL = Perl_atan(x); /* C89 math */ break; case 5: - RETVAL = floor(x); +#ifdef c99_atanh + RETVAL = c99_atanh(x); +#else + not_here("atanh"); +#endif break; case 6: - RETVAL = log10(x); +#ifdef c99_cbrt + RETVAL = c99_cbrt(x); +#else + not_here("cbrt"); +#endif break; case 7: - RETVAL = sinh(x); + RETVAL = Perl_ceil(x); /* C89 math */ break; case 8: - RETVAL = tan(x); + RETVAL = Perl_cosh(x); /* C89 math */ + break; + case 9: +#ifdef c99_erf + RETVAL = c99_erf(x); +#else + not_here("erf"); +#endif + break; + case 10: +#ifdef c99_erfc + RETVAL = c99_erfc(x); +#else + not_here("erfc"); +#endif + break; + case 11: +#ifdef c99_exp2 + RETVAL = c99_exp2(x); +#else + not_here("exp2"); +#endif + break; + case 12: +#ifdef c99_expm1 + RETVAL = c99_expm1(x); +#else + not_here("expm1"); +#endif + break; + case 13: + RETVAL = Perl_floor(x); /* C89 math */ + break; + case 14: +#ifdef bessel_j0 + RETVAL = bessel_j0(x); +#else + not_here("j0"); +#endif + break; + case 15: +#ifdef bessel_j1 + RETVAL = bessel_j1(x); +#else + not_here("j1"); +#endif + break; + case 16: + /* XXX lgamma_r -- the lgamma accesses a global variable (signgam), + * which is evil. Some platforms have lgamma_r, which has + * extra parameter instead of the global variable. */ +#ifdef c99_lgamma + RETVAL = c99_lgamma(x); +#else + not_here("lgamma"); +#endif + break; + case 17: + RETVAL = log10(x); /* C89 math */ + break; + case 18: +#ifdef c99_log1p + RETVAL = c99_log1p(x); +#else + not_here("log1p"); +#endif + break; + case 19: +#ifdef c99_log2 + RETVAL = c99_log2(x); +#else + not_here("log2"); +#endif + break; + case 20: +#ifdef c99_logb + RETVAL = c99_logb(x); +#else + not_here("logb"); +#endif + break; + case 21: +#ifdef c99_nearbyint + RETVAL = c99_nearbyint(x); +#else + not_here("nearbyint"); +#endif + break; + case 22: +#ifdef c99_rint + RETVAL = c99_rint(x); +#else + not_here("rint"); +#endif + break; + case 23: +#ifdef c99_round + RETVAL = c99_round(x); +#else + not_here("round"); +#endif + break; + case 24: + RETVAL = Perl_sinh(x); /* C89 math */ + break; + case 25: + RETVAL = Perl_tan(x); /* C89 math */ + break; + case 26: + RETVAL = Perl_tanh(x); /* C89 math */ + break; + case 27: + /* XXX tgamma_r -- the lgamma accesses a global variable (signgam), + * which is evil. Some platforms have tgamma_r, which has + * extra parameter instead of the global variable. */ +#ifdef c99_tgamma + RETVAL = c99_tgamma(x); +#else + not_here("tgamma"); +#endif + break; + case 28: +#ifdef c99_trunc + RETVAL = c99_trunc(x); +#else + not_here("trunc"); +#endif break; + case 29: +#ifdef bessel_y0 + RETVAL = bessel_y0(x); +#else + not_here("y0"); +#endif + break; + case 30: + default: +#ifdef bessel_y1 + RETVAL = bessel_y1(x); +#else + not_here("y1"); +#endif + } + OUTPUT: + RETVAL + +IV +fegetround() + CODE: +#ifdef HAS_FEGETROUND + RETVAL = my_fegetround(); +#else + RETVAL = -1; + not_here("fegetround"); +#endif + OUTPUT: + RETVAL + +IV +fesetround(x) + IV x + CODE: +#ifdef HAS_FEGETROUND /* canary for fesetround */ + RETVAL = fesetround(x); +#elif defined(HAS_FPGETROUND) /* canary for fpsetround */ + switch (x) { + default: + case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break; + case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break; + case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break; + case FE_UPWARD: RETVAL = fpsetround(FP_RP); break; + } +#else + RETVAL = -1; + not_here("fesetround"); +#endif + OUTPUT: + RETVAL + +IV +fpclassify(x) + NV x + ALIAS: + ilogb = 1 + isfinite = 2 + isinf = 3 + isnan = 4 + isnormal = 5 + lrint = 6 + lround = 7 + signbit = 8 + CODE: + RETVAL = -1; + switch (ix) { + case 0: +#ifdef c99_fpclassify + RETVAL = c99_fpclassify(x); +#else + not_here("fpclassify"); +#endif + break; + case 1: +#ifdef c99_ilogb + RETVAL = c99_ilogb(x); +#else + not_here("ilogb"); +#endif + break; + case 2: + RETVAL = Perl_isfinite(x); + break; + case 3: + RETVAL = Perl_isinf(x); + break; + case 4: + RETVAL = Perl_isnan(x); + break; + case 5: +#ifdef c99_isnormal + RETVAL = c99_isnormal(x); +#else + not_here("isnormal"); +#endif + break; + case 6: +#ifdef c99_lrint + RETVAL = c99_lrint(x); +#else + not_here("lrint"); +#endif + break; + case 7: +#ifdef c99_lround + RETVAL = c99_lround(x); +#else + not_here("lround"); +#endif + break; + case 8: default: - RETVAL = tanh(x); +#ifdef Perl_signbit + RETVAL = Perl_signbit(x); +#endif + break; } OUTPUT: RETVAL NV -fmod(x,y) +copysign(x,y) NV x NV y + ALIAS: + fdim = 1 + fmax = 2 + fmin = 3 + fmod = 4 + hypot = 5 + isgreater = 6 + isgreaterequal = 7 + isless = 8 + islessequal = 9 + islessgreater = 10 + isunordered = 11 + nextafter = 12 + nexttoward = 13 + remainder = 14 + CODE: + RETVAL = NV_NAN; + switch (ix) { + case 0: +#ifdef c99_copysign + RETVAL = c99_copysign(x, y); +#else + not_here("copysign"); +#endif + break; + case 1: +#ifdef c99_fdim + RETVAL = c99_fdim(x, y); +#else + not_here("fdim"); +#endif + break; + case 2: +#ifdef c99_fmax + RETVAL = c99_fmax(x, y); +#else + not_here("fmax"); +#endif + break; + case 3: +#ifdef c99_fmin + RETVAL = c99_fmin(x, y); +#else + not_here("fmin"); +#endif + break; + case 4: + RETVAL = Perl_fmod(x, y); /* C89 math */ + break; + case 5: +#ifdef c99_hypot + RETVAL = c99_hypot(x, y); +#else + not_here("hypot"); +#endif + break; + case 6: +#ifdef c99_isgreater + RETVAL = c99_isgreater(x, y); +#else + not_here("isgreater"); +#endif + break; + case 7: +#ifdef c99_isgreaterequal + RETVAL = c99_isgreaterequal(x, y); +#else + not_here("isgreaterequal"); +#endif + break; + case 8: +#ifdef c99_isless + RETVAL = c99_isless(x, y); +#else + not_here("isless"); +#endif + break; + case 9: +#ifdef c99_islessequal + RETVAL = c99_islessequal(x, y); +#else + not_here("islessequal"); +#endif + break; + case 10: +#ifdef c99_islessgreater + RETVAL = c99_islessgreater(x, y); +#else + not_here("islessgreater"); +#endif + break; + case 11: +#ifdef c99_isunordered + RETVAL = c99_isunordered(x, y); +#else + not_here("isunordered"); +#endif + break; + case 12: +#ifdef c99_nextafter + RETVAL = c99_nextafter(x, y); +#else + not_here("nextafter"); +#endif + break; + case 13: +#ifdef c99_nexttoward + RETVAL = c99_nexttoward(x, y); +#else + not_here("nexttoward"); +#endif + break; + case 14: + default: +#ifdef c99_remainder + RETVAL = c99_remainder(x, y); +#else + not_here("remainder"); +#endif + break; + } + OUTPUT: + RETVAL void frexp(x) @@ -1145,7 +2425,7 @@ frexp(x) PPCODE: int expvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(frexp(x,&expvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */ PUSHs(sv_2mortal(newSViv(expvar))); NV @@ -1159,9 +2439,94 @@ modf(x) PPCODE: NV intvar; /* (We already know stack is long enough.) */ - PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); + PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */ PUSHs(sv_2mortal(newSVnv(intvar))); +void +remquo(x,y) + NV x + NV y + PPCODE: +#ifdef c99_remquo + int intvar; + PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar)))); + PUSHs(sv_2mortal(newSVnv(intvar))); +#else + not_here("remquo"); +#endif + +NV +scalbn(x,y) + NV x + IV y + CODE: +#ifdef c99_scalbn + RETVAL = c99_scalbn(x, y); +#else + RETVAL = NV_NAN; + not_here("scalbn"); +#endif + OUTPUT: + RETVAL + +NV +fma(x,y,z) + NV x + NV y + NV z + CODE: +#ifdef c99_fma + RETVAL = c99_fma(x, y, z); +#else + RETVAL = NV_NAN; + not_here("fma"); +#endif + OUTPUT: + RETVAL + +NV +nan(s = 0) + char* s; + CODE: +#ifdef c99_nan + RETVAL = c99_nan(s ? s : ""); +#else + RETVAL = NV_NAN; +# ifndef NV_NAN + not_here("nan"); +# endif +#endif + OUTPUT: + RETVAL + +NV +jn(x,y) + IV x + NV y + ALIAS: + yn = 1 + CODE: + RETVAL = NV_NAN; + switch (ix) { + case 0: +#ifdef bessel_jn + RETVAL = bessel_jn(x, y); +#else + not_here("jn"); +#endif + break; + case 1: + default: +#ifdef bessel_yn + RETVAL = bessel_yn(x, y); +#else + not_here("yn"); +#endif + break; + } + OUTPUT: + RETVAL + SysRet sigaction(sig, optaction, oldaction = 0) int sig @@ -1570,6 +2935,29 @@ strtod(str) } RESTORE_NUMERIC_STANDARD(); +#ifdef HAS_STRTOLD + +void +strtold(str) + char * str + PREINIT: + long double num; + char *unparsed; + PPCODE: + STORE_NUMERIC_STANDARD_FORCE_LOCAL(); + num = strtold(str, &unparsed); + PUSHs(sv_2mortal(newSVnv(num))); + if (GIMME == G_ARRAY) { + EXTEND(SP, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&PL_sv_undef); + } + RESTORE_NUMERIC_STANDARD(); + +#endif + void strtol(str, base = 0) char * str diff --git a/ext/POSIX/lib/POSIX.pm b/ext/POSIX/lib/POSIX.pm index 3daa2f3..0b236d2 100644 --- a/ext/POSIX/lib/POSIX.pm +++ b/ext/POSIX/lib/POSIX.pm @@ -4,7 +4,7 @@ use warnings; our ($AUTOLOAD, %SIGRT); -our $VERSION = '1.42'; +our $VERSION = '1.43'; require XSLoader; @@ -268,6 +268,9 @@ our %EXPORT_TAGS = ( S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR)], + fenv_h => [qw(FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD + fegetround fesetround)], + float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP @@ -296,8 +299,19 @@ our %EXPORT_TAGS = ( LC_MONETARY LC_NUMERIC LC_TIME NULL localeconv setlocale)], - math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod - frexp ldexp log10 modf pow sinh tan tanh)], + math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL + FP_SUBNORMAL FP_ZERO HUGE_VAL INFINITY Inf M_1_PI + M_2_PI M_2_SQRTPI M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI + M_PI_2 M_PI_4 M_SQRT1_2 M_SQRT2 NAN NaN acos acosh + asin asinh atan atanh cbrt ceil copysign cosh erf + erfc exp2 expm1 fabs fdim floor fma fmax fmin fmod + fpclassify frexp hypot ilogb isfinite isgreater + isgreaterequal isinf isless islessequal + islessgreater isnan isnormal isunordered j0 j1 jn + ldexp lgamma log10 log1p log2 logb lrint modf nan + nearbyint nextafter nexttoward pow remainder remquo + rint round scalbn signbit sinh tan tanh tgamma trunc + y0 y1 yn)], pwd_h => [], @@ -329,7 +343,7 @@ our %EXPORT_TAGS = ( stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX abort atexit atof atoi atol bsearch calloc div free getenv labs ldiv malloc mblen mbstowcs mbtowc - qsort realloc strtod strtol strtoul wcstombs wctomb)], + qsort realloc strtod strtol strtold strtoul wcstombs wctomb)], string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat strchr strcmp strcoll strcpy strcspn strerror strlen diff --git a/ext/POSIX/lib/POSIX.pod b/ext/POSIX/lib/POSIX.pod index 677a599..82bc213 100644 --- a/ext/POSIX/lib/POSIX.pod +++ b/ext/POSIX/lib/POSIX.pod @@ -41,6 +41,32 @@ and other miscellaneous objects. The remaining sections list various constants and macros in an organization which roughly follows IEEE Std 1003.1b-1993. +=head1 C99 "math" interfaces + +Mathematic functions and constants from the C99 standard are available +on many platforms. In the below functions list they are marked [C99]. + +The mathematical constants include: + + M_SQRT2 # the square root of two + M_E # the Euler's (or Napier's) constant + M_PI # the Pi + +and other related/similar ones + + M_SQRT1_2 # sqrt(1/2) + M_LN10 M_LN2 M_LOG10E M_LOG2E + M_1_PI M_2_PI M_2_SQRTPI M_PI_2 M_PI_4 # 1/Pi, ..., Pi/4 + +and the + + INFINITY + NAN + +The last two are also available as just Inf and NaN. + +The Bessel functions (j0, j1, jn, y0, y1, yn) are also available. + =head1 CAVEATS A few functions are not implemented because they are C specific. If you @@ -102,6 +128,12 @@ I. This is identical to the C function C, returning the arcus cosine of its numerical argument. See also L. +=item C + +This is identical to the C function C, returning the +hyperbolic arcus cosine of its numerical argument [C99]. See also +L. + =item C This is identical to Perl's builtin C function, @@ -128,6 +160,12 @@ The C<$mon> is zero-based: January equals C<0>. The C<$year> is This is identical to the C function C, returning the arcus sine of its numerical argument. See also L. +=item C + +This is identical to the C function C, returning the +hyperbolic arcus sine of its numerical argument [C99]. See also +L. + =item C Unimplemented, but you can use L and the L module @@ -138,6 +176,12 @@ to achieve similar things. This is identical to the C function C, returning the arcus tangent of its numerical argument. See also L. +=item C + +This is identical to the C function C, returning the +hyperbolic arcus tangent of its numerical argument [C99]. See also +L. + =item C This is identical to Perl's builtin C function, returning @@ -174,6 +218,10 @@ see L. C is C-specific. Perl does memory management transparently. +=item C + +The cube root [C99]. + =item C This is identical to the C function C, returning the smallest @@ -232,6 +280,12 @@ See also L. This is identical to the C function C, for returning the hyperbolic cosine of its numeric argument. See also L. +=item C + +Returns the x but with the sign of y [C99]. + +See also L. + =item C Create a new file. This returns a file descriptor like the ones returned by @@ -290,6 +344,14 @@ C. Returns C on failure. +=item C + +The error function [C99]. + +=item C + +The complementary error function [C99]. + =item C Returns the value of errno. @@ -333,6 +395,12 @@ This is identical to Perl's builtin C function for returning the exponent (I-based) of the numerical argument, see L. +=item C + +Equivalent to C, but more precise for small argument values [C99]. + +See also L. + =item C This is identical to Perl's builtin C function for returning @@ -386,6 +454,35 @@ Use method C instead, or see L. This is identical to the C function C, returning the largest integer value less than or equal to the numerical argument. +=item C + +"Positive difference", x - y if x > y, zero otherwise [C99]. + +=item C + +Returns the current floating point rounding mode, one of + + FE_TONEAREST FE_TOWARDZERO FE_UPWARD FE_UPWARD + +FE_TONEAREST is like L, FE_TOWARDZERO is like L [C99]. + +=item C + +Sets the floating point rounding mode, see L. + +=item C + +"Fused multiply-add", x * y + z, possibly faster (and less lossy) +than the explicit two operations [C99]. + +=item C + +Maximum of x and y, except when either is NaN, returns the other [C99]. + +=item C + +Minimum of x and y, except when either is NaN, returns the other [C99]. + =item C This is identical to the C function C. @@ -419,6 +516,14 @@ pathname on the filesystem which holds F. Returns C on failure. +=item C + +Returns one of + + FP_NORMAL FP_ZERO FP_SUBNORMAL FP_INFINITE FP_NAN + +telling the class of the argument [C99]. + =item C C is C-specific, see L instead. @@ -587,6 +692,19 @@ This is identical to Perl's builtin C function for converting seconds since the epoch to a date in Greenwich Mean Time, see L. +=item C + +Equivalent to sqrt(x * x + y * y) except more stable on very large +or very small arguments [C99]. + +=item C + +Integer binary logarithm [C99] + +For example ilogb(20) is 4, as an integer. + +See also L. + =item C Deprecated function whose use raises a warning, and which is slated to @@ -662,6 +780,13 @@ corresponding C function returns C for every byte in the string. You may want to use the C\dE|perlrecharclass/Digits>> construct instead. +=item C + +Returns true if the argument is a finite number (that is, not an +infinity, or the not-a-number) [C99]. + +See also L, L, and L. + =item C Deprecated function whose use raises a warning, and which is slated to @@ -678,6 +803,19 @@ modifier is in effect?>). The function returns C if the input string is empty, or if the corresponding C function returns C for every byte in the string. +=item C + +(Also C, C, C, C, +C) + +Floating point comparisons which handle the NaN [C99]. + +=item C + +Returns true if the argument is an infinity (positive or negative) [C99]. + +See also L, L, and L. + =item C Deprecated function whose use raises a warning, and which is slated to @@ -696,6 +834,25 @@ corresponding C function returns C for every byte in the string. Do B use C unless you don't care about the current locale. +=item C + +Returns true if the argument is NaN (not-a-number) [C99]. + +Note that you cannot test for "NaN-ness" with + + $x == $x + +since the NaN is not equivalent to anything, B. + +See also L, L, and L. + +=item C + +Returns true if the argument is normal (that is, not a subnormal/denormal, +and not an infinity, or a not-a-number) [C99]. + +See also L, and L. + =item C Deprecated function whose use raises a warning, and which is slated to @@ -781,6 +938,12 @@ modifier is in effect?>). The function returns C if the input string is empty, or if the corresponding C function returns C for every byte in the string. +=item C + +(Also C, C, C, C, C) + +The Bessel function of the first kind of the order zero. + =item C This is identical to Perl's builtin C function for sending @@ -811,6 +974,31 @@ for multiplying floating point numbers with powers of two. (For computing dividends of long integers.) C is C-specific, use C and C instead. +=item C + +The logarithm of the Gamma function [C99]. + +See also L. + +=item C + +Equivalent to log(1 + x), but more stable results for small argument +values [C99]. + +=item C + +Logarithm base two [C99]. + +See also L. + +=item C + +Integer binary logarithm [C99]. + +For example logb(20) is 4, as a floating point number. + +See also L. + =item C This is identical to Perl's builtin C function @@ -895,6 +1083,21 @@ those obtained by calling C. Returns C on failure. +=item C + +Depending on the current floating point rounding mode, rounds the +argument either toward nearest (like L), toward zero (like +L), downward (toward negative infinity), or upward (toward +positive infinity) [C99]. + +For the rounding mode, see L. + +=item C + +Like L, but as integer, as opposed to floating point [C99]. + +See also L, L, L. + =item C C is C-specific. Perl does memory management transparently. @@ -902,23 +1105,24 @@ C is C-specific. Perl does memory management transparently. =item C This is identical to the C function C. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +Core Perl does not have any support for the wide and multibyte +characters of the C standards, so this might be a rather useless +function. + +However, Perl supports Unicode, see L. =item C This is identical to the C function C. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L. =item C This is identical to the C function C. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L. =item C @@ -984,6 +1188,33 @@ Return the integral and fractional parts of a floating-point number. ($fractional, $integral) = POSIX::modf( 3.14 ); +See also L. + +=item C + +Returns not-a-number [C99]. + +See also L. + +=item C + +Returns the nearest integer to the argument, according to the current +rounding mode (see L) [C99]. + +=item C + +Returns the next representable floating point number after x in the +direction of y [C99]. + +Like L, but potentially less accurate. + +=item C + +Returns the next representable floating point number after x in the +direction of y [C99]. + +Like L, but potentially more accurate. + =item C This is similar to the C function C, for changing @@ -1133,11 +1364,26 @@ for reading directory entries, see L. C is C-specific. Perl does memory management transparently. +=item C + +Given x and y, returns the value x - n*y, where n is the integer +closest to x/y. [C99] + +See also L. + =item C This is identical to Perl's builtin C function for removing files, see L. +=item C + +Like L but also returns the low-order bits of the quotient (n) +[C99] + +(This is quite esoteric interface, mainly used to implement numerical +algorithms.) + =item C This is identical to Perl's builtin C function @@ -1152,11 +1398,28 @@ Seeks to the beginning of the file. This is identical to Perl's builtin C function for rewinding directory entry streams, see L. +=item C + +Identical to L. + =item C This is identical to Perl's builtin C function for removing (empty) directories, see L. +=item C + +Returns the integer (but still as floating point) nearest to the +argument [C99]. + +See also L, L, L, L, and L. + +=item C + +Returns x * 2**y [C99]. + +See also L and L. + =item C C is C-specific, use EE and regular expressions instead, @@ -1285,6 +1548,10 @@ C and possibly also C documentation. C is C-specific: use L instead. +=item C + +Returns zero for positive arguments, non-zero for negative arguments [C99]. + =item C Examine signals that are blocked and pending. This uses C @@ -1543,6 +1810,11 @@ The second returned item and C<$!> can be used to check for valid input: When called in a scalar context strtol returns the parsed number. +=item C + +Like L but for long doubles. Defined only if the +system supports long doubles. + =item C String to unsigned (long) integer translation. C is identical @@ -1630,6 +1902,12 @@ terminal. Returns C on failure. +=item C + +The Gamma function [C99]. + +See also L. + =item C. + =item C This is identical to the C function C for returning the @@ -1761,16 +2045,14 @@ builtin C function, see L. =item C This is identical to the C function C. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L. =item C This is identical to the C function C. -Perl does not have any support for the wide and multibyte -characters of the C standards, so this might be a rather -useless function. + +See L. =item C diff --git a/ext/POSIX/t/export.t b/ext/POSIX/t/export.t index f76c60c..caa7f2b 100644 --- a/ext/POSIX/t/export.t +++ b/ext/POSIX/t/export.t @@ -34,80 +34,104 @@ my %expect = ( ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY EUSERS EWOULDBLOCK EXDEV - EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC FILENAME_MAX - FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX FLT_MAX_10_EXP - FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP FLT_RADIX - FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK - F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL - HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK - INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE - LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG - LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP - LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX - LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON - MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG - NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND - O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC - O_WRONLY PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK - SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND - SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR SEEK_END - SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM SIGBUS SIGCHLD - SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGPOLL - SIGPROF SIGQUIT SIGRTMAX SIGRTMIN SIGSEGV SIGSTOP SIGSYS - SIGTERM SIGTRAP SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 - SIGUSR2 SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR - SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX STDERR_FILENO - STDIN_FILENO STDOUT_FILENO STREAM_MAX S_IRGRP S_IROTH S_IRUSR - S_IRWXG S_IRWXO S_IRWXU S_ISBLK S_ISCHR S_ISDIR S_ISFIFO - S_ISGID S_ISREG S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP - S_IXOTH S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH - TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX TOSTOP - TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX USHRT_MAX VEOF VEOL - VERASE VINTR VKILL VMIN VQUIT VSTART VSTOP VSUSP VTIME - WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG - WTERMSIG WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED - _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT _PC_NAME_MAX - _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF _PC_VDISABLE - _POSIX_ARG_MAX _POSIX_CHILD_MAX _POSIX_CHOWN_RESTRICTED - _POSIX_JOB_CONTROL _POSIX_LINK_MAX _POSIX_MAX_CANON - _POSIX_MAX_INPUT _POSIX_NAME_MAX _POSIX_NGROUPS_MAX - _POSIX_NO_TRUNC _POSIX_OPEN_MAX _POSIX_PATH_MAX - _POSIX_PIPE_BUF _POSIX_SAVED_IDS _POSIX_SSIZE_MAX - _POSIX_STREAM_MAX _POSIX_TZNAME_MAX _POSIX_VDISABLE - _POSIX_VERSION _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK - _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE - _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION _exit - abort access acos asctime asin assert atan atexit atof atoi - atol bsearch calloc ceil cfgetispeed cfgetospeed cfsetispeed - cfsetospeed clearerr clock cosh creat ctermid ctime cuserid - difftime div dup dup2 errno execl execle execlp execv execve - execvp fabs fclose fdopen feof ferror fflush fgetc fgetpos - fgets floor fmod fopen fpathconf fprintf fputc fputs fread - free freopen frexp fscanf fseek fsetpos fstat fsync ftell + EXIT_FAILURE EXIT_SUCCESS FD_CLOEXEC + FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD + FILENAME_MAX FLT_DIG FLT_EPSILON FLT_MANT_DIG FLT_MAX + FLT_MAX_10_EXP FLT_MAX_EXP FLT_MIN FLT_MIN_10_EXP + FLT_MIN_EXP FLT_RADIX FLT_ROUNDS FP_ILOGB0 + FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL + FP_SUBNORMAL FP_ZERO F_DUPFD F_GETFD F_GETFL F_GETLK + F_OK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW + F_UNLCK F_WRLCK HUGE_VAL HUPCL ICANON ICRNL IEXTEN + IGNBRK IGNCR IGNPAR INFINITY INLCR INPCK INT_MAX + INT_MIN ISIG ISTRIP IXOFF IXON Inf LC_ALL LC_COLLATE + LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME + LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX + LDBL_MAX_10_EXP LDBL_MAX_EXP LDBL_MIN + LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX LONG_MAX + LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON + MAX_INPUT MB_CUR_MAX MB_LEN_MAX M_1_PI M_2_PI M_2_SQRTPI + M_E M_LN10 M_LN2 M_LOG10E M_LOG2E M_PI M_PI_2 M_PI_4 + M_SQRT1_2 M_SQRT2 NAME_MAX NAN NCCS NDEBUG + NGROUPS_MAX NOFLSH NULL NaN OPEN_MAX OPOST O_ACCMODE + O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY + O_RDWR O_TRUNC O_WRONLY PARENB PARMRK PARODD + PATH_MAX PIPE_BUF RAND_MAX R_OK SA_NOCLDSTOP + SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND + SA_RESTART SA_SIGINFO SCHAR_MAX SCHAR_MIN SEEK_CUR + SEEK_END SEEK_SET SHRT_MAX SHRT_MIN SIGABRT SIGALRM + SIGBUS SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT + SIGKILL SIGPIPE SIGPOLL SIGPROF SIGQUIT SIGRTMAX + SIGRTMIN SIGSEGV SIGSTOP SIGSYS SIGTERM SIGTRAP + SIGTSTP SIGTTIN SIGTTOU SIGURG SIGUSR1 SIGUSR2 + SIGVTALRM SIGXCPU SIGXFSZ SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK SSIZE_MAX + STDERR_FILENO STDIN_FILENO STDOUT_FILENO STREAM_MAX + S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU + S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG + S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH + S_IXUSR TCIFLUSH TCIOFF TCIOFLUSH TCION TCOFLUSH + TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW TMP_MAX + TOSTOP TZNAME_MAX UCHAR_MAX UINT_MAX ULONG_MAX + USHRT_MAX VEOF VEOL VERASE VINTR VKILL VMIN VQUIT + VSTART VSTOP VSUSP VTIME WEXITSTATUS WIFEXITED + WIFSIGNALED WIFSTOPPED WNOHANG WSTOPSIG WTERMSIG + WUNTRACED W_OK X_OK _PC_CHOWN_RESTRICTED + _PC_LINK_MAX _PC_MAX_CANON _PC_MAX_INPUT + _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX _PC_PIPE_BUF + _PC_VDISABLE _POSIX_ARG_MAX _POSIX_CHILD_MAX + _POSIX_CHOWN_RESTRICTED _POSIX_JOB_CONTROL + _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT + _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_NO_TRUNC + _POSIX_OPEN_MAX _POSIX_PATH_MAX _POSIX_PIPE_BUF + _POSIX_SAVED_IDS _POSIX_SSIZE_MAX _POSIX_STREAM_MAX + _POSIX_TZNAME_MAX _POSIX_VDISABLE _POSIX_VERSION + _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK + _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_MAX + _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX + _SC_TZNAME_MAX _SC_VERSION _exit abort access acos + acosh asctime asin asinh assert atan atanh atexit + atof atoi atol bsearch calloc cbrt ceil cfgetispeed + cfgetospeed cfsetispeed cfsetospeed clearerr clock + copysign cosh creat ctermid ctime cuserid difftime + div dup dup2 erf erfc errno execl execle execlp + execv execve execvp exp2 expm1 fabs fclose fdim + fdopen fegetround feof ferror fesetround fflush + fgetc fgetpos fgets floor fma fmax fmin fmod fopen + fpathconf fpclassify fprintf fputc fputs fread free + freopen frexp fscanf fseek fsetpos fstat fsync ftell fwrite getchar getcwd getegid getenv geteuid getgid getgroups - getpid gets getuid isalnum isalpha isatty iscntrl isdigit - isgraph islower isprint ispunct isspace isupper isxdigit labs - ldexp ldiv localeconv log10 longjmp lseek malloc mblen - mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo - mktime modf offsetof pathconf pause perror pow putc putchar - puts qsort raise realloc remove rewind scanf setbuf setgid - setjmp setlocale setpgid setsid setuid setvbuf sigaction - siglongjmp signal sigpending sigprocmask sigsetjmp sigsuspend - sinh sscanf stderr stdin stdout strcat strchr strcmp strcoll - strcpy strcspn strerror strftime strlen strncat strncmp - strncpy strpbrk strrchr strspn strstr strtod strtok strtol - strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush - tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile - tmpnam tolower toupper ttyname tzname tzset uname ungetc - vfprintf vprintf vsprintf wcstombs wctomb)], - EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown close closedir cos exit - exp fcntl fileno fork getc getgrgid getgrnam getlogin - getpgrp getppid getpwnam getpwuid gmtime kill lchown link - localtime log mkdir nice open opendir pipe printf rand - read readdir rename rewinddir rmdir sin sleep sprintf sqrt - srand stat system time times umask unlink utime wait - waitpid write)], -); + getpid gets getuid hypot ilogb isalnum isalpha + isatty iscntrl isdigit isfinite isgraph isgreater + isgreaterequal isinf isless islessequal + islessgreater islower isnan isnormal isprint ispunct + isspace isunordered isupper isxdigit j0 j1 jn labs + ldexp ldiv lgamma localeconv log10 log1p log2 logb + longjmp lrint lseek malloc mblen mbstowcs mbtowc + memchr memcmp memcpy memmove memset mkfifo mktime + modf nan nearbyint nextafter nexttoward offsetof + pathconf pause perror pow putc putchar puts qsort + raise realloc remainder remove remquo rewind rint + round scalbn scanf setbuf setgid setjmp setlocale + setpgid setsid setuid setvbuf sigaction siglongjmp + signal signbit sigpending sigprocmask sigsetjmp + sigsuspend sinh sscanf stderr stdin stdout strcat + strchr strcmp strcoll strcpy strcspn strerror + strftime strlen strncat strncmp strncpy strpbrk + strrchr strspn strstr strtod strtok strtol strtold + strtoul strxfrm sysconf tan tanh tcdrain tcflow + tcflush tcgetattr tcgetpgrp tcsendbreak tcsetattr + tcsetpgrp tgamma tmpfile tmpnam tolower toupper + trunc ttyname tzname tzset uname ungetc vfprintf + vprintf vsprintf wcstombs wctomb y0 y1 yn )], + EXPORT_OK => [qw(abs alarm atan2 chdir chmod chown + close closedir cos exit exp fcntl fileno fork getc + getgrgid getgrnam getlogin getpgrp getppid getpwnam + getpwuid gmtime kill lchown link localtime log mkdir + nice open opendir pipe printf rand read readdir + rename rewinddir rmdir sin sleep sprintf sqrt srand + stat system time times umask unlink utime wait + waitpid write)], ); plan (tests => 2 * keys %expect); diff --git a/ext/POSIX/t/math.t b/ext/POSIX/t/math.t index bf0c2de..f21a1cf 100644 --- a/ext/POSIX/t/math.t +++ b/ext/POSIX/t/math.t @@ -5,6 +5,8 @@ use strict; use POSIX; use Test::More; +use Config; + # These tests are mainly to make sure that these arithmetic functions # exist and are accessible. They are not meant to be an exhaustive # test for the interface. @@ -52,4 +54,99 @@ between(0.76, tanh(1), 0.77, 'tanh(1)'); between(-0.77, tanh(-1), -0.76, 'tanh(-1)'); cmp_ok(tanh(1), '==', -tanh(-1), 'tanh(1) == -tanh(-1)'); +SKIP: { + unless ($Config{d_acosh}) { + skip "no acosh, suspecting no C99 math", 30; + } + if ($^O =~ /Win32|VMS/) { + skip "running in $^O, C99 math support uneven", 30; + } + cmp_ok(abs(M_SQRT2 - 1.4142135623731), '<', 1e-9, "M_SQRT2"); + cmp_ok(abs(M_E - 2.71828182845905), '<', 1e-9, "M_E"); + cmp_ok(abs(M_PI - 3.14159265358979), '<', 1e-9, "M_PI"); + cmp_ok(abs(acosh(2) - 1.31695789692482), '<', 1e-9, "acosh"); + cmp_ok(abs(asinh(1) - 0.881373587019543), '<', 1e-9, "asinh"); + cmp_ok(abs(atanh(0.5) - 0.549306144334055), '<', 1e-9, "atanh"); + cmp_ok(abs(cbrt(8) - 2), '<', 1e-9, "cbrt"); + cmp_ok(abs(cbrt(-27) - -3), '<', 1e-9, "cbrt"); + cmp_ok(abs(copysign(3.14, -2) - -3.14), '<', 1e-9, "copysign"); + cmp_ok(abs(expm1(2) - 6.38905609893065), '<', 1e-9, "expm1"); + cmp_ok(abs(expm1(1e-6) - 1.00000050000017e-06), '<', 1e-9, "expm1"); + is(fdim(12, 34), 0, "fdim 12 34"); + is(fdim(34, 12), 22, "fdim 34 12"); + is(fmax(12, 34), 34, "fmax 12 34"); + is(fmin(12, 34), 12, "fmin 12 34"); + SKIP: { + unless ($Config{d_fpclassify}) { + skip "no fpclassify", 4; + } + is(fpclassify(1), FP_NORMAL, "fpclassify 1"); + is(fpclassify(0), FP_ZERO, "fpclassify 0"); + is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY"); + is(fpclassify(NAN), FP_NAN, "fpclassify NAN"); + } + is(hypot(3, 4), 5, "hypot 3 4"); + cmp_ok(abs(hypot(-2, 1) - sqrt(5)), '<', 1e-9, "hypot -1 2"); + is(ilogb(255), 7, "ilogb 255"); + is(ilogb(256), 8, "ilogb 256"); + SKIP: { + unless ($Config{d_isfinite}) { + skip "no isfinite", 3; + } + ok(isfinite(1), "isfinite 1"); + ok(!isfinite(Inf), "isfinite Inf"); + ok(!isfinite(NaN), "isfinite NaN"); + } + SKIP: { + unless ($Config{d_isinf}) { + skip "no isinf", 4; + } + ok(isinf(INFINITY), "isinf INFINITY"); + ok(isinf(Inf), "isinf Inf"); + ok(!isinf(NaN), "isinf NaN"); + ok(!isinf(42), "isinf 42"); + } + SKIP: { + unless ($Config{d_isnan}) { + skip "no isnan", 4; + } + ok(isnan(NAN), "isnan NAN"); + ok(isnan(NaN), "isnan NaN"); + ok(!isnan(Inf), "isnan Inf"); + ok(!isnan(42), "isnan Inf"); + } + cmp_ok(nan(), '!=', nan(), 'nan'); + cmp_ok(abs(log1p(2) - 1.09861228866811), '<', 1e-9, "log1p"); + cmp_ok(abs(log1p(1e-6) - 9.99999500000333e-07), '<', 1e-9, "log1p"); + cmp_ok(abs(log2(8) - 3), '<', 1e-9, "log2"); + SKIP: { + unless ($Config{d_signbit}) { + skip "no signbit", 2; + } + is(signbit(2), 0, "signbit 2"); # zero + ok(signbit(-2), "signbit -2"); # non-zero + } + is(round(2.25), 2, "round 2.25"); + is(round(-2.25), -2, "round -2.25"); + is(round(2.5), 3, "round 2.5"); + is(round(-2.5), -3, "round -2.5"); + is(round(2.75), 3, "round 2.75"); + is(round(-2.75), -3, "round 2.75"); + is(trunc(2.25), 2, "trunc 2.25"); + is(trunc(-2.25), -2, "trunc -2.25"); + is(trunc(2.5), 2, "trunc 2.5"); + is(trunc(-2.5), -2, "trunc -2.5"); + is(trunc(2.75), 2, "trunc 2.75"); + is(trunc(-2.75), -2, "trunc -2.75"); + ok(isless(1, 2), "isless 1 2"); + ok(!isless(2, 1), "isless 2 1"); + ok(!isless(1, 1), "isless 1 1"); + ok(!isless(1, NaN), "isless 1 NaN"); + ok(isgreater(2, 1), "isgreater 2 1"); + ok(islessequal(1, 1), "islessequal 1 1"); + ok(isunordered(1, NaN), "isunordered 1 NaN"); + cmp_ok(abs(erf(1) - 0.842700792949715), '<', 1.5e-7, "erf 1"); + cmp_ok(abs(erfc(1) - 0.157299207050285), '<', 1.5e-7, "erfc 1"); +} + done_testing(); diff --git a/ext/POSIX/t/posix.t b/ext/POSIX/t/posix.t index c2e4abe..da4aba8 100644 --- a/ext/POSIX/t/posix.t +++ b/ext/POSIX/t/posix.t @@ -8,7 +8,7 @@ BEGIN { } } -use Test::More tests => 109; +use Test::More tests => 111; use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write errno localeconv dup dup2 lseek access); @@ -176,6 +176,22 @@ SKIP: { } SKIP: { + skip("strtold() not present", 2) unless $Config{d_strtold}; + + if ($Config{d_setlocale}) { + $lc = &POSIX::setlocale(&POSIX::LC_NUMERIC); + &POSIX::setlocale(&POSIX::LC_NUMERIC, 'C'); + } + + # we're just checking that strtold works, not how accurate it is + ($n, $x) = &POSIX::strtod('2.718_ISH'); + cmp_ok(abs("2.718" - $n), '<', 1e-6, 'strtold works'); + is($x, 4, 'strtold works'); + + &POSIX::setlocale(&POSIX::LC_NUMERIC, $lc) if $Config{d_setlocale}; +} + +SKIP: { skip("strtol() not present", 2) unless $Config{d_strtol}; ($n, $x) = &POSIX::strtol('21_PENGUINS'); diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 7fed553..2950eaf 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -5,7 +5,7 @@ use strict; use warnings; use Carp; -our $VERSION = '0.63'; +our $VERSION = '0.64'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 54ee2da..777e342 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3589,6 +3589,13 @@ alias_av(AV *av, IV ix, SV *sv) CODE: av_store(av, ix, SvREFCNT_inc(sv)); +SV * +cv_name(SVREF ref, ...) + CODE: + RETVAL = SvREFCNT_inc(cv_name((CV *)ref, items>1 ? ST(1) : NULL)); + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/t/clone-with-stack.t b/ext/XS-APItest/t/clone-with-stack.t index 7a0cd29..3f68c93 100644 --- a/ext/XS-APItest/t/clone-with-stack.t +++ b/ext/XS-APItest/t/clone-with-stack.t @@ -17,7 +17,7 @@ if (not $Config{'useithreads'}) { skip_all("clone_with_stack requires threads"); } -plan(4); +plan(5); fresh_perl_is( <<'----', <<'====', undef, "minimal clone_with_stack" ); use XS::APItest; @@ -65,3 +65,16 @@ X-Y-0:1:2:3:4-Z ==== } + +{ + fresh_perl_is( <<'----', <<'====', undef, "with a lexical sub" ); +use XS::APItest; +use experimental lexical_subs=>; +my sub f { print "42\n" } +clone_with_stack(); +f(); +---- +42 +==== + +} diff --git a/ext/XS-APItest/t/cv_name.t b/ext/XS-APItest/t/cv_name.t new file mode 100644 index 0000000..cc6202a --- /dev/null +++ b/ext/XS-APItest/t/cv_name.t @@ -0,0 +1,29 @@ +use XS::APItest; +use Test::More tests => 15; +use feature "lexical_subs", "state"; +no warnings "experimental::lexical_subs"; + +is (cv_name(\&foo), 'main::foo', 'cv_name with package sub'); +is (cv_name(*{"foo"}{CODE}), 'main::foo', + 'cv_name with package sub via glob'); +is (cv_name(\*{"foo"}), 'main::foo', 'cv_name with typeglob'); +is (cv_name(\"foo"), 'foo', 'cv_name with string'); +state sub lex1; +is (cv_name(\&lex1), 'lex1', 'cv_name with lexical sub'); + +$ret = \cv_name(\&bar, $name); +is $ret, \$name, 'cv_name with package sub returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with package sub & 2nd arg'); +$ret = \cv_name(*{"bar"}{CODE}, $name); +is $ret, \$name, 'cv_name with package sub via glob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name w/pkg sub via glob & 2nd arg'); +$ret = \cv_name(\*{"bar"}, $name); +is $ret, \$name, 'cv_name with typeglob returns 2nd argument'; +is ($name, 'main::bar', 'retval of cv_name with typeglob & 2nd arg'); +$ret = \cv_name(\"bar", $name); +is $ret, \$name, 'cv_name with string returns 2nd argument'; +is ($name, 'bar', 'retval of cv_name with string & 2nd arg'); +state sub lex2; +$ret = \cv_name(\&lex2, $name); +is $ret, \$name, 'cv_name with lexical sub returns 2nd argument'; +is ($name, 'lex2', 'retval of cv_name with lexical sub & 2nd arg'); diff --git a/ext/XS-APItest/t/grok.t b/ext/XS-APItest/t/grok.t index b41cb09..e6093f2 100644 --- a/ext/XS-APItest/t/grok.t +++ b/ext/XS-APItest/t/grok.t @@ -98,9 +98,9 @@ my @groks = #[ "Infin",PERL_SCAN_TRAILING, undef, # IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING ], [ "nan", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], - [ "nanx", 0, undef, 0 ], - [ "nanx", PERL_SCAN_TRAILING, undef, - IS_NUMBER_NAN | IS_NUMBER_NOT_INT | IS_NUMBER_TRAILING], + # even without PERL_SCAN_TRAILING nan can have weird stuff trailing + [ "nanx", 0, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], + [ "nanx", PERL_SCAN_TRAILING, undef, IS_NUMBER_NAN | IS_NUMBER_NOT_INT ], ); for my $grok (@groks) { diff --git a/ext/XS-APItest/t/locale.t b/ext/XS-APItest/t/locale.t index 900fe74..42fdab8 100644 --- a/ext/XS-APItest/t/locale.t +++ b/ext/XS-APItest/t/locale.t @@ -4,6 +4,7 @@ BEGIN { } use XS::APItest; +use Config; BEGIN { eval { require POSIX; POSIX->import("locale_h") }; @@ -30,6 +31,11 @@ skip_all("no non-dot radix locales available") unless $non_dot_locale; plan tests => 2; -is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'"); -use locale; -is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'"); +SKIP: { + if ($Config{usequadmath}) { + skip "no gconvert with usequadmath", 2; + } + is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale outside 'use locale'"); + use locale; + is(test_Gconvert(4.179, 2), "4.2", "Gconvert doesn't recognize underlying locale inside 'use locale'"); +} diff --git a/ext/XS-APItest/t/printf.t b/ext/XS-APItest/t/printf.t index 76cc19f..8f43ee2 100644 --- a/ext/XS-APItest/t/printf.t +++ b/ext/XS-APItest/t/printf.t @@ -1,3 +1,11 @@ +BEGIN { + require Config; import Config; + if ($Config{usequadmath}) { + print "1..0 # Skip: usequadmath\n"; + exit(0); + } +} + use Test::More tests => 11; BEGIN { use_ok('XS::APItest') }; diff --git a/ext/attributes/attributes.pm b/ext/attributes/attributes.pm index 7c3c0b0..ebca214 100644 --- a/ext/attributes/attributes.pm +++ b/ext/attributes/attributes.pm @@ -1,6 +1,6 @@ package attributes; -our $VERSION = 0.22; +our $VERSION = 0.23; @EXPORT_OK = qw(get reftype); @EXPORT = (); diff --git a/ext/attributes/attributes.xs b/ext/attributes/attributes.xs index dbb644d..6b36812 100644 --- a/ext/attributes/attributes.xs +++ b/ext/attributes/attributes.xs @@ -97,7 +97,7 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) } break; default: - if (memEQs(name, 6, "shared")) { + if (memEQs(name, len, "shared")) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); diff --git a/ext/re/t/regop.t b/ext/re/t/regop.t index 76576b1..8ed2029 100644 --- a/ext/re/t/regop.t +++ b/ext/re/t/regop.t @@ -14,7 +14,7 @@ our $NUM_SECTS; chomp(my @strs= grep { !/^\s*\#/ } ); my $out = runperl(progfile => "t/regop.pl", stderr => 1 ); # VMS currently embeds linefeeds in the output. -$out =~ s/\cJ//g if $^O == 'VMS'; +$out =~ s/\cJ//g if $^O eq 'VMS'; my @tests = grep { /\S/ } split /(?=Compiling REx)/, $out; # on debug builds we get an EXECUTING... message in there at the top shift @tests @@ -261,9 +261,9 @@ Offsets: [3] Freeing REx: "[q]" --- #Compiling REx "^(\S{1,9}):\s*(\d+)$" -#synthetic stclass "ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY]". +#synthetic stclass "ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY]". #Final program: -# 1: BOL (2) +# 1: SBOL (2) # 2: OPEN1 (4) # 4: CURLY {1,9} (7) # 6: NPOSIXD[\s] (0) @@ -277,8 +277,8 @@ Freeing REx: "[q]" # 17: CLOSE2 (19) # 19: EOL (20) # 20: END (0) -#floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3 +#floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(SBOL) minlen 3 #Freeing REx: "^(\S{1,9}):\s*(\d+)$" -floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{08}\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(BOL) minlen 3 +floating ":" at 1..9 (checking floating) stclass ANYOF[\x{00}-\x{06}\a\b\x{0E}-\x{1F}\x{21}-\x{FF}][{utf8}0100-167F 1681-1FFF 200B-2027 202A-202E 2030-205E 2060-2FFF 3001-INFINITY] anchored(SBOL) minlen 3 %MATCHED% synthetic stclass diff --git a/globvar.sym b/globvar.sym index 3cab4bf..3e66db9 100644 --- a/globvar.sym +++ b/globvar.sym @@ -39,6 +39,11 @@ no_usym no_wrongref op_desc op_name +op_private_bitdef_ix +op_private_bitdefs +op_private_bitfields +op_private_labels +op_private_valid opargs phase_names ppaddr diff --git a/gv.c b/gv.c index 8b43d91..73fb7da 100644 --- a/gv.c +++ b/gv.c @@ -216,7 +216,7 @@ Perl_newGP(pTHX_ GV *const gv) void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) { - GV * const oldgv = CvGV(cv); + GV * const oldgv = CvNAMED(cv) ? NULL : SvANY(cv)->xcv_gv_u.xcv_gv; HEK *hek; PERL_ARGS_ASSERT_CVGV_SET; @@ -232,7 +232,11 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) sv_del_backref(MUTABLE_SV(oldgv), MUTABLE_SV(cv)); } } - else if ((hek = CvNAME_HEK(cv))) unshare_hek(hek); + else if ((hek = CvNAME_HEK(cv))) { + unshare_hek(hek); + CvNAMED_off(cv); + CvLEXICAL_off(cv); + } SvANY(cv)->xcv_gv_u.xcv_gv = gv; assert(!CvCVGV_RC(cv)); @@ -248,6 +252,37 @@ Perl_cvgv_set(pTHX_ CV* cv, GV* gv) } } +/* Convert CvSTASH + CvNAME_HEK into a GV. Conceptually, all subs have a + GV, but for efficiency that GV may not in fact exist. This function, + called by CvGV, reifies it. */ + +GV * +Perl_cvgv_from_hek(pTHX_ CV *cv) +{ + GV *gv; + SV **svp; + PERL_ARGS_ASSERT_CVGV_FROM_HEK; + assert(SvTYPE(cv) == SVt_PVCV); + if (!CvSTASH(cv)) return NULL; + ASSUME(CvNAME_HEK(cv)); + svp = hv_fetchhek(CvSTASH(cv), CvNAME_HEK(cv), 0); + gv = MUTABLE_GV(svp && *svp ? *svp : newSV(0)); + if (!isGV(gv)) + gv_init_pvn(gv, CvSTASH(cv), HEK_KEY(CvNAME_HEK(cv)), + HEK_LEN(CvNAME_HEK(cv)), + SVf_UTF8 * !!HEK_UTF8(CvNAME_HEK(cv))); + if (!CvNAMED(cv)) { /* gv_init took care of it */ + assert (SvANY(cv)->xcv_gv_u.xcv_gv == gv); + return gv; + } + unshare_hek(CvNAME_HEK(cv)); + CvNAMED_off(cv); + SvANY(cv)->xcv_gv_u.xcv_gv = gv; + if (svp && *svp) SvREFCNT_inc_simple_void_NN(gv); + CvCVGV_RC_on(cv); + return gv; +} + /* Assign CvSTASH(cv) = st, handling weak references. */ void @@ -343,10 +378,9 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag assert (!(proto && has_constant)); if (has_constant) { - /* The constant has to be a simple scalar type. */ + /* The constant has to be a scalar, array or subroutine. */ switch (SvTYPE(has_constant)) { case SVt_PVHV: - case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", @@ -382,7 +416,21 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag gv_name_set(gv, name, len, GV_ADD | ( flags & SVf_UTF8 ? SVf_UTF8 : 0 )); if (flags & GV_ADDMULTI || doproto) /* doproto means it */ GvMULTI_on(gv); /* _was_ mentioned */ - if (doproto) { + if (has_constant && SvTYPE(has_constant) == SVt_PVCV) { + /* Not actually a constant. Just a regular sub. */ + CV * const cv = (CV *)has_constant; + GvCV_set(gv,cv); + if (CvSTASH(cv) == stash && ( + CvNAME_HEK(cv) == GvNAME_HEK(gv) + || ( HEK_LEN(CvNAME_HEK(cv)) == HEK_LEN(GvNAME_HEK(gv)) + && HEK_FLAGS(CvNAME_HEK(cv)) != HEK_FLAGS(GvNAME_HEK(gv)) + && HEK_UTF8(CvNAME_HEK(cv)) == HEK_UTF8(GvNAME_HEK(gv)) + && memEQ(HEK_KEY(CvNAME_HEK(cv)), GvNAME(gv), GvNAMELEN(gv)) + ) + )) + CvGV_set(cv,gv); + } + else if (doproto) { CV *cv; if (has_constant) { /* newCONSTSUB takes ownership of the reference from us. */ @@ -1053,7 +1101,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le GV* stubgv; GV* autogv; - if (CvANON(cv) || !CvGV(cv)) + if (CvANON(cv) || CvLEXICAL(cv)) stubgv = gv; else { stubgv = CvGV(cv); @@ -1198,7 +1246,7 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags) * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ - varstash = GvSTASH(CvGV(cv)); + varstash = CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); ENTER; @@ -1310,11 +1358,22 @@ Flags may be one of: The most important of which are probably GV_ADD and SVf_UTF8. +Note, use of C instead of C where possible is strongly +recommended for performance reasons. + =cut */ -HV* -Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) +/* +gv_stashpvn_internal + +Perform the internal bits of gv_stashsvpvn_cached. You could think of this +as being one half of the logic. Not to be called except from gv_stashsvpvn_cached(). + +*/ + +PERL_STATIC_INLINE HV* +S_gv_stashpvn_internal(pTHX_ const char *name, U32 namelen, I32 flags) { char smallbuf[128]; char *tmpbuf; @@ -1322,7 +1381,7 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) GV *tmpgv; U32 tmplen = namelen + 2; - PERL_ARGS_ASSERT_GV_STASHPVN; + PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL; if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; @@ -1352,22 +1411,81 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) } /* +gv_stashsvpvn_cached + +Returns a pointer to the stash for a specified package, possibly +cached. Implements both C and C. + +Requires one of either namesv or namepv to be non-null. + +See C for details on "flags". + +Note the sv interface is strongly preferred for performance reasons. + +*/ + +#define PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED \ + assert(namesv || name) + +PERL_STATIC_INLINE HV* +S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char *name, U32 namelen, I32 flags) +{ + HV* stash; + HE* he; + + PERL_ARGS_ASSERT_GV_STASHSVPVN_CACHED; + + he = (HE *)hv_common( + PL_stashcache, namesv, name, namelen, + (flags & SVf_UTF8) ? HVhek_UTF8 : 0, 0, NULL, 0 + ); + + if (he) return INT2PTR(HV*,SvIVX(HeVAL(he))); + else if (flags & GV_CACHE_ONLY) return NULL; + + if (namesv) { + if (SvOK(namesv)) { /* prevent double uninit warning */ + STRLEN len; + name = SvPV_const(namesv, len); + namelen = len; + flags |= SvUTF8(namesv); + } else { + name = ""; namelen = 0; + } + } + stash = gv_stashpvn_internal(name, namelen, flags); + + if (stash && namelen) { + SV* const ref = newSViv(PTR2IV(stash)); + (void)hv_store(PL_stashcache, name, + (flags & SVf_UTF8) ? -(I32)namelen : (I32)namelen, ref, 0); + } + + return stash; +} + +HV* +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) +{ + PERL_ARGS_ASSERT_GV_STASHPVN; + return gv_stashsvpvn_cached(NULL, name, namelen, flags); +} + +/* =for apidoc gv_stashsv Returns a pointer to the stash for a specified package. See C. +Note this interface is strongly preferred over C for performance reasons. + =cut */ HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { - STRLEN len; - const char * const ptr = SvPV_const(sv,len); - PERL_ARGS_ASSERT_GV_STASHSV; - - return gv_stashpvn(ptr, len, flags | SvUTF8(sv)); + return gv_stashsvpvn_cached(sv, NULL, 0, flags); } @@ -1613,17 +1731,19 @@ S_find_default_stash(pTHX_ HV **stash, const char *name, STRLEN len, if (!*stash) { if (add && !PL_in_clean_all) { - SV * const err = Perl_mess(aTHX_ + GV *gv; + qerror(Perl_mess(aTHX_ "Global symbol \"%s%"UTF8f - "\" requires explicit package name", + "\" requires explicit package name (did you forget to " + "declare \"my %s%"UTF8f"\"?)", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), UTF8fARG(is_utf8, len, name)); - GV *gv; - if (is_utf8) - SvUTF8_on(err); - qerror(err); + : ""), UTF8fARG(is_utf8, len, name), + (sv_type == SVt_PV ? "$" + : sv_type == SVt_PVAV ? "@" + : sv_type == SVt_PVHV ? "%" + : ""), UTF8fARG(is_utf8, len, name))); /* To maintain the output of errors after the strict exception * above, and to keep compat with older releases, rather than * placing the variables in the pad, we place @@ -2533,11 +2653,14 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) numifying instead of C's "+0". */ gv = Perl_gv_fetchmeth_pvn(aTHX_ stash, cooky, l, -1, 0); cv = 0; - if (gv && (cv = GvCV(gv))) { - if(GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")){ - const char * const hvname = HvNAME_get(GvSTASH(CvGV(cv))); - if (hvname && HEK_LEN(HvNAME_HEK(GvSTASH(CvGV(cv)))) == 8 - && strEQ(hvname, "overload")) { + if (gv && (cv = GvCV(gv)) && CvHASGV(cv)) { + const HEK * const gvhek = + CvNAMED(cv) ? CvNAME_HEK(cv) : GvNAME_HEK(CvGV(cv)); + const HEK * const stashek = + HvNAME_HEK(CvNAMED(cv) ? CvSTASH(cv) : GvSTASH(CvGV(cv))); + if (HEK_LEN(gvhek) == 3 && strEQ(HEK_KEY(gvhek), "nil") + && stashek && HEK_LEN(stashek) == 8 + && strEQ(HEK_KEY(stashek), "overload")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ @@ -2571,7 +2694,6 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing) } } cv = GvCV(gv = ngv); - } } DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), @@ -3384,7 +3506,7 @@ Perl_gv_try_downgrade(pTHX_ GV *gv) (void)hv_deletehek(stash, gvnhek, G_DISCARD); } else if (GvMULTI(gv) && cv && SvREFCNT(cv) == 1 && !SvOBJECT(cv) && !SvMAGICAL(cv) && !SvREADONLY(cv) && - CvSTASH(cv) == stash && CvGV(cv) == gv && + CvSTASH(cv) == stash && !CvNAMED(cv) && CvGV(cv) == gv && CvCONST(cv) && !CvMETHOD(cv) && !CvLVALUE(cv) && !CvUNIQUE(cv) && !CvNODEBUG(cv) && !CvCLONE(cv) && !CvCLONED(cv) && !CvANON(cv) && (namehek = GvNAME_HEK(gv)) && diff --git a/gv.h b/gv.h index d7ca92f..2b29b6d 100644 --- a/gv.h +++ b/gv.h @@ -12,13 +12,14 @@ struct gp { SV * gp_sv; /* scalar value */ struct io * gp_io; /* filehandle value */ CV * gp_cv; /* subroutine value */ - U32 gp_cvgen; /* generational validity of cached gv_cv */ + U32 gp_cvgen; /* generational validity of cached gp_cv */ U32 gp_refcnt; /* how many globs point to this? */ HV * gp_hv; /* hash value */ AV * gp_av; /* array value */ CV * gp_form; /* format value */ GV * gp_egv; /* effective gv, if *glob */ line_t gp_line; /* line first declared at (for -w) */ + U32 gp_flags; HEK * gp_file_hek; /* file first declared in (for -w) */ }; @@ -139,6 +140,8 @@ Return the CV from the GV. #define GvCVGEN(gv) (GvGP(gv)->gp_cvgen) #define GvCVu(gv) (GvGP(gv)->gp_cvgen ? NULL : GvGP(gv)->gp_cv) +#define GvGPFLAGS(gv) (GvGP(gv)->gp_flags) + #define GvLINE(gv) (GvGP(gv)->gp_line) #define GvFILE_HEK(gv) (GvGP(gv)->gp_file_hek) #define GvFILEx(gv) HEK_KEY(GvFILE_HEK(gv)) @@ -156,7 +159,7 @@ Return the CV from the GV. #define GVf_INTRO 0x01 #define GVf_MULTI 0x02 #define GVf_ASSUMECV 0x04 -#define GVf_IN_PAD 0x08 +/* UNUSED 0x08 */ #define GVf_IMPORTED 0xF0 #define GVf_IMPORTED_SV 0x10 #define GVf_IMPORTED_AV 0x20 @@ -195,11 +198,16 @@ Return the CV from the GV. #define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV) #define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV) -#define GvIN_PAD(gv) (GvFLAGS(gv) & GVf_IN_PAD) -#define GvIN_PAD_on(gv) (GvFLAGS(gv) |= GVf_IN_PAD) -#define GvIN_PAD_off(gv) (GvFLAGS(gv) &= ~GVf_IN_PAD) +#define GPf_ALIASED_SV 1 + +#define GvALIASED_SV(gv) (GvGPFLAGS(gv) & GPf_ALIASED_SV) +#define GvALIASED_SV_on(gv) (GvGPFLAGS(gv) |= GPf_ALIASED_SV) +#define GvALIASED_SV_off(gv) (GvGPFLAGS(gv) &= ~GPf_ALIASED_SV) #ifndef PERL_CORE +# define GvIN_PAD(gv) 0 +# define GvIN_PAD_on(gv) NOOP +# define GvIN_PAD_off(gv) NOOP # define Nullgv Null(GV*) #endif @@ -221,7 +229,7 @@ Return the CV from the GV. #define GV_ADDMULTI 0x02 /* add, pretending it has been added already; used also by gv_init_* */ #define GV_ADDWARN 0x04 /* add, but warn if symbol wasn't already there */ -#define GV_ADDINEVAL 0x08 /* add, as though we're doing so within an eval */ + /* 0x08 UNUSED */ #define GV_NOINIT 0x10 /* add, but don't init symbol, if type != PVGV */ /* This is used by toke.c to avoid turing placeholder constants in the symbol table into full PVGVs with attached constant subroutines. */ @@ -235,6 +243,8 @@ Return the CV from the GV. #define GV_ADDMG 0x400 /* add if magical */ #define GV_NO_SVGMAGIC 0x800 /* Skip get-magic on an SV argument; used only by gv_fetchsv(_nomg) */ +#define GV_CACHE_ONLY 0x1000 /* return stash only if found in cache; + used only in flags parameter to gv_stash* family */ /* Flags for gv_fetchmeth_pvn and gv_autoload_pvn*/ #define GV_SUPER 0x1000 /* SUPER::method */ diff --git a/handy.h b/handy.h index c5c4d4b..511bba3 100644 --- a/handy.h +++ b/handy.h @@ -963,7 +963,8 @@ patched there. The file as of this writing is cpan/Devel-PPPort/parts/inc/misc # define _CC_QUOTEMETA 21 # define _CC_NON_FINAL_FOLD 22 # define _CC_IS_IN_SOME_FOLD 23 -/* Unused: 24-31 +# define _CC_MNEMONIC_CNTRL 24 +/* Unused: 25-31 * If more bits are needed, one could add a second word for non-64bit * QUAD_IS_INT systems, using some #ifdefs to distinguish between having a 2nd * word or not. The IS_IN_SOME_FOLD bit is the most easily expendable, as it @@ -1056,7 +1057,7 @@ EXTCONST U32 PL_charclass[]; # define isALPHANUMERIC_A(c) _generic_isCC_A(c, _CC_ALPHANUMERIC) # define isBLANK_A(c) _generic_isCC_A(c, _CC_BLANK) # define isCNTRL_A(c) _generic_isCC_A(c, _CC_CNTRL) -# define isDIGIT_A(c) _generic_isCC(c, _CC_DIGIT) +# define isDIGIT_A(c) _generic_isCC(c, _CC_DIGIT) /* No non-ASCII digits */ # define isGRAPH_A(c) _generic_isCC_A(c, _CC_GRAPH) # define isLOWER_A(c) _generic_isCC_A(c, _CC_LOWER) # define isPRINT_A(c) _generic_isCC_A(c, _CC_PRINT) @@ -1065,7 +1066,7 @@ EXTCONST U32 PL_charclass[]; # define isSPACE_A(c) _generic_isCC_A(c, _CC_SPACE) # define isUPPER_A(c) _generic_isCC_A(c, _CC_UPPER) # define isWORDCHAR_A(c) _generic_isCC_A(c, _CC_WORDCHAR) -# define isXDIGIT_A(c) _generic_isCC(c, _CC_XDIGIT) +# define isXDIGIT_A(c) _generic_isCC(c, _CC_XDIGIT) /* No non-ASCII xdigits */ # define isIDFIRST_A(c) _generic_isCC_A(c, _CC_IDFIRST) # define isALPHA_L1(c) _generic_isCC(c, _CC_ALPHA) # define isALPHANUMERIC_L1(c) _generic_isCC(c, _CC_ALPHANUMERIC) @@ -1096,6 +1097,8 @@ EXTCONST U32 PL_charclass[]; _generic_isCC(c, _CC_NON_FINAL_FOLD) # define _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \ _generic_isCC(c, _CC_IS_IN_SOME_FOLD) +# define _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) \ + _generic_isCC(c, _CC_MNEMONIC_CNTRL) #else /* else we don't have perl.h */ /* If we don't have perl.h, we are compiling a utility program. Below we @@ -1706,6 +1709,25 @@ typedef U32 line_t; * both ASCII and EBCDIC the last 3 bits of the octal digits range from 0-7. */ #define OCTAL_VALUE(c) (__ASSERT_(isOCTAL(c)) (7 & (c))) +/* Efficiently returns a boolean as to if two native characters are equivalent + * case-insenstively. At least one of the characters must be one of [A-Za-z]; + * the ALPHA in the name is to remind you of that. This is asserted() in + * DEBUGGING builds. Because [A-Za-z] are invariant under UTF-8, this macro + * works (on valid input) for both non- and UTF-8-encoded bytes. + * + * When one of the inputs is a compile-time constant and gets folded by the + * compiler, this reduces to an AND and a TEST. On both EBCDIC and ASCII + * machines, 'A' and 'a' differ by a single bit; the same with the upper and + * lower case of all other ASCII-range alphabetics. On ASCII platforms, they + * are 32 apart; on EBCDIC, they are 64. At compile time, this uses an + * exclusive 'or' to find that bit and then inverts it to form a mask, with + * just a single 0, in the bit position where the upper- and lowercase differ. + * */ +#define isALPHA_FOLD_EQ(c1, c2) \ + (__ASSERT_(isALPHA_A(c1) || isALPHA_A(c2)) \ + ((c1) & ~('A' ^ 'a')) == ((c2) & ~('A' ^ 'a'))) +#define isALPHA_FOLD_NE(c1, c2) (! isALPHA_FOLD_EQ((c1), (c2))) + /* =head1 Memory Management diff --git a/hints/aix.sh b/hints/aix.sh index 675cfa6..956e806 100644 --- a/hints/aix.sh +++ b/hints/aix.sh @@ -34,7 +34,6 @@ d_setrgid='undef' d_setruid='undef' alignbytes=8 - case "$usemymalloc" in '') usemymalloc='n' ;; esac @@ -544,4 +543,107 @@ if [ -f "/opt/freeware/include/gdbm/dbm.h" ] || i_gdbm='undef' i_gdbmndbm='undef' fi + +# Some releases (and patch levels) of AIX cannot have both +# long doubles and infinity (infinity plus one equals ... NaNQ!) +# +# This deficiency, and others, is apparently a well-documented feature +# of AIX 128-bit long doubles: +# +# http://www-01.ibm.com/support/knowledgecenter/ssw_aix_61/com.ibm.aix.genprogc/128bit_long_double_floating-point_datatype.htm +# +# The URL seems to be fragile, it has moved around over the years, +# but searching AIX docs at ibm.com for "128-bit long double +# floating-point data type" should surface the latest info. +# +# Some salient points: +# +# +# * The 128-bit implementation differs from the IEEE standard for long double +# in the following ways: +# * Supports only round-to-nearest mode. If the application changes +# the rounding mode, results are undefined. +# * Does not fully support the IEEE special numbers NaN and INF. +# * Does not support IEEE status flags for overflow, underflow, +# and other conditions. These flags have no meaning for the 128-bit +# long double inplementation. +# * The 128-bit long double data type does not support the following math +# APIs: atanhl, cbrtl, copysignl, exp2l, expm1l, fdiml, fmal, fmaxl, +# fminl, hypotl, ilogbl, llrintl, llroundl, log1pl, log2l, logbl, +# lrintl, lroundl, nanl, nearbyintl, nextafterl, nexttoward, +# nexttowardf, nexttowardl, remainderl, remquol, rintl, roundl, +# scalblnl, scalbnl, tgammal, and truncl. +# * The representation of 128-bit long double numbers means that the +# following macros required by standard C in the values.h file do not +# have clear meaning: +# * Number of bits in the mantissa (LDBL_MANT_DIG) +# * Epsilon (LBDL_EPSILON) +# * Maximum representable finite value (LDBL_MAX) +# +# +# The missing math functions affect the POSIX extension math interfaces. + +case "$uselongdouble" in +define) + echo "Checking if your infinity is working with long doubles..." >&4 + cat > inf$$.c < +#include +int main() { + long double inf = INFINITY; + long double one = 1.0L; + printf("%Lg\n", inf + one); +} +EOF + $cc -qlongdouble -o inf$$ inf$$.c -lm + case `./inf$$` in + INF) echo "Your infinity is working correctly with long doubles." >&4 ;; + *) # NaNQ + echo " " + echo "Your infinity is broken, I suggest disabling long doubles." >&4 + rp="Disable long doubles?" + dflt="y" + . UU/myread + case "$ans" in + [Yy]*) + echo "Okay, disabling long doubles." >&4 + uselongdouble=undef + ccflags=`echo " $ccflags " | sed -e 's/ -qlongdouble / /'` + libswanted=`echo " $libswanted " | sed -e 's/ c128/ /'` + lddlflags=`echo " $lddlflags " | sed -e 's/ -lc128 / /'` + ;; + *) + echo "Okay, keeping long doubles enabled." >&4 + ;; + esac + ;; + esac + rm -f inf$$.c inf$$ + ;; +esac + +# Some releases (and patch levels) of AIX have a broken powl(). +pp_cflags='' +case "$uselongdouble" in +define) + echo "Checking if your powl() is broken..." >&4 + cat > powl$$.c < +#include +int main() { + printf("%Lg\n", powl(-3.0L, 2.0L)); +} +EOF + $cc -qlongdouble -o powl$$ powl$$.c -lm + case `./powl$$` in + 9) echo "Your powl() is working correctly." >&4 ;; + *) + echo "Your powl() is broken, will use a workaround." >&4 + pp_cflags='ccflags="$ccflags -DHAS_AIX_POWL_NEG_BASE_BUG"' + ;; + esac + rm -f powl$$.c powl$$ + ;; +esac + # EOF diff --git a/hints/catamount.sh b/hints/catamount.sh index db87e1a..ac118dd 100644 --- a/hints/catamount.sh +++ b/hints/catamount.sh @@ -31,11 +31,11 @@ # mkdir -p /opt/perl-catamount # mkdir -p /opt/perl-catamount/include # mkdir -p /opt/perl-catamount/lib -# mkdir -p /opt/perl-catamount/lib/perl5/5.21.3 +# mkdir -p /opt/perl-catamount/lib/perl5/5.21.4 # mkdir -p /opt/perl-catamount/bin # cp *.h /opt/perl-catamount/include # cp libperl.a /opt/perl-catamount/lib -# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.3 +# cp -pr lib/* /opt/perl-catamount/lib/perl5/5.21.4 # cp miniperl perl run.sh cc.sh /opt/perl-catamount/lib # # With the headers and the libperl.a you can embed Perl to your Catamount diff --git a/hints/darwin.sh b/hints/darwin.sh index 7c3f818..da79297 100644 --- a/hints/darwin.sh +++ b/hints/darwin.sh @@ -24,6 +24,12 @@ case "$osvers" in ;; esac +# finite() deprecated in 10.9, use isfinite() instead. +case "$osvers" in +[1-8].*) ;; +*) d_finite='undef' ;; +esac + # This was previously used in all but causes three cases # (no -Ddprefix=, -Dprefix=/usr, -Dprefix=/some/thing/else) # but that caused too much grief. @@ -168,7 +174,14 @@ esac # Allow the user to override ld, but modify it as necessary below case "$ld" in - '') ld='cc';; + '') case "$cc" in + # If the cc is explicitly something else than cc (or empty), + # set the ld to be that explicitly something else. Conversely, + # if the cc is 'cc' (or empty), set the ld to be 'cc'. + cc|'') ld='cc';; + *) ld="$cc" ;; + esac + ;; esac # Perl bundles do not expect two-level namespace, added in Darwin 1.4. @@ -322,6 +335,11 @@ i_dbm=undef; # NeilW says this should be acceptable on all darwin versions. ranlib='ranlib' +# Catch MacPorts gcc/g++ extra libdir +case "$($cc -v 2>&1)" in +*"MacPorts gcc"*) loclibpth="$loclibpth /opt/local/lib/libgcc" ;; +esac + ## # Build process ## diff --git a/hints/hpux.sh b/hints/hpux.sh index 598b199..39150be 100644 --- a/hints/hpux.sh +++ b/hints/hpux.sh @@ -765,3 +765,18 @@ case "$d_oldpthreads" in # H.Merijn says it's not 1998 anymore: ODBM is not needed, # and it seems to be buggy in HP-UX anyway. i_dbm=undef + +# In HP-UXes prior to 11.23 strtold() returned a HP-UX +# specific union called long_double, not a C99 long double. +case "`grep 'double strtold.const' /usr/include/stdlib.h`" in +*"long double strtold"*) ;; # strtold should be safe. +*) echo "Looks like your strtold() is non-standard..." >&4 + d_strtold=undef ;; +esac + +# In pre-11 HP-UXes there really isn't isfinite(), despite what +# Configure might think. (There is finite(), though.) +case "`grep 'isfinite' /usr/include/math.h`" in +*"isfinite"*) ;; +*) d_isfinite=undef ;; +esac diff --git a/hints/linux-android.sh b/hints/linux-android.sh index 76cfceb..fdfe64a 100644 --- a/hints/linux-android.sh +++ b/hints/linux-android.sh @@ -251,6 +251,9 @@ fi # Cross-compiling with adb case "$usecrosscompile" in define) +# The tests for this in Configure doesn't play nicely with +# cross-compiling +d_procselfexe="define" if $test "X$hostosname" = "Xdarwin"; then firstmakefile=GNUmakefile; fi @@ -280,9 +283,16 @@ case "$src" in ;; esac -$cat <> $pwd/config.arch +$cat <<'EOO' >> $pwd/config.arch osname='android' +eval "libpth='$libpth /system/lib /vendor/lib'" + +if $test "X$procselfexe" = X; then + case "$d_procselfexe" in + define) procselfexe='"/proc/self/exe"';; + esac +fi EOO # Android is a linux variant, so run those hints. diff --git a/inline.h b/inline.h index 0792694..ad6edf2 100644 --- a/inline.h +++ b/inline.h @@ -25,6 +25,14 @@ S_av_top_index(pTHX_ AV *av) /* ------------------------------- cv.h ------------------------------- */ +PERL_STATIC_INLINE GV * +S_CvGV(pTHX_ CV *sv) +{ + return CvNAMED(sv) + ? Perl_cvgv_from_hek(aTHX_ sv) + : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv; +} + PERL_STATIC_INLINE I32 * S_CvDEPTHp(const CV * const sv) { diff --git a/intrpvar.h b/intrpvar.h index 9dd4e16..362d0cb 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -60,6 +60,9 @@ PERLVAR(I, markstack, I32 *) /* stack_sp locations we're PERLVAR(I, markstack_ptr, I32 *) PERLVAR(I, markstack_max, I32 *) +PERLVARI(I, sawalias, bool, FALSE) /* must enable common-vars + pessimisation */ + #ifdef PERL_HASH_RANDOMIZE_KEYS #ifdef USE_PERL_PERTURB_KEYS PERLVARI(I, hash_rand_bits_enabled, U8, 1) /* used to randomize hash stuff 0 == no-random, 1 == random, 2 == determinsitic */ @@ -171,7 +174,7 @@ PERLVAR(I, statgv, GV *) PERLVARI(I, statname, SV *, NULL) #ifdef HAS_TIMES -/* Will be removed soon after v5.21.3. See RT #121351 */ +/* Will be removed soon after v5.21.4. See RT #121351 */ PERLVAR(I, timesbuf, struct tms) #endif @@ -531,7 +534,9 @@ PERLVAR(I, subline, I32) /* line this subroutine began on */ PERLVAR(I, min_intro_pending, I32) /* start of vars to introduce */ PERLVAR(I, max_intro_pending, I32) /* end of vars to introduce */ -PERLVAR(I, padix, I32) /* max used index in current "register" pad */ +PERLVAR(I, padix, I32) /* lowest unused index - 1 + in current "register" pad */ +PERLVAR(I, constpadix, I32) /* lowest unused for constants */ PERLVAR(I, padix_floor, I32) /* how low may inner block reset padix */ @@ -578,6 +583,7 @@ PERLVAR(I, numeric_radix_sv, SV *) /* The radix separator if not '.' */ PERLVAR(I, Latin1, SV *) PERLVAR(I, UpperLatin1, SV *) /* Code points 128 - 255 */ PERLVAR(I, AboveLatin1, SV *) +PERLVAR(I, InBitmap, SV *) PERLVAR(I, NonL1NonFinalFold, SV *) PERLVAR(I, HasMultiCharFold, SV *) @@ -733,7 +739,7 @@ PERLVAR(I, debug_pad, struct perl_debug_pad) /* always needed because of the re /* Hook for File::Glob */ PERLVARI(I, globhook, globhook_t, NULL) -/* The last unconditional member of the interpreter structure when 5.21.3 was +/* The last unconditional member of the interpreter structure when 5.21.4 was released. The offset of the end of this is baked into a global variable in any shared perl library which will allow a sanity test in future perl releases. */ diff --git a/l1_char_class_tab.h b/l1_char_class_tab.h index ccc7014..fc262be 100644 --- a/l1_char_class_tab.h +++ b/l1_char_class_tab.h @@ -15,13 +15,13 @@ /* U+04 EOT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE), -/* U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -35,7 +35,7 @@ /* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+1A SUB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* U+1C FS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+1D GS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+1E RS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -276,15 +276,15 @@ /* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE), +/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -292,8 +292,8 @@ /* U+12 DC2 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -310,7 +310,7 @@ /* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x25 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), /* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -318,7 +318,7 @@ /* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -539,15 +539,15 @@ /* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE), +/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -556,7 +556,7 @@ /* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x15 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -571,9 +571,9 @@ /* 0x22 U+82 BPH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x23 U+83 NBH */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x25 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* 0x25 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -581,7 +581,7 @@ /* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -802,15 +802,15 @@ /* U+02 STX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+03 ETX */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x04 U+9C ST */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE), +/* 0x05 U+09 HT */ (1U<<_CC_ASCII)|(1U<<_CC_BLANK)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x06 U+86 SSA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x07 U+7F DEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x08 U+97 EPA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x09 U+8D RI */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x0A U+8E SS2 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0B VT */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), +/* U+0C FF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* U+0D CR */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), /* U+0E SO */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+0F SI */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+10 DLE */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -818,8 +818,8 @@ /* U+12 DC2 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+13 DC3 */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x14 U+9D OSC */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), -/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x15 U+0A LF */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE)|(1U<<_CC_MNEMONIC_CNTRL), +/* 0x16 U+08 BS */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x17 U+87 ESA */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+18 CAN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* U+19 EOM */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -836,7 +836,7 @@ /* 0x24 U+84 IND */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x25 U+85 NEL */ (1U<<_CC_CNTRL)|(1U<<_CC_PSXSPC)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_SPACE)|(1U<<_CC_VERTSPACE), /* 0x26 U+17 ETB */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x27 U+1B ESC */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x28 U+88 HTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x29 U+89 HTJ */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2A U+8A VTS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), @@ -844,7 +844,7 @@ /* 0x2C U+8C PLU */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2D U+05 ENQ */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x2E U+06 ACK */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), -/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), +/* 0x2F U+07 BEL */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA)|(1U<<_CC_MNEMONIC_CNTRL), /* 0x30 U+90 DCS */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x31 U+91 PU1 */ (1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), /* 0x32 U+16 SYN */ (1U<<_CC_ASCII)|(1U<<_CC_CNTRL)|(1U<<_CC_QUOTEMETA), diff --git a/lib/.gitignore b/lib/.gitignore index 8d281ca..816da15 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -161,6 +161,7 @@ /SelfLoader.pm /Socket.pm /Storable.pm +/Sub/ /Sys/ /TAP/ /Term/ diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index 470c829..ab85acf 100644 --- a/lib/B/Deparse.pm +++ b/lib/B/Deparse.pm @@ -17,10 +17,11 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER OPpSORT_REVERSE SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG + SVpad_TYPED CVf_METHOD CVf_LVALUE PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED); -$VERSION = '1.27'; +$VERSION = '1.28'; use strict; use vars qw/$AUTOLOAD/; use warnings (); @@ -221,8 +222,9 @@ BEGIN { # curcvlex: # Cached hash of lexical variables for curcv: keys are # names prefixed with "m" or "o" (representing my/our), and -# each value is an array of pairs, indicating the cop_seq of scopes -# in which a var of that name is valid. +# each value is an array with two elements indicating the cop_seq +# of scopes in which a var of that name is valid and a third ele- +# ment referencing the pad name. # # curcop: # COP for statement being deparsed @@ -1191,12 +1193,24 @@ sub maybe_parens_func { } } +sub find_our_type { + my ($self, $name) = @_; + $self->populate_curcvlex() if !defined $self->{'curcvlex'}; + my $seq = $self->{'curcop'}->cop_seq; + for my $a (@{$self->{'curcvlex'}{"o$name"}}) { + my ($st, undef, $padname) = @$a; + if ($st == $seq && $padname->FLAGS & SVpad_TYPED) { + return $padname->SvSTASH->NAME; + } + } + return ''; +} + sub maybe_local { my $self = shift; my($op, $cx, $text) = @_; my $our_intro = ($op->name =~ /^(gv|rv2)[ash]v$/) ? OPpOUR_INTRO : 0; - if ($op->private & (OPpLVAL_INTRO|$our_intro) - and not $self->{'avoid_local'}{$$op}) { + if ($op->private & (OPpLVAL_INTRO|$our_intro)) { my $our_local = ($op->private & OPpLVAL_INTRO) ? "local" : "our"; if( $our_local eq 'our' ) { if ( $text !~ /^\W(\w+::)*\w+\z/ @@ -1205,7 +1219,12 @@ sub maybe_local { die "Unexpected our($text)\n"; } $text =~ s/(\w+::)+//; + + if (my $type = $self->find_our_type($text)) { + $our_local .= ' ' . $type; + } } + return $text if $self->{'avoid_local'}{$$op}; if (want_scalar($op)) { return "$our_local $text"; } else { @@ -1236,11 +1255,15 @@ sub padname_sv { sub maybe_my { my $self = shift; - my($op, $cx, $text, $forbid_parens) = @_; + my($op, $cx, $padname, $forbid_parens) = @_; + my $text = $padname->PVX; if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) { my $my = $op->private & OPpPAD_STATE ? $self->keyword("state") : "my"; + if ($padname->FLAGS & SVpad_TYPED) { + $my .= ' ' . $padname->SvSTASH->NAME; + } if ($forbid_parens || want_scalar($op)) { return "$my $text"; } else { @@ -1397,9 +1420,14 @@ sub gv_name { my $self = shift; my $gv = shift; my $raw = shift; -Carp::confess() unless ref($gv) eq "B::GV"; - my $stash = $gv->STASH->NAME; - my $name = $raw ? $gv->NAME : $gv->SAFENAME; +#Carp::confess() unless ref($gv) eq "B::GV"; + my $cv = $gv->FLAGS & SVf_ROK ? $gv->RV : 0; + my $stash = ($cv || $gv)->STASH->NAME; + my $name = $raw + ? $cv ? $cv->NAME_HEK || $cv->GV->NAME : $gv->NAME + : $cv + ? B::safename($cv->NAME_HEK || $cv->GV->NAME) + : $gv->SAFENAME; if ($stash eq 'main' && $name =~ /^::/) { $stash = '::'; } @@ -1517,7 +1545,7 @@ sub populate_curcvlex { push @{$self->{'curcvlex'}{ ($ns[$i]->FLAGS & SVpad_OUR ? 'o' : 'm') . $name - }}, [$seq_st, $seq_en]; + }}, [$seq_st, $seq_en, $ns[$i]]; } } } @@ -2963,6 +2991,7 @@ sub pp_list { return '' if class($kid) eq 'NULL'; my $lop; my $local = "either"; # could be local(...), my(...), state(...) or our(...) + my $type; for ($lop = $kid; !null($lop); $lop = $lop->sibling) { # This assumes that no other private flags equal 128, and that # OPs that store things other than flags in their op_private, @@ -2973,14 +3002,16 @@ sub pp_list { # XXX This really needs to be rewritten to accept only those ops # known to take the OPpLVAL_INTRO flag. + my $lopname = $lop->name; if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO) - or $lop->name eq "undef") - or $lop->name =~ /^(?:entersub|exit|open|split)\z/) + or $lopname eq "undef") + or $lopname =~ /^(?:entersub|exit|open|split)\z/) { $local = ""; # or not last; } - if ($lop->name =~ /^pad[ash]v$/) { + my $newtype; + if ($lopname =~ /^pad[ash]v$/) { if ($lop->private & OPpPAD_STATE) { # state() ($local = "", last) if $local =~ /^(?:local|our|my)$/; $local = "state"; @@ -2988,23 +3019,39 @@ sub pp_list { ($local = "", last) if $local =~ /^(?:local|our|state)$/; $local = "my"; } - } elsif ($lop->name =~ /^(gv|rv2)[ash]v$/ + my $padname = $self->padname_sv($lop->targ); + if ($padname->FLAGS & SVpad_TYPED) { + $newtype = $padname->SvSTASH->NAME; + } + } elsif ($lopname =~ /^(?:gv|rv2)([ash])v$/ && $lop->private & OPpOUR_INTRO - or $lop->name eq "null" && $lop->first->name eq "gvsv" + or $lopname eq "null" && $lop->first->name eq "gvsv" && $lop->first->private & OPpOUR_INTRO) { # our() ($local = "", last) if $local =~ /^(?:my|local|state)$/; $local = "our"; - } elsif ($lop->name ne "undef" + my $funny = !$1 || $1 eq 's' ? '$' : $1 eq 'a' ? '@' : '%'; + if (my $t = $self->find_our_type( + $funny . $self->gv_or_padgv($lop->first)->NAME + )) { + $newtype = $t; + } + } elsif ($lopname ne "undef" # specifically avoid the "reverse sort" optimisation, # where "reverse" is nullified - && !($lop->name eq 'sort' && ($lop->flags & OPpSORT_REVERSE))) + && !($lopname eq 'sort' && ($lop->flags & OPpSORT_REVERSE))) { # local() ($local = "", last) if $local =~ /^(?:my|our|state)$/; $local = "local"; } + if (defined $type && defined $newtype && $newtype ne $type) { + $local = ''; + last; + } + $type = $newtype; } $local = "" if $local eq "either"; # no point if it's all undefs + $local .= " $type " if $local && length $type; return $self->deparse($kid, $cx) if null $kid->sibling and not $local; for (; !null($kid); $kid = $kid->sibling) { if ($local) { @@ -3121,12 +3168,7 @@ sub loop_common { $ary = $self->deparse($ary, 1); } if (null $var) { - if (($enter->flags & OPf_SPECIAL) && ($] < 5.009)) { - # thread special var, under 5005threads - $var = $self->pp_threadsv($enter, 1); - } else { # regular my() variable - $var = $self->pp_padsv($enter, 1, 1); - } + $var = $self->pp_padsv($enter, 1, 1); } elsif ($var->name eq "rv2gv") { $var = $self->pp_rv2sv($var, 1); if ($enter->private & OPpOUR_INTRO) { @@ -3288,20 +3330,13 @@ sub padany { sub pp_padsv { my $self = shift; my($op, $cx, $forbid_parens) = @_; - return $self->maybe_my($op, $cx, $self->padname($op->targ), + return $self->maybe_my($op, $cx, $self->padname_sv($op->targ), $forbid_parens); } sub pp_padav { pp_padsv(@_) } sub pp_padhv { pp_padsv(@_) } -my @threadsv_names = B::threadsv_names; -sub pp_threadsv { - my $self = shift; - my($op, $cx) = @_; - return $self->maybe_local($op, $cx, "\$" . $threadsv_names[$op->targ]); -} - sub gv_or_padgv { my $self = shift; my $op = shift; @@ -3806,8 +3841,10 @@ sub pp_entersub { $kid = "{" . $self->deparse($kid, 0) . "}"; } elsif ($kid->first->name eq "gv") { my $gv = $self->gv_or_padgv($kid->first); - if (class($gv->CV) ne "SPECIAL") { - $proto = $gv->CV->PV if $gv->CV->FLAGS & SVf_POK; + my $cv; + if (class($gv) eq 'GV' && class($cv = $gv->CV) ne "SPECIAL" + || $gv->FLAGS & SVf_ROK && class($cv = $gv->RV) eq 'CV') { + $proto = $cv->PV if $cv->FLAGS & SVf_POK; } $simple = 1; # only calls of named functions can be prototyped $kid = $self->deparse($kid, 24); diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t index c804b70..620d430 100644 --- a/lib/B/Deparse.t +++ b/lib/B/Deparse.t @@ -344,6 +344,24 @@ print $main::x[1]; my %x; $x{warn()}; #### +# our (LIST) +our($foo, $bar, $baz); +#### +# CONTEXT { package Dog } use feature "state"; +# variables with declared classes +my Dog $spot; +our Dog $spotty; +state Dog $spotted; +my Dog @spot; +our Dog @spotty; +state Dog @spotted; +my Dog %spot; +our Dog %spotty; +state Dog %spotted; +my Dog ($foo, @bar, %baz); +our Dog ($phoo, @barr, %bazz); +state Dog ($fough, @barre, %bazze); +#### # <> my $foo; $_ .= . <$foo>; @@ -964,11 +982,6 @@ print /a/u, s/b/c/u; # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns) s/foo/\(3);/eg; #### -# Test @threadsv_names under 5005threads -foreach $' (1, 2) { - sleep $'; -} -#### # y///r tr/a/b/r; #### diff --git a/lib/B/Op_private.pm b/lib/B/Op_private.pm new file mode 100644 index 0000000..6c77420 --- /dev/null +++ b/lib/B/Op_private.pm @@ -0,0 +1,700 @@ +# -*- buffer-read-only: t -*- +# +# lib/B/Op_private.pm +# +# Copyright (C) 2014 by Larry Wall and others +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the README file. +# +# !!!!!!! DO NOT EDIT THIS FILE !!!!!!! +# This file is built by regen/opcode.pl from data in +# regen/op_private and pod embedded in regen/opcode.pl. +# Any changes made here will be lost! + +=head1 NAME + +B::Op_private - OP op_private flag definitions + +=head1 SYNOPSIS + + use B::Op_private; + + # flag details for bit 7 of OP_AELEM's op_private: + my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO + my $value = $B::Op_private::defines{$name}; # 128 + my $label = $B::Op_private::labels{$name}; # LVINTRO + + # the bit field at bits 5..6 of OP_AELEM's op_private: + my $bf = $B::Op_private::bits{aelem}{6}; + my $mask = $bf->{bitmask}; # etc + +=head1 DESCRIPTION + +This module provides three global hashes: + + %B::Op_private::bits + %B::Op_private::defines + %B::Op_private::labels + +which contain information about the per-op meanings of the bits in the +op_private field. + +=head2 C<%bits> + +This is indexed by op name and then bit number (0..7). For single bit flags, +it returns the name of the define (if any) for that bit: + + $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; + +For bit fields, it returns a hash ref containing details about the field. +The same reference will be returned for all bit positions that make +up the bit field; so for example these both return the same hash ref: + + $bitfield = $B::Op_private::bits{aelem}{5}; + $bitfield = $B::Op_private::bits{aelem}{6}; + +The general format of this hash ref is + + { + # The bit range and mask; these are always present. + bitmin => 5, + bitmax => 6, + bitmask => 0x60, + + # (The remaining keys are optional) + + # The names of any defines that were requested: + mask_def => 'OPpFOO_MASK', + baseshift_def => 'OPpFOO_SHIFT', + bitcount_def => 'OPpFOO_BITS', + + # If present, Concise etc will display the value with a 'FOO=' + # prefix. If it equals '-', then Concise will treat the bit + # field as raw bits and not try to interpret it. + label => 'FOO', + + # If present, specifies the names of some defines and the + # display labels that are used to assign meaning to particu- + # lar integer values within the bit field; e.g. 3 is dis- + # played as 'C'. + enum => [ qw( + 1 OPpFOO_A A + 2 OPpFOO_B B + 3 OPpFOO_C C + )], + + }; + + +=head2 C<%defines> + +This gives the value of every C define, e.g. + + $B::Op_private::defines{OPpLVAL_INTRO} == 128; + +=head2 C<%labels> + +This gives the short display label for each define, as used by C +and C, e.g. + + $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; + +If the label equals '-', then Concise will treat the bit as a raw bit and +not try to display it symbolically. + +=cut + +package B::Op_private; + +our %bits; + + +our $VERSION = "5.021004"; + +$bits{$_}{3} = 'OPpENTERSUB_AMPER' for qw(entersub rv2cv); +$bits{$_}{4} = 'OPpENTERSUB_DB' for qw(entersub rv2cv); +$bits{$_}{2} = 'OPpENTERSUB_HASTARG' for qw(entersub rv2cv); +$bits{$_}{6} = 'OPpFLIP_LINENUM' for qw(flip flop); +$bits{$_}{1} = 'OPpFT_ACCESS' for qw(fteexec fteread ftewrite ftrexec ftrread ftrwrite); +$bits{$_}{4} = 'OPpFT_AFTER_t' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{2} = 'OPpFT_STACKED' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{3} = 'OPpFT_STACKING' for qw(ftatime ftbinary ftblk ftchr ftctime ftdir fteexec fteowned fteread ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned ftrread ftrwrite ftsgid ftsize ftsock ftsuid ftsvtx fttext fttty ftzero); +$bits{$_}{1} = 'OPpGREP_LEX' for qw(grepstart grepwhile mapstart mapwhile); +$bits{$_}{6} = 'OPpHINT_M_VMSISH_STATUS' for qw(dbstate nextstate); +$bits{$_}{7} = 'OPpHINT_M_VMSISH_TIME' for qw(dbstate nextstate); +$bits{$_}{1} = 'OPpHINT_STRICT_REFS' for qw(entersub rv2av rv2cv rv2gv rv2hv rv2sv); +$bits{$_}{5} = 'OPpHUSH_VMSISH' for qw(dbstate nextstate); +$bits{$_}{2} = 'OPpITER_REVERSED' for qw(enteriter iter); +$bits{$_}{7} = 'OPpLVALUE' for qw(leave leaveloop); +$bits{$_}{4} = 'OPpLVAL_DEFER' for qw(aelem helem); +$bits{$_}{7} = 'OPpLVAL_INTRO' for qw(aelem aslice cond_expr delete enteriter entersub gvsv helem hslice list padav padhv padrange padsv pos pushmark rv2av rv2gv rv2hv rv2sv substr vec); +$bits{$_}{3} = 'OPpMAYBE_LVSUB' for qw(aassign aelem aslice av2arylen helem hslice keys kvaslice kvhslice padav padhv pos rkeys rv2av rv2gv rv2hv substr vec); +$bits{$_}{6} = 'OPpMAYBE_TRUEBOOL' for qw(padhv rv2hv); +$bits{$_}{7} = 'OPpOFFBYONE' for qw(caller runcv wantarray); +$bits{$_}{5} = 'OPpOPEN_IN_CRLF' for qw(backtick open); +$bits{$_}{4} = 'OPpOPEN_IN_RAW' for qw(backtick open); +$bits{$_}{7} = 'OPpOPEN_OUT_CRLF' for qw(backtick open); +$bits{$_}{6} = 'OPpOPEN_OUT_RAW' for qw(backtick open); +$bits{$_}{4} = 'OPpOUR_INTRO' for qw(enteriter gvsv rv2av rv2hv rv2sv); +$bits{$_}{4} = 'OPpPAD_STATE' for qw(padav padhv padsv pushmark); +$bits{$_}{7} = 'OPpPV_IS_UTF8' for qw(dump goto last next redo); +$bits{$_}{6} = 'OPpREFCOUNTED' for qw(leave leaveeval leavesub leavesublv leavewrite); +$bits{$_}{6} = 'OPpRUNTIME' for qw(match pushre qr subst substcont); +$bits{$_}{2} = 'OPpSLICEWARNING' for qw(aslice hslice padav padhv rv2av rv2hv); +$bits{$_}{4} = 'OPpTARGET_MY' for qw(abs add atan2 chdir chmod chomp chown chr chroot concat cos crypt divide exec exp flock getpgrp getppid getpriority hex i_add i_divide i_modulo i_multiply i_negate i_postdec i_postinc i_subtract index int kill left_shift length link log match mkdir modulo multiply oct ord pow push rand rename right_shift rindex rmdir schomp setpgrp setpriority sin sleep sqrt srand stringify subst subtract symlink system time trans transr unlink unshift utime wait waitpid); +$bits{$_}{5} = 'OPpTRANS_COMPLEMENT' for qw(trans transr); +$bits{$_}{7} = 'OPpTRANS_DELETE' for qw(trans transr); +$bits{$_}{0} = 'OPpTRANS_FROM_UTF' for qw(trans transr); +$bits{$_}{6} = 'OPpTRANS_GROWS' for qw(trans transr); +$bits{$_}{2} = 'OPpTRANS_IDENTICAL' for qw(trans transr); +$bits{$_}{3} = 'OPpTRANS_SQUASH' for qw(trans transr); +$bits{$_}{1} = 'OPpTRANS_TO_UTF' for qw(trans transr); +$bits{$_}{5} = 'OPpTRUEBOOL' for qw(padhv rv2hv); + +my @bf = ( + { + label => '-', + mask_def => 'OPpARG1_MASK', + bitmin => 0, + bitmax => 0, + bitmask => 1, + }, + { + label => '-', + mask_def => 'OPpARG2_MASK', + bitmin => 0, + bitmax => 1, + bitmask => 3, + }, + { + label => '-', + mask_def => 'OPpARG3_MASK', + bitmin => 0, + bitmax => 2, + bitmask => 7, + }, + { + label => '-', + mask_def => 'OPpARG4_MASK', + bitmin => 0, + bitmax => 3, + bitmask => 15, + }, + { + label => '-', + mask_def => 'OPpPADRANGE_COUNTMASK', + bitcount_def => 'OPpPADRANGE_COUNTSHIFT', + bitmin => 0, + bitmax => 6, + bitmask => 127, + }, + { + label => '-', + bitmin => 0, + bitmax => 7, + bitmask => 255, + }, + { + mask_def => 'OPpDEREF', + bitmin => 5, + bitmax => 6, + bitmask => 96, + enum => [ + 1, 'OPpDEREF_AV', 'DREFAV', + 2, 'OPpDEREF_HV', 'DREFHV', + 3, 'OPpDEREF_SV', 'DREFSV', + ], + }, +); + +@{$bits{aassign}}{6,1,0} = ('OPpASSIGN_COMMON', $bf[1], $bf[1]); +$bits{abs}{0} = $bf[0]; +@{$bits{accept}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{add}}{1,0} = ($bf[1], $bf[1]); +$bits{aeach}{0} = $bf[0]; +@{$bits{aelem}}{6,5,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]); +@{$bits{aelemfast}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]); +@{$bits{aelemfast_lex}}{7,6,5,4,3,2,1,0} = ($bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5], $bf[5]); +$bits{akeys}{0} = $bf[0]; +$bits{alarm}{0} = $bf[0]; +$bits{and}{0} = $bf[0]; +$bits{andassign}{0} = $bf[0]; +@{$bits{anonhash}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{anonlist}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{atan2}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{av2arylen}{0} = $bf[0]; +$bits{avalues}{0} = $bf[0]; +$bits{backtick}{0} = $bf[0]; +@{$bits{bind}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{binmode}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{bit_and}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bit_or}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bit_xor}}{1,0} = ($bf[1], $bf[1]); +@{$bits{bless}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{caller}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{chdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{chmod}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{chomp}{0} = $bf[0]; +$bits{chop}{0} = $bf[0]; +@{$bits{chown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{chr}{0} = $bf[0]; +$bits{chroot}{0} = $bf[0]; +@{$bits{close}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{closedir}{0} = $bf[0]; +$bits{complement}{0} = $bf[0]; +@{$bits{concat}}{1,0} = ($bf[1], $bf[1]); +$bits{cond_expr}{0} = $bf[0]; +@{$bits{connect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{const}}{6,4,3,2,1} = ('OPpCONST_BARE', 'OPpCONST_ENTERED', 'OPpCONST_STRICT', 'OPpCONST_SHORTCIRCUIT', 'OPpCONST_NOVER'); +@{$bits{coreargs}}{7,6,1,0} = ('OPpCOREARGS_PUSHMARK', 'OPpCOREARGS_SCALARMOD', 'OPpCOREARGS_DEREF2', 'OPpCOREARGS_DEREF1'); +$bits{cos}{0} = $bf[0]; +@{$bits{crypt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{dbmclose}{0} = $bf[0]; +@{$bits{dbmopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{defined}{0} = $bf[0]; +@{$bits{delete}}{6,0} = ('OPpSLICE', $bf[0]); +@{$bits{die}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{divide}}{1,0} = ($bf[1], $bf[1]); +$bits{dofile}{0} = $bf[0]; +$bits{dor}{0} = $bf[0]; +$bits{dorassign}{0} = $bf[0]; +$bits{dump}{0} = $bf[0]; +$bits{each}{0} = $bf[0]; +@{$bits{entereval}}{5,4,3,2,1,0} = ('OPpEVAL_RE_REPARSING', 'OPpEVAL_COPHH', 'OPpEVAL_BYTES', 'OPpEVAL_UNICODE', 'OPpEVAL_HAS_HH', $bf[0]); +$bits{entergiven}{0} = $bf[0]; +$bits{enteriter}{3} = 'OPpITER_DEF'; +@{$bits{entersub}}{6,5,0} = ($bf[6], $bf[6], 'OPpENTERSUB_INARGS'); +$bits{entertry}{0} = $bf[0]; +$bits{enterwhen}{0} = $bf[0]; +@{$bits{enterwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{eof}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{eq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{exec}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{exists}}{6,0} = ('OPpEXISTS_SUB', $bf[0]); +@{$bits{exit}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{exp}{0} = $bf[0]; +$bits{fc}{0} = $bf[0]; +@{$bits{fcntl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{fileno}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{flip}{0} = $bf[0]; +@{$bits{flock}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{flop}{0} = $bf[0]; +@{$bits{formline}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{ftatime}{0} = $bf[0]; +$bits{ftbinary}{0} = $bf[0]; +$bits{ftblk}{0} = $bf[0]; +$bits{ftchr}{0} = $bf[0]; +$bits{ftctime}{0} = $bf[0]; +$bits{ftdir}{0} = $bf[0]; +$bits{fteexec}{0} = $bf[0]; +$bits{fteowned}{0} = $bf[0]; +$bits{fteread}{0} = $bf[0]; +$bits{ftewrite}{0} = $bf[0]; +$bits{ftfile}{0} = $bf[0]; +$bits{ftis}{0} = $bf[0]; +$bits{ftlink}{0} = $bf[0]; +$bits{ftmtime}{0} = $bf[0]; +$bits{ftpipe}{0} = $bf[0]; +$bits{ftrexec}{0} = $bf[0]; +$bits{ftrowned}{0} = $bf[0]; +$bits{ftrread}{0} = $bf[0]; +$bits{ftrwrite}{0} = $bf[0]; +$bits{ftsgid}{0} = $bf[0]; +$bits{ftsize}{0} = $bf[0]; +$bits{ftsock}{0} = $bf[0]; +$bits{ftsuid}{0} = $bf[0]; +$bits{ftsvtx}{0} = $bf[0]; +$bits{fttext}{0} = $bf[0]; +$bits{fttty}{0} = $bf[0]; +$bits{ftzero}{0} = $bf[0]; +@{$bits{ge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{gelem}}{1,0} = ($bf[1], $bf[1]); +@{$bits{getc}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{getpeername}{0} = $bf[0]; +@{$bits{getpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{getpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{getsockname}{0} = $bf[0]; +$bits{ggrgid}{0} = $bf[0]; +$bits{ggrnam}{0} = $bf[0]; +@{$bits{ghbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{ghbyname}{0} = $bf[0]; +@{$bits{glob}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{gmtime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{gnbyaddr}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{gnbyname}{0} = $bf[0]; +$bits{goto}{0} = $bf[0]; +$bits{gpbyname}{0} = $bf[0]; +@{$bits{gpbynumber}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{gpwnam}{0} = $bf[0]; +$bits{gpwuid}{0} = $bf[0]; +$bits{grepwhile}{0} = $bf[0]; +@{$bits{gsbyname}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{gsbyport}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{gsockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{gt}}{1,0} = ($bf[1], $bf[1]); +$bits{gv}{5} = 'OPpEARLY_CV'; +@{$bits{helem}}{6,5,1,0} = ($bf[6], $bf[6], $bf[1], $bf[1]); +$bits{hex}{0} = $bf[0]; +@{$bits{i_add}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_divide}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_eq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_gt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_le}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_lt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_modulo}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_multiply}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ncmp}}{1,0} = ($bf[1], $bf[1]); +@{$bits{i_ne}}{1,0} = ($bf[1], $bf[1]); +$bits{i_negate}{0} = $bf[0]; +$bits{i_postdec}{0} = $bf[0]; +$bits{i_postinc}{0} = $bf[0]; +$bits{i_predec}{0} = $bf[0]; +$bits{i_preinc}{0} = $bf[0]; +@{$bits{i_subtract}}{1,0} = ($bf[1], $bf[1]); +@{$bits{index}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{int}{0} = $bf[0]; +@{$bits{ioctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{join}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{keys}{0} = $bf[0]; +@{$bits{kill}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{last}{0} = $bf[0]; +$bits{lc}{0} = $bf[0]; +$bits{lcfirst}{0} = $bf[0]; +@{$bits{le}}{1,0} = ($bf[1], $bf[1]); +$bits{leaveeval}{0} = $bf[0]; +$bits{leavegiven}{0} = $bf[0]; +@{$bits{leaveloop}}{1,0} = ($bf[1], $bf[1]); +$bits{leavesub}{0} = $bf[0]; +$bits{leavesublv}{0} = $bf[0]; +$bits{leavewhen}{0} = $bf[0]; +$bits{leavewrite}{0} = $bf[0]; +@{$bits{left_shift}}{1,0} = ($bf[1], $bf[1]); +$bits{length}{0} = $bf[0]; +@{$bits{link}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{list}{6} = 'OPpLIST_GUESSED'; +@{$bits{listen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{localtime}{0} = $bf[0]; +$bits{lock}{0} = $bf[0]; +$bits{log}{0} = $bf[0]; +@{$bits{lslice}}{1,0} = ($bf[1], $bf[1]); +$bits{lstat}{0} = $bf[0]; +@{$bits{lt}}{1,0} = ($bf[1], $bf[1]); +$bits{mapwhile}{0} = $bf[0]; +$bits{method}{0} = $bf[0]; +@{$bits{mkdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{modulo}}{1,0} = ($bf[1], $bf[1]); +@{$bits{msgctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{msgget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{msgrcv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{msgsnd}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{multiply}}{1,0} = ($bf[1], $bf[1]); +@{$bits{ncmp}}{1,0} = ($bf[1], $bf[1]); +@{$bits{ne}}{1,0} = ($bf[1], $bf[1]); +$bits{negate}{0} = $bf[0]; +$bits{next}{0} = $bf[0]; +$bits{not}{0} = $bf[0]; +$bits{oct}{0} = $bf[0]; +$bits{once}{0} = $bf[0]; +@{$bits{open}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{open_dir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{or}{0} = $bf[0]; +$bits{orassign}{0} = $bf[0]; +$bits{ord}{0} = $bf[0]; +@{$bits{pack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{padrange}}{6,5,4,3,2,1,0} = ($bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4], $bf[4]); +@{$bits{padsv}}{6,5} = ($bf[6], $bf[6]); +@{$bits{pipe_op}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{pop}{0} = $bf[0]; +$bits{pos}{0} = $bf[0]; +$bits{postdec}{0} = $bf[0]; +$bits{postinc}{0} = $bf[0]; +@{$bits{pow}}{1,0} = ($bf[1], $bf[1]); +$bits{predec}{0} = $bf[0]; +$bits{preinc}{0} = $bf[0]; +$bits{prototype}{0} = $bf[0]; +@{$bits{push}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{quotemeta}{0} = $bf[0]; +@{$bits{rand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{range}{0} = $bf[0]; +$bits{reach}{0} = $bf[0]; +@{$bits{read}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{readdir}{0} = $bf[0]; +$bits{readline}{0} = $bf[0]; +$bits{readlink}{0} = $bf[0]; +@{$bits{recv}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{redo}{0} = $bf[0]; +$bits{ref}{0} = $bf[0]; +$bits{refgen}{0} = $bf[0]; +$bits{regcmaybe}{0} = $bf[0]; +$bits{regcomp}{0} = $bf[0]; +$bits{regcreset}{0} = $bf[0]; +@{$bits{rename}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{repeat}}{6,1,0} = ('OPpREPEAT_DOLIST', $bf[1], $bf[1]); +$bits{require}{0} = $bf[0]; +@{$bits{reset}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{reverse}}{3,0} = ('OPpREVERSE_INPLACE', $bf[0]); +$bits{rewinddir}{0} = $bf[0]; +@{$bits{right_shift}}{1,0} = ($bf[1], $bf[1]); +@{$bits{rindex}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{rkeys}{0} = $bf[0]; +$bits{rmdir}{0} = $bf[0]; +$bits{rv2av}{0} = $bf[0]; +@{$bits{rv2cv}}{7,6,0} = ('OPpENTERSUB_NOPAREN', 'OPpMAY_RETURN_CONSTANT', $bf[0]); +@{$bits{rv2gv}}{6,5,4,2,0} = ($bf[6], $bf[6], 'OPpALLOW_FAKE', 'OPpDONT_INIT_GV', $bf[0]); +$bits{rv2hv}{0} = $bf[0]; +@{$bits{rv2sv}}{6,5,0} = ($bf[6], $bf[6], $bf[0]); +$bits{rvalues}{0} = $bf[0]; +@{$bits{sassign}}{7,6,1,0} = ('OPpASSIGN_CV_TO_GV', 'OPpASSIGN_BACKWARDS', $bf[1], $bf[1]); +$bits{scalar}{0} = $bf[0]; +$bits{schomp}{0} = $bf[0]; +$bits{schop}{0} = $bf[0]; +@{$bits{scmp}}{1,0} = ($bf[1], $bf[1]); +@{$bits{seek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{seekdir}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{select}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{semctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{semget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{semop}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{send}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{seq}}{1,0} = ($bf[1], $bf[1]); +@{$bits{setpgrp}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{setpriority}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sge}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sgt}}{1,0} = ($bf[1], $bf[1]); +$bits{shift}{0} = $bf[0]; +@{$bits{shmctl}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{shmget}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{shmread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{shmwrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{shostent}{0} = $bf[0]; +@{$bits{shutdown}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{sin}{0} = $bf[0]; +@{$bits{sle}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sleep}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{slt}}{1,0} = ($bf[1], $bf[1]); +@{$bits{smartmatch}}{1,0} = ($bf[1], $bf[1]); +@{$bits{sne}}{1,0} = ($bf[1], $bf[1]); +$bits{snetent}{0} = $bf[0]; +@{$bits{socket}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sockpair}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sort}}{6,5,4,3,2,1,0} = ('OPpSORT_STABLE', 'OPpSORT_QSORT', 'OPpSORT_DESCEND', 'OPpSORT_INPLACE', 'OPpSORT_REVERSE', 'OPpSORT_INTEGER', 'OPpSORT_NUMERIC'); +@{$bits{splice}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{split}{7} = 'OPpSPLIT_IMPLIM'; +@{$bits{sprintf}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{sprotoent}{0} = $bf[0]; +$bits{sqrt}{0} = $bf[0]; +@{$bits{srand}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{srefgen}{0} = $bf[0]; +@{$bits{sselect}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{sservent}{0} = $bf[0]; +@{$bits{ssockopt}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{stat}{0} = $bf[0]; +@{$bits{stringify}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{study}{0} = $bf[0]; +$bits{substcont}{0} = $bf[0]; +@{$bits{substr}}{4,2,1,0} = ('OPpSUBSTR_REPL_FIRST', $bf[2], $bf[2], $bf[2]); +@{$bits{subtract}}{1,0} = ($bf[1], $bf[1]); +@{$bits{symlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{syscall}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sysopen}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sysread}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{sysseek}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{system}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{syswrite}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{tell}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{telldir}{0} = $bf[0]; +@{$bits{tie}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{tied}{0} = $bf[0]; +@{$bits{truncate}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{uc}{0} = $bf[0]; +$bits{ucfirst}{0} = $bf[0]; +@{$bits{umask}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{undef}{0} = $bf[0]; +@{$bits{unlink}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{unpack}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{unshift}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{untie}{0} = $bf[0]; +@{$bits{utime}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +$bits{values}{0} = $bf[0]; +@{$bits{vec}}{1,0} = ($bf[1], $bf[1]); +@{$bits{waitpid}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{warn}}{3,2,1,0} = ($bf[3], $bf[3], $bf[3], $bf[3]); +@{$bits{xor}}{1,0} = ($bf[1], $bf[1]); + + +our %defines = ( + OPpALLOW_FAKE => 16, + OPpARG1_MASK => 1, + OPpARG2_MASK => 3, + OPpARG3_MASK => 7, + OPpARG4_MASK => 15, + OPpASSIGN_BACKWARDS => 64, + OPpASSIGN_COMMON => 64, + OPpASSIGN_CV_TO_GV => 128, + OPpCONST_BARE => 64, + OPpCONST_ENTERED => 16, + OPpCONST_NOVER => 2, + OPpCONST_SHORTCIRCUIT => 4, + OPpCONST_STRICT => 8, + OPpCOREARGS_DEREF1 => 1, + OPpCOREARGS_DEREF2 => 2, + OPpCOREARGS_PUSHMARK => 128, + OPpCOREARGS_SCALARMOD => 64, + OPpDEREF => 96, + OPpDEREF_AV => 32, + OPpDEREF_HV => 64, + OPpDEREF_SV => 96, + OPpDONT_INIT_GV => 4, + OPpEARLY_CV => 32, + OPpENTERSUB_AMPER => 8, + OPpENTERSUB_DB => 16, + OPpENTERSUB_HASTARG => 4, + OPpENTERSUB_INARGS => 1, + OPpENTERSUB_NOPAREN => 128, + OPpEVAL_BYTES => 8, + OPpEVAL_COPHH => 16, + OPpEVAL_HAS_HH => 2, + OPpEVAL_RE_REPARSING => 32, + OPpEVAL_UNICODE => 4, + OPpEXISTS_SUB => 64, + OPpFLIP_LINENUM => 64, + OPpFT_ACCESS => 2, + OPpFT_AFTER_t => 16, + OPpFT_STACKED => 4, + OPpFT_STACKING => 8, + OPpGREP_LEX => 2, + OPpHINT_M_VMSISH_STATUS => 64, + OPpHINT_M_VMSISH_TIME => 128, + OPpHINT_STRICT_REFS => 2, + OPpHUSH_VMSISH => 32, + OPpITER_DEF => 8, + OPpITER_REVERSED => 4, + OPpLIST_GUESSED => 64, + OPpLVALUE => 128, + OPpLVAL_DEFER => 16, + OPpLVAL_INTRO => 128, + OPpMAYBE_LVSUB => 8, + OPpMAYBE_TRUEBOOL => 64, + OPpMAY_RETURN_CONSTANT => 64, + OPpOFFBYONE => 128, + OPpOPEN_IN_CRLF => 32, + OPpOPEN_IN_RAW => 16, + OPpOPEN_OUT_CRLF => 128, + OPpOPEN_OUT_RAW => 64, + OPpOUR_INTRO => 16, + OPpPADRANGE_COUNTMASK => 127, + OPpPADRANGE_COUNTSHIFT => 7, + OPpPAD_STATE => 16, + OPpPV_IS_UTF8 => 128, + OPpREFCOUNTED => 64, + OPpREPEAT_DOLIST => 64, + OPpREVERSE_INPLACE => 8, + OPpRUNTIME => 64, + OPpSLICE => 64, + OPpSLICEWARNING => 4, + OPpSORT_DESCEND => 16, + OPpSORT_INPLACE => 8, + OPpSORT_INTEGER => 2, + OPpSORT_NUMERIC => 1, + OPpSORT_QSORT => 32, + OPpSORT_REVERSE => 4, + OPpSORT_STABLE => 64, + OPpSPLIT_IMPLIM => 128, + OPpSUBSTR_REPL_FIRST => 16, + OPpTARGET_MY => 16, + OPpTRANS_COMPLEMENT => 32, + OPpTRANS_DELETE => 128, + OPpTRANS_FROM_UTF => 1, + OPpTRANS_GROWS => 64, + OPpTRANS_IDENTICAL => 4, + OPpTRANS_SQUASH => 8, + OPpTRANS_TO_UTF => 2, + OPpTRUEBOOL => 32, +); + +our %labels = ( + OPpALLOW_FAKE => 'FAKE', + OPpASSIGN_BACKWARDS => 'BKWARD', + OPpASSIGN_COMMON => 'COMMON', + OPpASSIGN_CV_TO_GV => 'CV2GV', + OPpCONST_BARE => 'BARE', + OPpCONST_ENTERED => 'ENTERED', + OPpCONST_NOVER => 'NOVER', + OPpCONST_SHORTCIRCUIT => 'SHORT', + OPpCONST_STRICT => 'STRICT', + OPpCOREARGS_DEREF1 => 'DEREF1', + OPpCOREARGS_DEREF2 => 'DEREF2', + OPpCOREARGS_PUSHMARK => 'MARK', + OPpCOREARGS_SCALARMOD => '$MOD', + OPpDEREF_AV => 'DREFAV', + OPpDEREF_HV => 'DREFHV', + OPpDEREF_SV => 'DREFSV', + OPpDONT_INIT_GV => 'NOINIT', + OPpEARLY_CV => 'EARLYCV', + OPpENTERSUB_AMPER => 'AMPER', + OPpENTERSUB_DB => 'DBG', + OPpENTERSUB_HASTARG => 'TARG', + OPpENTERSUB_INARGS => 'INARGS', + OPpENTERSUB_NOPAREN => 'NO()', + OPpEVAL_BYTES => 'BYTES', + OPpEVAL_COPHH => 'COPHH', + OPpEVAL_HAS_HH => 'HAS_HH', + OPpEVAL_RE_REPARSING => 'REPARSE', + OPpEVAL_UNICODE => 'UNI', + OPpEXISTS_SUB => 'SUB', + OPpFLIP_LINENUM => 'LINENUM', + OPpFT_ACCESS => 'FTACCESS', + OPpFT_AFTER_t => 'FTAFTERt', + OPpFT_STACKED => 'FTSTACKED', + OPpFT_STACKING => 'FTSTACKING', + OPpGREP_LEX => 'GREPLEX', + OPpHINT_M_VMSISH_STATUS => 'VMSISH_STATUS', + OPpHINT_M_VMSISH_TIME => 'VMSISH_TIME', + OPpHINT_STRICT_REFS => 'STRICT', + OPpHUSH_VMSISH => 'HUSH', + OPpITER_DEF => 'DEF', + OPpITER_REVERSED => 'REVERSED', + OPpLIST_GUESSED => 'GUESSED', + OPpLVALUE => 'LV', + OPpLVAL_DEFER => 'LVDEFER', + OPpLVAL_INTRO => 'LVINTRO', + OPpMAYBE_LVSUB => 'LVSUB', + OPpMAYBE_TRUEBOOL => 'BOOL?', + OPpMAY_RETURN_CONSTANT => 'CONST', + OPpOFFBYONE => '+1', + OPpOPEN_IN_CRLF => 'INCR', + OPpOPEN_IN_RAW => 'INBIN', + OPpOPEN_OUT_CRLF => 'OUTCR', + OPpOPEN_OUT_RAW => 'OUTBIN', + OPpOUR_INTRO => 'OURINTR', + OPpPAD_STATE => 'STATE', + OPpPV_IS_UTF8 => 'UTF', + OPpREFCOUNTED => 'REFC', + OPpREPEAT_DOLIST => 'DOLIST', + OPpREVERSE_INPLACE => 'INPLACE', + OPpRUNTIME => 'RTIME', + OPpSLICE => 'SLICE', + OPpSLICEWARNING => 'SLICEWARN', + OPpSORT_DESCEND => 'DESC', + OPpSORT_INPLACE => 'INPLACE', + OPpSORT_INTEGER => 'INT', + OPpSORT_NUMERIC => 'NUM', + OPpSORT_QSORT => 'QSORT', + OPpSORT_REVERSE => 'REV', + OPpSORT_STABLE => 'STABLE', + OPpSPLIT_IMPLIM => 'IMPLIM', + OPpSUBSTR_REPL_FIRST => 'REPL1ST', + OPpTARGET_MY => 'TARGMY', + OPpTRANS_COMPLEMENT => 'COMPL', + OPpTRANS_DELETE => 'DEL', + OPpTRANS_FROM_UTF => ' 'GROWS', + OPpTRANS_IDENTICAL => 'IDENT', + OPpTRANS_SQUASH => 'SQUASH', + OPpTRANS_TO_UTF => '>UTF', + OPpTRUEBOOL => 'BOOL', +); + +# ex: set ro: diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm index ecb7ebb..b7f8132 100644 --- a/lib/Getopt/Std.pm +++ b/lib/Getopt/Std.pm @@ -36,8 +36,8 @@ The C function returns true unless an invalid option was found. The C function is similar, but its argument is a string containing all switches that take an argument. If no argument is provided for a switch, say, C, the corresponding C<$opt_y> will be set to an undefined value. -Unspecified switches are silently accepted. B is not -recommended.> +Unspecified switches are silently accepted. Use of C is not +recommended. Note that, if your code is running under the recommended C pragma, you will need to declare these package variables @@ -81,7 +81,7 @@ and version_mess() with the switches string as an argument. @ISA = qw(Exporter); @EXPORT = qw(getopt getopts); -$VERSION = '1.10'; +$VERSION = '1.11'; # uncomment the next line to disable 1.03-backward compatibility paranoia # $STANDARD_HELP_VERSION = 1; diff --git a/lib/_charnames.pm b/lib/_charnames.pm index 92286c2..729d849 100644 --- a/lib/_charnames.pm +++ b/lib/_charnames.pm @@ -6,8 +6,7 @@ package _charnames; use strict; use warnings; -use File::Spec; -our $VERSION = '1.41'; +our $VERSION = '1.42'; use unicore::Name; # mktables-generated algorithmically-defined names use bytes (); # for $bytes::hint_bits @@ -237,6 +236,7 @@ sub not_legal_use_bytes_msg { sub alias_file ($) # Reads a file containing alias definitions { + require File::Spec; my ($arg, $file) = @_; if (-f $arg && File::Spec->file_name_is_absolute ($arg)) { $file = $arg; diff --git a/lib/diagnostics.t b/lib/diagnostics.t index 4ac2ebf..0b35d16 100644 --- a/lib/diagnostics.t +++ b/lib/diagnostics.t @@ -106,7 +106,7 @@ seek STDERR, 0,0; $warning = ''; warn "Using just the first character returned by \\N{} in character class in regex; marked by <-- HERE in m/%s/"; like $warning, - qr/A charnames handler may return a sequence/s, + qr/Named Unicode character escapes/s, 'multi-line entries in perldiag.pod match'; # ; at end of entry in perldiag.pod diff --git a/lib/locale.t b/lib/locale.t index 31b40f9..f59e17b 100644 --- a/lib/locale.t +++ b/lib/locale.t @@ -1910,13 +1910,23 @@ foreach my $Locale (@Locale) { my $first_c_test = $locales_test_number; - report_result($Locale, ++$locales_test_number, $ok3); - $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant'; - $problematical_tests{$locales_test_number} = 1; + $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a constant'; + if ($Config{usequadmath}) { + print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n"; + report_result($Locale, $locales_test_number, 1); + } else { + report_result($Locale, $locales_test_number, $ok3); + $problematical_tests{$locales_test_number} = 1; + } - report_result($Locale, ++$locales_test_number, $ok4); - $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar'; - $problematical_tests{$locales_test_number} = 1; + $test_names{++$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar'; + if ($Config{usequadmath}) { + print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n"; + report_result($Locale, $locales_test_number, 1); + } else { + report_result($Locale, $locales_test_number, $ok4); + $problematical_tests{$locales_test_number} = 1; + } report_result($Locale, ++$locales_test_number, $ok5); $test_names{$locales_test_number} = 'Verify that a different locale radix works when doing "==" with a scalar and an intervening sprintf'; @@ -1931,9 +1941,14 @@ foreach my $Locale (@Locale) { report_result($Locale, ++$locales_test_number, $ok7); $test_names{$locales_test_number} = 'Verify that "==" with a scalar still works in inner no locale'; - report_result($Locale, ++$locales_test_number, $ok8); - $test_names{$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale'; - $problematical_tests{$locales_test_number} = 1; + $test_names{++$locales_test_number} = 'Verify that "==" with a scalar and an intervening sprintf still works in inner no locale'; + if ($Config{usequadmath}) { + print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n"; + report_result($Locale, $locales_test_number, 1); + } else { + report_result($Locale, $locales_test_number, $ok8); + $problematical_tests{$locales_test_number} = 1; + } debug "$first_e_test..$locales_test_number: \$e = $e, no locale\n"; @@ -1946,9 +1961,14 @@ foreach my $Locale (@Locale) { $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar'; $problematical_tests{$locales_test_number} = 1; - report_result($Locale, ++$locales_test_number, $ok11); - $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf'; - $problematical_tests{$locales_test_number} = 1; + $test_names{++$locales_test_number} = 'Verify that after a no-locale block, a different locale radix still works when doing "==" with a scalar and an intervening sprintf'; + if ($Config{usequadmath}) { + print "# Skip: no locale radix with usequadmath ($test_names{$locales_test_number})\n"; + report_result($Locale, $locales_test_number, 1); + } else { + report_result($Locale, $locales_test_number, $ok11); + $problematical_tests{$locales_test_number} = 1; + } report_result($Locale, ++$locales_test_number, $ok12); $test_names{$locales_test_number} = 'Verify that after a no-locale block, a different locale radix can participate in an addition and function call as numeric'; @@ -2186,9 +2206,14 @@ foreach my $Locale (@Locale) { } } - report_result($Locale, $locales_test_number, @f == 0); - if (@f) { - print "# failed $locales_test_number locale '$Locale' numbers @f\n" + if ($Config{usequadmath}) { + print "# Skip: no locale radix with usequadmath ($Locale)\n"; + report_result($Locale, $locales_test_number, 1); + } else { + report_result($Locale, $locales_test_number, @f == 0); + if (@f) { + print "# failed $locales_test_number locale '$Locale' numbers @f\n" + } } } } diff --git a/lib/overload.pm b/lib/overload.pm index 51801d6..fc9ff4e 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,6 +1,6 @@ package overload; -our $VERSION = '1.22'; +our $VERSION = '1.23'; %ops = ( with_assign => "+ - * / % ** << >> x .", @@ -81,7 +81,7 @@ sub ov_method { return undef unless $globref; my $sub = \&{*$globref}; no overloading; - return $sub if !ref $sub or $sub != \&nil; + return $sub if $sub != \&nil; return shift->can($ {*$globref}); } diff --git a/lib/overload.t b/lib/overload.t index d89ec2a..2371c71 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 5194; +plan tests => 5198; use Scalar::Util qw(tainted); @@ -2730,6 +2730,23 @@ EOF pass("RT 121362"); } +package refsgalore { + use overload + '${}' => sub { \42 }, + '@{}' => sub { [43] }, + '%{}' => sub { { 44 => 45 } }, + '&{}' => sub { sub { 46 } }; +} +{ + use feature 'postderef'; + no warnings 'experimental::postderef'; + tell myio; # vivifies *myio{IO} at compile time + use constant ioref => bless *myio{IO}, refsgalore::; + is ioref->$*, 42, '(overloaded constant that is not a scalar ref)->$*'; + is ioref->[0], 43, '(ovrld constant that is not an array ref)->[0]'; + is ioref->{44}, 45, "(ovrld const that is not a hash ref)->{key}"; + is ioref->(), 46, '(overloaded constant that is not a sub ref)->()'; +} { # undefining the overload stash -- KEEP THIS TEST LAST package ant; diff --git a/lib/utf8_heavy.pl b/lib/utf8_heavy.pl index 3cd8e83..43f3399 100644 --- a/lib/utf8_heavy.pl +++ b/lib/utf8_heavy.pl @@ -175,7 +175,11 @@ sub _loose_name ($) { } if (miniperl) { eval "require '$unicore_dir/Heavy.pl'"; - last GETFILE if $@; + if ($@) { + print STDERR __LINE__, ": '$@'\n" if DEBUG; + pop @recursed if @recursed; + return $type; + } } else { require "$unicore_dir/Heavy.pl"; diff --git a/locale.c b/locale.c index 8f77885..2e68b23 100644 --- a/locale.c +++ b/locale.c @@ -1440,8 +1440,8 @@ Perl__is_cur_LC_category_utf8(pTHX_ int category) while ((name += strcspn(name, "Uu") + 1) <= save_input_locale + final_pos - 2) { - if (toFOLD(*(name)) != 't' - || toFOLD(*(name + 1)) != 'f') + if (!isALPHA_FOLD_NE(*name, 't') + || isALPHA_FOLD_NE(*(name + 1), 'f')) { continue; } diff --git a/make_ext.pl b/make_ext.pl index a67e894..f19bf18 100644 --- a/make_ext.pl +++ b/make_ext.pl @@ -377,7 +377,7 @@ sub build_extension { } unless ($fromname) { - die "For $mname tried @locations in in $ext_dir but can't find source"; + die "For $mname tried @locations in $ext_dir but can't find source"; } ($value = $fromname) =~ s/\.pm\z/.pod/; $value = $fromname unless -e $value; @@ -445,8 +445,8 @@ EOM # the Makefile.PL. Altering the atime and mtime backwards by 4 # seconds seems to resolve the issue. eval { - my $ftime = time - 4; - utime $ftime, $ftime, 'Makefile.PL'; + my $ftime = (stat('Makefile.PL'))[9] - 4; + utime $ftime, $ftime, 'Makefile.PL'; }; } elsif ($mname =~ /\A(?:Carp |ExtUtils::CBuilder diff --git a/makedef.pl b/makedef.pl index 83f0c91..2cfd3c4 100644 --- a/makedef.pl +++ b/makedef.pl @@ -662,6 +662,11 @@ if ($define{'USE_PERLIO'}) { # Remaining remnants that _may_ be functions are handled below. } +unless ($define{'USE_QUADMATH'}) { + ++$skip{Perl_quadmath_format_needed}; + ++$skip{Perl_quadmath_format_single}; +} + ############################################################################### # At this point all skip lists should be completed, as we are about to test diff --git a/mathoms.c b/mathoms.c index f9b9462..fa60621 100644 --- a/mathoms.c +++ b/mathoms.c @@ -1767,6 +1767,13 @@ Perl_utf8_to_uvuni(pTHX_ const U8 *s, STRLEN *retlen) return NATIVE_TO_UNI(valid_utf8_to_uvchr(s, retlen)); } +void +Perl_save_re_context(pTHX) +{ + PERL_UNUSED_CONTEXT; +} + + END_EXTERN_C #endif /* NO_MATHOMS */ diff --git a/metaconfig.h b/metaconfig.h index 72f73e3..8c32690 100644 --- a/metaconfig.h +++ b/metaconfig.h @@ -11,31 +11,26 @@ * in Configure, this is the way to force them into availability. * * BOOTSTRAP_CHARSET - * CHARBITS + * HAS_ACOSH * HAS_ASCTIME64 - * HAS_BACKTRACE * HAS_CTIME64 * HAS_DIFFTIME64 * HAS_DLADDR + * HAS_FEGETROUND + * HAS_FPCLASSIFY * HAS_GMTIME64 - * HAS_ISBLANK + * HAS_ISFINITEL + * HAS_ISINFL + * HAS_J0 * HAS_LOCALTIME64 - * HAS_IP_MREQ - * HAS_IP_MREQ_SOURCE - * HAS_IPV6_MREQ - * HAS_IPV6_MREQ_SOURCE * HAS_MKTIME64 * HAS_PRCTL * HAS_PSEUDOFORK * HAS_TIMEGM - * HAS_SOCKADDR_IN6 * I16SIZE * I64SIZE * I8SIZE * LOCALTIME_R_NEEDS_TZSET * U8SIZE * USE_CBACKTRACE - * USE_KERN_PROC_PATHNAME - * USE_NSGETEXECUTABLEPATH - * */ diff --git a/mg.c b/mg.c index e1fc578..e18ec01 100644 --- a/mg.c +++ b/mg.c @@ -1759,7 +1759,6 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, if (flags & G_WRITING_TO_STDERR) { SAVETMPS; - save_re_context(); SAVESPTR(PL_stderrgv); PL_stderrgv = NULL; } @@ -2237,7 +2236,7 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); #endif - TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1)); + TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME); return 0; } @@ -3125,11 +3124,19 @@ Perl_sighandler(int sig) } if (!cv || !CvROOT(cv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", - PL_sig_name[sig], (gv ? GvENAME(gv) - : ((cv && CvGV(cv)) - ? GvENAME(CvGV(cv)) - : "__ANON__"))); + const HEK * const hek = gv + ? GvENAME_HEK(gv) + : cv && CvNAMED(cv) + ? CvNAME_HEK(cv) + : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; + if (hek) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"%"HEKf"\" not defined.\n", + PL_sig_name[sig], hek); + /* diag_listed_as: SIG%s handler "%s" not defined */ + else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "SIG%s handler \"__ANON__\" not defined.\n", + PL_sig_name[sig]); goto cleanup; } diff --git a/mg.h b/mg.h index 81ed296..0f2fa29 100644 --- a/mg.h +++ b/mg.h @@ -33,6 +33,7 @@ struct magic { #define MGf_TAINTEDDIR 1 /* PERL_MAGIC_envelem only */ #define MGf_MINMATCH 1 /* PERL_MAGIC_regex_global only */ +#define MGf_REQUIRE_GV 1 /* PERL_MAGIC_checkcall only */ #define MGf_REFCOUNTED 2 #define MGf_GSKIP 4 /* skip further GETs until after next SET */ #define MGf_COPY 8 /* has an svt_copy MGVTBL entry */ diff --git a/mro.c b/mro.c index c9b40e5..5f7b939 100644 --- a/mro.c +++ b/mro.c @@ -307,19 +307,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) HEK *const key = HeKEY_hek(he); HeVAL(he) = &PL_sv_undef; - /* Save copying by making a shared hash key scalar. We - inline this here rather than calling - Perl_newSVpvn_share because we already have the - scalar, and we already have the hash key. */ - assert(SvTYPE(val) == SVt_NULL); - sv_upgrade(val, SVt_PV); - SvPV_set(val, HEK_KEY(share_hek_hek(key))); - SvCUR_set(val, HEK_LEN(key)); - SvIsCOW_on(val); - SvPOK_on(val); - if (HEK_UTF8(key)) - SvUTF8_on(val); - + sv_sethek(val, key); av_push(retval, val); } } diff --git a/numeric.c b/numeric.c index a203bf5..5691120 100644 --- a/numeric.c +++ b/numeric.c @@ -153,11 +153,11 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { - if (s[0] == 'b' || s[0] == 'B') { + if (isALPHA_FOLD_EQ(s[0], 'b')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && (s[1] == 'b' || s[1] == 'B')) { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'b'))) { s+=2; len-=2; } @@ -252,7 +252,7 @@ number may use '_' characters to separate digits. =cut Not documented yet because experimental is C= 1) { - if (s[0] == 'x' || s[0] == 'X') { + if (isALPHA_FOLD_EQ(s[0], 'x')) { s++; len--; } - else if (len >= 2 && s[0] == '0' && (s[1] == 'x' || s[1] == 'X')) { + else if (len >= 2 && s[0] == '0' && (isALPHA_FOLD_EQ(s[1], 'x'))) { s+=2; len-=2; } @@ -586,6 +586,108 @@ Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) return grok_number_flags(pv, len, valuep, 0); } +/* +=for apidoc grok_infnan + +Helper for grok_number(), accepts various ways of spelling "infinity" +or "not a number", and returns one of the following flag combinations: + + IS_NUMBER_INFINITE + IS_NUMBER_NAN + IS_NUMBER_INFINITE | IS_NUMBER_NEG + IS_NUMBER_NAN | IS_NUMBER_NEG + 0 + +If an infinity or not-a-number is recognized, the *sp will point to +one past the end of the recognized string. If the recognition fails, +zero is returned, and the *sp will not move. + +=cut +*/ + +int +Perl_grok_infnan(const char** sp, const char* send) +{ + const char* s = *sp; + int flags = 0; + + PERL_ARGS_ASSERT_GROK_INFNAN; + + if (*s == '+') { + s++; if (s == send) return 0; + } + else if (*s == '-') { + flags |= IS_NUMBER_NEG; /* Yes, -NaN happens. Incorrect but happens. */ + s++; if (s == send) return 0; + } + + if (*s == '1') { + /* Visual C: 1.#SNAN, -1.#QNAN, 1#INF, 1#.IND (maybe also 1.#NAN) */ + s++; if (s == send) return 0; + if (*s == '.') { + s++; if (s == send) return 0; + } + if (*s == '#') { + s++; if (s == send) return 0; + } else + return 0; + } + + if (isALPHA_FOLD_EQ(*s, 'I')) { + /* INF or IND (1.#IND is indeterminate, a certain type of NAN) */ + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; if (s == send) return 0; + if (isALPHA_FOLD_EQ(*s, 'F')) { + s++; + if (s < send && (isALPHA_FOLD_EQ(*s, 'I'))) { + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'I')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'T')) return 0; + s++; if (s == send || + /* allow either Infinity or Infinite */ + !(isALPHA_FOLD_EQ(*s, 'Y') || + isALPHA_FOLD_EQ(*s, 'E'))) return 0; + s++; if (s < send) return 0; + } else if (*s) + return 0; + flags |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } + else if (isALPHA_FOLD_EQ(*s, 'D')) { + s++; + flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else + return 0; + } + else { + /* NAN */ + if (isALPHA_FOLD_EQ(*s, 'S') || isALPHA_FOLD_EQ(*s, 'Q')) { + /* snan, qNaN */ + /* XXX do something with the snan/qnan difference */ + s++; if (s == send) return 0; + } + + if (isALPHA_FOLD_EQ(*s, 'N')) { + s++; if (s == send || isALPHA_FOLD_NE(*s, 'A')) return 0; + s++; if (s == send || isALPHA_FOLD_NE(*s, 'N')) return 0; + s++; + + flags |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + + /* NaN can be followed by various stuff (NaNQ, NaNS), but + * there are also multiple different NaN values, and some + * implementations output the "payload" values, + * e.g. NaN123, NAN(abc), while some implementations just + * have weird stuff like NaN%. */ + s = send; + } + else + return 0; + } + + *sp = s; + return flags; +} + static const UV uv_max_div_10 = UV_MAX / 10; static const U8 uv_max_mod_10 = UV_MAX % 10; @@ -594,9 +696,8 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) { const char *s = pv; const char * const send = pv + len; + const char *d; int numtype = 0; - int sawinf = 0; - int sawnan = 0; PERL_ARGS_ASSERT_GROK_NUMBER_FLAGS; @@ -614,7 +715,11 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) if (s == send) return 0; - /* next must be digit or the radix separator or beginning of infinity */ + /* The first digit (after optional sign): note that might + * also point to "infinity" or "nan", or "1.#INF". */ + d = s; + + /* next must be digit or the radix separator or beginning of infinity/nan */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ @@ -723,36 +828,12 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) } } else - return 0; - } else if (*s == 'I' || *s == 'i') { - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; - s++; if (s < send && (*s == 'I' || *s == 'i')) { - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; - s++; if (s == send || (*s != 'T' && *s != 't')) return 0; - s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; - s++; - } - sawinf = 1; - } else if (*s == 'N' || *s == 'n') { - /* XXX TODO: There are signaling NaNs and quiet NaNs. */ - s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; - s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; - s++; - sawnan = 1; - } else - return 0; + return 0; + } - if (sawinf) { - numtype &= IS_NUMBER_NEG; /* Keep track of sign */ - numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; - } else if (sawnan) { - numtype &= IS_NUMBER_NEG; /* Keep track of sign */ - numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; - } else if (s < send) { + if (s < send) { /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { + if (isALPHA_FOLD_EQ(*s, 'e')) { s++; if (s < send && (*s == '-' || *s == '+')) s++; @@ -780,6 +861,18 @@ Perl_grok_number_flags(pTHX_ const char *pv, STRLEN len, UV *valuep, U32 flags) *valuep = 0; return IS_NUMBER_IN_UV; } + /* We could be e.g. at "Inf" or "NaN", or at the "#" of "1.#INF". */ + if ((s + 2 < send) && strchr("inqs#", toFOLD(*s))) { + /* Really detect inf/nan. Start at d, not s, since the above + * code might have already consumed the "1." or "1". */ + int infnan = Perl_grok_infnan(&d, send); + if ((infnan & IS_NUMBER_INFINITY)) { + return (numtype | infnan); /* Keep sign for infinity. */ + } + else if ((infnan & IS_NUMBER_NAN)) { + return (numtype | infnan) & ~IS_NUMBER_NEG; /* Clear sign for nan. */ + } + } else if (flags & PERL_SCAN_TRAILING) { return numtype | IS_NUMBER_TRAILING; } @@ -872,6 +965,7 @@ Perl_grok_atou(const char *pv, const char** endptr) return val; } +#ifndef USE_QUADMATH STATIC NV S_mulexp10(NV value, I32 exponent) { @@ -950,12 +1044,17 @@ S_mulexp10(NV value, I32 exponent) } return negative ? value / result : value * result; } +#endif /* #ifndef USE_QUADMATH */ NV Perl_my_atof(pTHX_ const char* s) { NV x = 0.0; -#ifdef USE_LOCALE_NUMERIC +#ifdef USE_QUADMATH + Perl_my_atof2(aTHX_ s, &x); + return x; +#else +# ifdef USE_LOCALE_NUMERIC PERL_ARGS_ASSERT_MY_ATOF; { @@ -988,21 +1087,96 @@ Perl_my_atof(pTHX_ const char* s) Perl_atof2(s, x); RESTORE_LC_NUMERIC(); } -#else +# else Perl_atof2(s, x); +# endif #endif return x; } +static char* +S_my_atof_infnan(const char* s, bool negative, const char* send, NV* value) +{ + const char *p0 = negative ? s - 1 : s; + const char *p = p0; + int infnan = grok_infnan(&p, send); + if (infnan && p != p0) { + /* If we can generate inf/nan directly, let's do so. */ +#ifdef NV_INF + if ((infnan & IS_NUMBER_INFINITY)) { + *value = (infnan & IS_NUMBER_NEG) ? -NV_INF: NV_INF; + return (char*)p; + } +#endif +#ifdef NV_NAN + if ((infnan & IS_NUMBER_NAN)) { + *value = NV_NAN; + return (char*)p; + } +#endif +#ifdef Perl_strtod + /* If still here, we didn't have either NV_INF or NV_NAN, + * and can try falling back to native strtod/strtold. + * + * (Though, are our NV_INF or NV_NAN ever not defined?) + * + * The native interface might not recognize all the possible + * inf/nan strings Perl recognizes. What we can try + * is to try faking the input. We will try inf/-inf/nan + * as the most promising/portable input. */ + { + const char* fake = NULL; + char* endp; + NV nv; + if ((infnan & IS_NUMBER_INFINITY)) { + fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf"; + } + else if ((infnan & IS_NUMBER_NAN)) { + fake = "nan"; + } + assert(fake); + nv = Perl_strtod(fake, &endp); + if (fake != endp) { + if ((infnan & IS_NUMBER_INFINITY)) { +#ifdef Perl_isinf + if (Perl_isinf(nv)) + *value = nv; +#else + /* last resort, may generate SIGFPE */ + *value = Perl_exp((NV)1e9); + if ((infnan & IS_NUMBER_NEG)) + *value = -*value; +#endif + return (char*)p; /* p, not endp */ + } + else if ((infnan & IS_NUMBER_NAN)) { +#ifdef Perl_isnan + if (Perl_isnan(nv)) + *value = nv; +#else + /* last resort, may generate SIGFPE */ + *value = Perl_log((NV)-1.0); +#endif + return (char*)p; /* p, not endp */ + } + } + } +#endif /* #ifdef Perl_strtod */ + } + return NULL; +} + char* Perl_my_atof2(pTHX_ const char* orig, NV* value) { - NV result[3] = {0.0, 0.0, 0.0}; const char* s = orig; -#ifdef USE_PERL_ATOF - UV accumulator[2] = {0,0}; /* before/after dp */ + NV result[3] = {0.0, 0.0, 0.0}; +#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) + const char* send = s + strlen(orig); /* one past the last */ bool negative = 0; - const char* send = s + strlen(orig) - 1; +#endif +#if defined(USE_PERL_ATOF) && !defined(USE_QUADMATH) + UV accumulator[2] = {0,0}; /* before/after dp */ bool seen_digit = 0; I32 exp_adjust[2] = {0,0}; I32 exp_acc[2] = {-1, -1}; @@ -1012,9 +1186,39 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) I32 digit = 0; I32 old_digit = 0; I32 sig_digits = 0; /* noof significant digits seen so far */ +#endif +#if defined(USE_PERL_ATOF) || defined(USE_QUADMATH) PERL_ARGS_ASSERT_MY_ATOF2; + /* leading whitespace */ + while (isSPACE(*s)) + ++s; + + /* sign */ + switch (*s) { + case '-': + negative = 1; + /* FALLTHROUGH */ + case '+': + ++s; + } +#endif + +#ifdef USE_QUADMATH + { + char* endp; + if ((endp = S_my_atof_infnan(s, negative, send, value))) + return endp; + result[2] = strtoflt128(s, &endp); + if (s != endp) { + *value = negative ? -result[2] : result[2]; + return endp; + } + return NULL; + } +#elif defined(USE_PERL_ATOF) + /* There is no point in processing more significant digits * than the NV can hold. Note that NV_DIG is a lower-bound value, * while we need an upper-bound value. We add 2 to account for this; @@ -1044,33 +1248,11 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) /* the max number we can accumulate in a UV, and still safely do 10*N+9 */ #define MAX_ACCUMULATE ( (UV) ((UV_MAX - 9)/10)) - /* leading whitespace */ - while (isSPACE(*s)) - ++s; - - /* sign */ - switch (*s) { - case '-': - negative = 1; - /* FALLTHROUGH */ - case '+': - ++s; - } - - /* punt to strtod for NaN/Inf; if no support for it there, tough luck */ - -#ifdef HAS_STRTOD - if (*s == 'n' || *s == 'N' || *s == 'i' || *s == 'I') { - const char *p = negative ? s - 1 : s; - char *endp; - NV rslt; - rslt = strtod(p, &endp); - if (endp != p) { - *value = rslt; - return (char *)endp; - } + { + const char* endp; + if ((endp = S_my_atof_infnan(s, negative, send, value))) + return (char*)endp; } -#endif /* we accumulate digits into an integer; when this becomes too * large, we add the total to NV and start again */ @@ -1143,7 +1325,7 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) result[1] = S_mulexp10(result[1], exp_acc[1]) + (NV)accumulator[1]; } - if (seen_digit && (*s == 'e' || *s == 'E')) { + if (seen_digit && (isALPHA_FOLD_EQ(*s, 'e'))) { bool expnegative = 0; ++s; @@ -1179,20 +1361,58 @@ Perl_my_atof2(pTHX_ const char* orig, NV* value) return (char *)s; } -#if ! defined(HAS_MODFL) && defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +/* +=for apidoc isinfnan + +Perl_isinfnan() is utility function that returns true if the NV +argument is either an infinity or a NaN, false otherwise. To test +in more detail, use Perl_isinf() and Perl_isnan(). + +This is also the logical inverse of Perl_isfinite(). + +=cut +*/ +bool +Perl_isinfnan(NV nv) +{ +#ifdef Perl_isinf + if (Perl_isinf(nv)) + return TRUE; +#endif +#ifdef Perl_isnan + if (Perl_isnan(nv)) + return TRUE; +#endif + return FALSE; +} + +#ifndef HAS_MODFL +/* C99 has truncl, pre-C99 Solaris had aintl. We can use either with + * copysignl to emulate modfl, which is in some platforms missing or + * broken. */ +# if defined(HAS_TRUNCL) && defined(HAS_COPYSIGNL) long double Perl_my_modfl(long double x, long double *ip) { - *ip = aintl(x); - return (x == *ip ? copysignl(0.0L, x) : x - *ip); + *ip = truncl(x); + return (x == *ip ? copysignl(0.0L, x) : x - *ip); } +# elif defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +long double +Perl_my_modfl(long double x, long double *ip) +{ + *ip = aintl(x); + return (x == *ip ? copysignl(0.0L, x) : x - *ip); +} +# endif #endif +/* Similarly, with ilobl and scalbnl we can emulate frexpl. */ #if ! defined(HAS_FREXPL) && defined(HAS_ILOGBL) && defined(HAS_SCALBNL) long double Perl_my_frexpl(long double x, int *e) { - *e = x == 0.0L ? 0 : ilogbl(x) + 1; - return (scalbnl(x, -*e)); + *e = x == 0.0L ? 0 : ilogbl(x) + 1; + return (scalbnl(x, -*e)); } #endif @@ -1204,11 +1424,8 @@ it is not. If Configure detects this system has a signbit() that will work with our NVs, then we just use it via the #define in perl.h. Otherwise, -fall back on this implementation. As a first pass, this gets everything -right except -0.0. Alas, catching -0.0 is the main use for this function, -so this is not too helpful yet. Still, at least we have the scaffolding -in place to support other systems, should that prove useful. - +fall back on this implementation. The main use of this function +is catching -0.0. Configure notes: This function is called 'Perl_signbit' instead of a plain 'signbit' because it is easy to imagine a system having a signbit() @@ -1224,6 +1441,10 @@ Users should just always call Perl_signbit(). #if !defined(HAS_SIGNBIT) int Perl_signbit(NV x) { +# ifdef Perl_fp_class_nzero + if (x == 0) + return Perl_fp_class_nzero(x); +# endif return (x < 0.0) ? 1 : 0; } #endif diff --git a/op.c b/op.c index f785c55..163b6a8 100644 --- a/op.c +++ b/op.c @@ -496,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -518,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -543,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -565,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + SV * const namesv = cv_name((CV *)gv, NULL); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -725,6 +695,11 @@ Perl_op_free(pTHX_ OP *o) return; type = o->op_type; + + /* an op should only ever acquire op_private flags that we know about. + * If this fails, you may need to fix something in regen/op_private */ + assert(!(o->op_private & ~PL_op_private_valid[type])); + if (o->op_private & OPpREFCOUNTED) { switch (type) { case OP_LEAVESUB: @@ -832,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - /* No GvIN_PAD_off(cGVOPo_gv) here, because other references - * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } @@ -900,8 +873,6 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - /* No GvIN_PAD_off here, because other references may still - * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else @@ -2371,9 +2342,6 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ - /* Both ENTERSUB and RV2CV use this bit, but for different pur- - poses, so we need it clear. */ - o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ @@ -2391,6 +2359,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) else { /* Compile-time error message: */ OP *kid = cUNOPo->op_first; CV *cv; + GV *gv; if (kid->op_type != OP_PUSHMARK) { if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) @@ -2418,7 +2387,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) break; } - cv = GvCV(kGVOP_gv); + gv = kGVOP_gv; + cv = isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : NULL; if (!cv) break; if (CvLVALUE(cv)) @@ -2773,7 +2747,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) assert(cUNOPo->op_first->op_type == OP_NULL); op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; - o->op_private &= ~1; } else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV @@ -3730,6 +3703,7 @@ S_fold_constants(pTHX_ OP *o) SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; COP not_compiling; + U8 oldwarn = PL_dowarn; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -3775,7 +3749,7 @@ S_fold_constants(pTHX_ OP *o) { const char *s = SvPVX_const(sv); while (s < SvEND(sv)) { - if (*s == 'p' || *s == 'P') goto nope; + if (isALPHA_FOLD_EQ(*s, 'p')) goto nope; s++; } } @@ -3824,6 +3798,10 @@ S_fold_constants(pTHX_ OP *o) PL_diehook = NULL; JMPENV_PUSH(ret); + /* Effective $^W=1. */ + if ( ! (PL_dowarn & G_WARN_ALL_MASK)) + PL_dowarn |= G_WARN_ON; + switch (ret) { case 0: CALLRUNOPS(aTHX); @@ -3853,6 +3831,7 @@ S_fold_constants(pTHX_ OP *o) Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret); } JMPENV_POP; + PL_dowarn = oldwarn; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; PL_curcop = &PL_compiling; @@ -5202,7 +5181,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; - padop->op_padix = pad_alloc(type, SVs_PADTMP); + padop->op_padix = + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); @@ -5235,7 +5215,6 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS - GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); @@ -5297,7 +5276,6 @@ Perl_package(pTHX_ OP *o) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; op_free(o); } @@ -5436,7 +5414,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) PL_hints |= HINT_BLOCK_SCOPE; PL_parser->copline = NOLINE; - PL_parser->expect = XSTATE; PL_cop_seqmax++; /* Purely for B::*'s benefit */ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */ PL_cop_seqmax++; @@ -7052,12 +7029,19 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block) return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0); } +/* must not conflict with SVf_UTF8 */ +#define CV_CKPROTO_CURSTASH 0x1 + void Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, const STRLEN len, const U32 flags) { SV *name = NULL, *msg; - const char * cvp = SvROK(cv) ? "" : CvPROTO(cv); + const char * cvp = SvROK(cv) + ? SvTYPE(SvRV_const(cv)) == SVt_PVCV + ? (cv = (const CV *)SvRV_const(cv), CvPROTO(cv)) + : "" + : CvPROTO(cv); STRLEN clen = CvPROTOLEN(cv), plen = len; PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS; @@ -7094,6 +7078,16 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p, gv_efullname3(name = sv_newmortal(), gv, NULL); else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&') name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP); + else if (flags & CV_CKPROTO_CURSTASH || SvROK(gv)) { + name = sv_2mortal(newSVhek(HvNAME_HEK(PL_curstash))); + sv_catpvs(name, "::"); + if (SvROK(gv)) { + assert (SvTYPE(SvRV_const(gv)) == SVt_PVCV); + assert (CvNAMED(SvRV_const(gv))); + sv_cathek(name, CvNAME_HEK(MUTABLE_CV(SvRV_const(gv)))); + } + else sv_catsv(name, (SV *)gv); + } else name = (SV *)gv; } sv_setpvs(msg, "Prototype mismatch:"); @@ -7148,6 +7142,7 @@ Perl_cv_const_sv_or_av(const CV * const cv) { if (!cv) return NULL; + if (SvROK(cv)) return SvRV((SV *)cv); assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } @@ -7203,6 +7198,10 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv) return NULL; if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; + else if (type == OP_UNDEF && !o->op_private) { + sv = newSV(0); + SAVEFREESV(sv); + } else if (cv && type == OP_CONST) { sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) @@ -7357,12 +7356,16 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvNAMED(*spot)) hek = CvNAME_HEK(*spot); else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); CvNAME_HEK_set(*spot, hek = share_hek( PadnamePV(name)+1, - PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0 + PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash ) ); + CvLEXICAL_on(*spot); } if (mg) { assert(mg->mg_obj); @@ -7489,14 +7492,18 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) *spot = cv; } setname: + CvLEXICAL_on(cv); if (!CvNAME_HEK(cv)) { - CvNAME_HEK_set(cv, - hek - ? share_hek_hek(hek) - : share_hek(PadnamePV(name)+1, + if (hek) (void)share_hek_hek(hek); + else { + dVAR; + U32 hash; + PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1); + hek = share_hek(PadnamePV(name)+1, PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), - 0) - ); + hash); + } + CvNAME_HEK_set(cv, hek); } if (const_sv) goto clone; @@ -7633,7 +7640,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, /* If the subroutine has no body, no attributes, and no builtin attributes then it's just a sub declaration, and we may be able to get away with storing with a placeholder scalar in the symbol table, rather than a - full GV and CV. If anything is present then it will take a full CV to + full CV. If anything is present then it will take a full CV to store it. */ const I32 gv_fetch_flags = ec ? GV_NOADD_NOINIT : @@ -7646,6 +7653,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; + bool special = FALSE; #endif if (o_is_gv) { @@ -7653,7 +7661,20 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, o = NULL; has_name = TRUE; } else if (name) { - gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + /* Try to optimise and avoid creating a GV. Instead, the CV’s name + hek and CvSTASH pointer together can imply the GV. If the name + contains a package name, then GvSTASH(CvGV(cv)) may differ from + CvSTASH, so forego the optimisation if we find any. + Also, we may be called from load_module at run time, so + PL_curstash (which sets CvSTASH) may not point to the stash the + sub is stored in. */ + const I32 flags = + ec ? GV_NOADD_NOINIT + : PL_curstash != CopSTASH(PL_curcop) + || memchr(name, ':', namlen) || memchr(name, '\'', namlen) + ? gv_fetch_flags + : GV_ADDMULTI | GV_NOINIT; + gv = gv_fetchsv(cSVOPo->op_sv, flags, SVt_PVCV); has_name = TRUE; } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); @@ -7670,7 +7691,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, has_name = FALSE; } if (!ec) - move_proto_attr(&proto, &attrs, gv); + move_proto_attr(&proto, &attrs, + isGV(gv) ? gv : (GV *)cSVOPo->op_sv); if (proto) { assert(proto->op_type == OP_CONST); @@ -7709,26 +7731,46 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, goto done; } - if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at - maximum a prototype before. */ + if (!block && SvTYPE(gv) != SVt_PVGV) { + /* If we are not defining a new sub and the existing one is not a + full GV + CV... */ + if (attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)) { + /* We are applying attributes to an existing sub, so we need it + upgraded if it is a constant. */ + if (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_init_pvn(gv, PL_curstash, name, namlen, + SVf_UTF8 * name_is_utf8); + } + else { /* Maybe prototype now, and had at maximum + a prototype or const/sub ref before. */ if (SvTYPE(gv) > SVt_NULL) { cv_ckproto_len_flags((const CV *)gv, o ? (const GV *)cSVOPo->op_sv : NULL, ps, ps_len, ps_utf8); } - if (ps) { + if (!SvROK(gv)) { + if (ps) { sv_setpvn(MUTABLE_SV(gv), ps, ps_len); if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv)); - } - else + } + else sv_setiv(MUTABLE_SV(gv), -1); + } SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; goto done; + } } - cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv); + cv = (!name || (isGV(gv) && GvCVGEN(gv))) + ? NULL + : isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : NULL; + if (!block || !ps || *ps || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) @@ -7737,6 +7779,38 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, else const_sv = op_const_sv(block, NULL); + if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) { + assert (block); + cv_ckproto_len_flags((const CV *)gv, + o ? (const GV *)cSVOPo->op_sv : NULL, ps, + ps_len, ps_utf8|CV_CKPROTO_CURSTASH); + if (SvROK(gv)) { + /* All the other code for sub redefinition warnings expects the + clobbered sub to be a CV. Instead of making all those code + paths more complex, just inline the RV version here. */ + const line_t oldline = CopLINE(PL_curcop); + assert(IN_PERL_COMPILETIME); + if (PL_parser && PL_parser->copline != NOLINE) + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ + CopLINE_set(PL_curcop, PL_parser->copline); + /* protect against fatal warnings leaking compcv */ + SAVEFREESV(PL_compcv); + + if (ckWARN(WARN_REDEFINE) + || ( ckWARN_d(WARN_REDEFINE) + && ( !const_sv || SvRV(gv) == const_sv + || sv_cmp(SvRV(gv), const_sv) ))) + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Constant subroutine %"SVf" redefined", + SVfARG(cSVOPo->op_sv)); + + SvREFCNT_inc_simple_void_NN(PL_compcv); + CopLINE_set(PL_curcop, oldline); + SvREFCNT_dec(SvRV(gv)); + } + } + if (cv) { const bool exists = CvROOT(cv) || CvXSUB(cv); @@ -7747,7 +7821,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (exists || SvPOK(cv)) cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8); /* already defined (or promised)? */ - if (exists || GvASSUMECV(gv)) { + if (exists || (isGV(gv) && GvASSUMECV(gv))) { if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv)) cv = NULL; else { @@ -7771,11 +7845,22 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvISXSUB_on(cv); } else { - GvCV_set(gv, NULL); - cv = newCONSTSUB_flags( - NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, - const_sv - ); + if (isGV(gv)) { + if (name) GvCV_set(gv, NULL); + cv = newCONSTSUB_flags( + NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0, + const_sv + ); + } + else { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, const_sv); + } } op_free(block); SvREFCNT_dec(PL_compcv); @@ -7793,12 +7878,26 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE); OP * const cvstart = CvSTART(cv); - CvGV_set(cv,gv); - assert(!CvCVGV_RC(cv)); - assert(CvGV(cv) == gv); + if (isGV(gv)) { + CvGV_set(cv,gv); + assert(!CvCVGV_RC(cv)); + assert(CvGV(cv) == gv); + } + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, + share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } SvPOK_off(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs; + CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs + | CvNAMED(cv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvPADLIST(cv) = CvPADLIST(PL_compcv); @@ -7830,16 +7929,35 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } else { cv = PL_compcv; - if (name) { + if (name && isGV(gv)) { GvCV_set(gv, cv); GvCVGEN(gv) = 0; if (HvENAME_HEK(GvSTASH(gv))) /* sub Foo::bar { (shift)+1 } */ gv_method_changed(gv); } + else if (name) { + if (!SvROK(gv)) { + SV_CHECK_THINKFIRST_COW_DROP((SV *)gv); + prepare_SV_for_RV((SV *)gv); + SvOK_off((SV *)gv); + SvROK_on(gv); + } + SvRV_set(gv, (SV *)cv); + } } - if (!CvGV(cv)) { - CvGV_set(cv, gv); + if (!CvHASGV(cv)) { + if (isGV(gv)) CvGV_set(cv, gv); + else { + dVAR; + U32 hash; + PERL_HASH(hash, name, namlen); + CvNAME_HEK_set(cv, share_hek(name, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, + hash)); + } CvFILE_set_from_cop(cv, PL_curcop); CvSTASH_set(cv, PL_curstash); } @@ -7896,7 +8014,9 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, attrs: if (attrs) { /* Need to do a C. */ - HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + HV *stash = name && !CvNAMED(cv) && GvSTASH(CvGV(cv)) + ? GvSTASH(CvGV(cv)) + : PL_curstash; if (!name) SAVEFREESV(cv); apply_attrs(stash, MUTABLE_SV(cv), attrs); if (!name) SvREFCNT_inc_simple_void_NN(cv); @@ -7904,7 +8024,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = sv_newmortal(); + SV * const tmpstr = cv_name(cv,NULL); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -7912,7 +8032,6 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); - gv_efullname3(tmpstr, gv, NULL); (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); @@ -7932,7 +8051,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else - process_special_blocks(floor, name, gv, cv); +#ifdef PERL_DEBUG_READONLY_OPS + special = +#endif + process_special_blocks(floor, name, gv, cv); } } @@ -7942,7 +8064,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, LEAVE_SCOPE(floor); #ifdef PERL_DEBUG_READONLY_OPS /* Watch out for BEGIN blocks */ - if (slab && gv && isGV(gv) && GvCV(gv)) Slab_to_ro(slab); + if (!special) Slab_to_ro(slab); #endif return cv; } @@ -7963,12 +8085,16 @@ S_clear_special_blocks(pTHX_ const char *const fullname, || (*name == 'U' && strEQ(name, "UNITCHECK")) || (*name == 'C' && strEQ(name, "CHECK")) || (*name == 'I' && strEQ(name, "INIT"))) { + if (!isGV(gv)) { + (void)CvGV(cv); + assert(isGV(gv)); + } GvCV_set(gv, NULL); SvREFCNT_dec_NN(MUTABLE_SV(cv)); } } -STATIC void +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) @@ -7982,6 +8108,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, if (strEQ(name, "BEGIN")) { const I32 oldscope = PL_scopestack_ix; dSP; + (void)CvGV(cv); if (floor) LEAVE_SCOPE(floor); ENTER; PUSHSTACKi(PERLSI_REQUIRE); @@ -7996,23 +8123,24 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, POPSTACK; LEAVE; + return TRUE; } else - return; + return FALSE; } else { if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { if (PL_main_start) @@ -8022,7 +8150,7 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else if (*name == 'I') { if (strEQ(name, "INIT")) { if (PL_main_start) @@ -8032,11 +8160,13 @@ S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else - return; + return FALSE; } else - return; + return FALSE; DEBUG_x( dump_sub(gv) ); + (void)CvGV(cv); GvCV_set(gv,0); /* cv has been hijacked */ + return TRUE; } } @@ -8826,8 +8956,6 @@ Perl_ck_rvconst(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_RVCONST; o->op_private |= (PL_hints & HINT_STRICT_REFS); - if (o->op_type == OP_RV2CV) - o->op_private &= ~1; if (kid->op_type == OP_CONST) { int iscv; @@ -8835,31 +8963,7 @@ Perl_ck_rvconst(pTHX_ OP *o) SV * const kidsv = kid->op_sv; /* Is it a constant from cv_const_sv()? */ - if (SvROK(kidsv) && SvREADONLY(kidsv)) { - SV * const rsv = SvRV(kidsv); - const svtype type = SvTYPE(rsv); - const char *badtype = NULL; - - switch (o->op_type) { - case OP_RV2SV: - if (type > SVt_PVMG) - badtype = "a SCALAR"; - break; - case OP_RV2AV: - if (type != SVt_PVAV) - badtype = "an ARRAY"; - break; - case OP_RV2HV: - if (type != SVt_PVHV) - badtype = "a HASH"; - break; - case OP_RV2CV: - if (type != SVt_PVCV) - badtype = "a CODE"; - break; - } - if (badtype) - Perl_croak(aTHX_ "Constant is not %s reference", badtype); + if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) { return o; } if (SvTYPE(kidsv) == SVt_PVAV) return o; @@ -8892,10 +8996,12 @@ Perl_ck_rvconst(pTHX_ OP *o) * or we get possible typo warnings. OPpCONST_ENTERED says * whether the lexer already added THIS instance of this symbol. */ - iscv = (o->op_type == OP_RV2CV) * 2; - do { - gv = gv_fetchsv(kidsv, - iscv | !(kid->op_private & OPpCONST_ENTERED), + iscv = o->op_type == OP_RV2CV ? GV_NOEXPAND|GV_ADDMULTI : 0; + gv = gv_fetchsv(kidsv, + o->op_type == OP_RV2CV + && o->op_private & OPpMAY_RETURN_CONSTANT + ? GV_NOEXPAND + : iscv | !(kid->op_private & OPpCONST_ENTERED), iscv ? SVt_PVCV : o->op_type == OP_RV2SV @@ -8905,16 +9011,21 @@ Perl_ck_rvconst(pTHX_ OP *o) : o->op_type == OP_RV2HV ? SVt_PVHV : SVt_PVGV); - } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++); if (gv) { + if (!isGV(gv)) { + assert(iscv); + assert(SvROK(gv)); + if (!(o->op_private & OPpMAY_RETURN_CONSTANT) + && SvTYPE(SvRV(gv)) != SVt_PVCV) + gv_fetchsv(kidsv, GV_ADDMULTI, SVt_PVCV); + } kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ assert (sizeof(PADOP) <= sizeof(SVOP)); - kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); + kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); @@ -9677,12 +9788,15 @@ Perl_ck_require(pTHX_ OP *o) if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP * const kid = (SVOP*)cUNOPo->op_first; - - if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { - SV * const sv = kid->op_sv; - U32 was_readonly = SvREADONLY(sv); - char *s; - STRLEN len; + HEK *hek; + U32 hash; + char *s; + STRLEN len; + if (kid->op_type == OP_CONST) { + SV * const sv = kid->op_sv; + U32 const was_readonly = SvREADONLY(sv); + if (kid->op_private & OPpCONST_BARE) { + dVAR; const char *end; if (was_readonly) { @@ -9702,7 +9816,33 @@ Perl_ck_require(pTHX_ OP *o) } SvEND_set(sv, end); sv_catpvs(sv, ".pm"); + PERL_HASH(hash, SvPVX(sv), SvCUR(sv)); + hek = share_hek(SvPVX(sv), + (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1), + hash); + sv_sethek(sv, hek); + unshare_hek(hek); SvFLAGS(sv) |= was_readonly; + } + else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) { + s = SvPV(sv, len); + if (SvREFCNT(sv) > 1) { + kid->op_sv = newSVpvn_share( + s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0); + SvREFCNT_dec_NN(sv); + } + else { + dVAR; + if (was_readonly) SvREADONLY_off(sv); + PERL_HASH(hash, s, len); + hek = share_hek(s, + SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, + hash); + sv_sethek(sv, hek); + unshare_hek(hek); + SvFLAGS(sv) |= was_readonly; + } + } } } @@ -9830,6 +9970,33 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = kid; o->op_flags |= OPf_SPECIAL; } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv)); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; + cUNOPx(firstkid)->op_first = padop; + op_free(kid); + } + } + } firstkid = OP_SIBLING(firstkid); } @@ -10102,7 +10269,7 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) CV *cv; GV *gv; PERL_ARGS_ASSERT_RV2CV_OP_CV; - if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV)) + if (flags & ~RV2CVOPCV_FLAG_MASK) Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags); if (cvop->op_type != OP_RV2CV) return NULL; @@ -10114,6 +10281,16 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) switch (rvop->op_type) { case OP_GV: { gv = cGVOPx_gv(rvop); + if (!isGV(gv)) { + if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) { + cv = MUTABLE_CV(SvRV(gv)); + gv = NULL; + break; + } + if (flags & RV2CVOPCV_RETURN_STUB) + return (CV *)gv; + else return NULL; + } cv = GvCVu(gv); if (!cv) { if (flags & RV2CVOPCV_MARK_EARLY) @@ -10138,8 +10315,9 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if (!CvANON(cv) || !gv) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -10235,7 +10413,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -10273,32 +10456,6 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) goto wrapref; /* autoconvert GLOB -> GLOBref */ else if (o3->op_type == OP_CONST) o3->op_private &= ~OPpCONST_STRICT; - else if (o3->op_type == OP_ENTERSUB) { - /* accidental subroutine, revert to bareword */ - OP *gvop = ((UNOP*)o3)->op_first; - if (gvop && gvop->op_type == OP_NULL) { - gvop = ((UNOP*)gvop)->op_first; - if (gvop) { - for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop)) - ; - if (gvop && - (gvop->op_private & OPpENTERSUB_NOPAREN) && - (gvop = ((UNOP*)gvop)->op_first) && - gvop->op_type == OP_GV) - { - OP * newop; - GV * const gv = cGVOPx_gv(gvop); - SV * const n = newSVpvs(""); - gv_fullname4(n, gv, "", FALSE); - /* replace the aop subtree with a const op */ - newop = newSVOP(OP_CONST, 0, n); - op_sibling_splice(parent, prev, 1, newop); - op_free(aop); - aop = newop; - } - } - } - } scalar(aop); break; case '+': @@ -10411,10 +10568,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(protosv)); } } @@ -10428,7 +10584,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10596,24 +10756,33 @@ by L. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; - PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree for a @@ -10630,15 +10799,25 @@ It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, -which may be replaced by the check function, and I is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I supplies +the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L. You can force perl to pass a GV by including +C in the I. + The current setting for a particular CV can be retrieved by L. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L, which passes it the +C flag for backward-compatibility. + =cut */ @@ -10646,6 +10825,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10664,7 +10851,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10683,7 +10871,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = OP_SIBLING(aop); for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10708,21 +10896,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (!namegv) { + /* The original call checker API guarantees that a GV will be + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); } @@ -11351,7 +11542,7 @@ Perl_rpeep(pTHX_ OP *o) OP *rv2av, *q; p = o->op_next; if ( p->op_type == OP_GV - && (gv = cGVOPx_gv(p)) + && (gv = cGVOPx_gv(p)) && isGV(gv) && GvNAMELEN_get(gv) == 1 && *GvNAME_get(gv) == '_' && GvSTASH(gv) == PL_defstash diff --git a/op.h b/op.h index c76f37d..139375d 100644 --- a/op.h +++ b/op.h @@ -150,213 +150,23 @@ Deprecated. Use C instead. : G_SCALAR) \ : dowantarray()) -/* Lower bits of op_private often carry the number of arguments, as - * set by newBINOP, newUNOP and ck_fun */ -/* NOTE: OP_NEXTSTATE and OP_DBSTATE (i.e. COPs) carry NATIVE_HINTS - * in op_private */ +/* NOTE: OPp* flags are now auto-generated and defined in opcode.h, + * from data in regen/op_private */ -/* Private for lvalues */ -#define OPpLVAL_INTRO 128 /* Lvalue must be localized or lvalue sub */ -/* Private for OPs with TARGLEX */ - /* (lower bits may carry MAXARG) */ -#define OPpTARGET_MY 16 /* Target is PADMY. */ - -/* Private for OP_LEAVE, OP_LEAVESUB, OP_LEAVESUBLV and OP_LEAVEWRITE */ -#define OPpREFCOUNTED 64 /* op_targ carries a refcount */ - -/* Private for OP_LEAVE and OP_LEAVELOOP */ -#define OPpLVALUE 128 /* Do not copy return value */ - -/* Private for OP_AASSIGN */ -#define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */ - -/* Private for OP_SASSIGN */ -#define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */ -#define OPpASSIGN_CV_TO_GV 128 /* Possible optimisation for constants. */ - -/* Private for OP_MATCH and OP_SUBST{,CONT} */ -#define OPpRUNTIME 64 /* Pattern coming in on the stack */ - -/* Private for OP_TRANS */ -#define OPpTRANS_FROM_UTF 1 -#define OPpTRANS_TO_UTF 2 -#define OPpTRANS_IDENTICAL 4 /* right side is same as left */ -#define OPpTRANS_SQUASH 8 - /* 16 is used for OPpTARGET_MY */ -#define OPpTRANS_COMPLEMENT 32 -#define OPpTRANS_GROWS 64 -#define OPpTRANS_DELETE 128 #define OPpTRANS_ALL (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE) -/* Private for OP_REPEAT */ -#define OPpREPEAT_DOLIST 64 /* List replication. */ - -/* Private for OP_RV2GV, OP_RV2SV, OP_AELEM, OP_HELEM, OP_PADSV */ -#define OPpDEREF (32|64) /* autovivify: Want ref to something: */ -#define OPpDEREF_AV 32 /* Want ref to AV. */ -#define OPpDEREF_HV 64 /* Want ref to HV. */ -#define OPpDEREF_SV (32|64) /* Want ref to SV. */ - -/* OP_ENTERSUB and OP_RV2CV flags - -Flags are set on entersub and rv2cv in three phases: - parser - the parser passes the flag to the op constructor - check - the check routine called by the op constructor sets the flag - context - application of scalar/ref/lvalue context applies the flag - -In the third stage, an entersub op might turn into an rv2cv op (undef &foo, -\&foo, lock &foo, exists &foo, defined &foo). The two places where that -happens (op_lvalue_flags and doref in op.c) need to make sure the flags do -not conflict. Flags applied in the context phase are only set when there -is no conversion of op type. - - bit entersub flag phase rv2cv flag phase - --- ------------- ----- ---------- ----- - 1 OPpENTERSUB_INARGS context OPpMAY_RETURN_CONSTANT context - 2 HINT_STRICT_REFS check HINT_STRICT_REFS check - 4 OPpENTERSUB_HASTARG check - 8 OPpENTERSUB_AMPER parser - 16 OPpENTERSUB_DB check - 32 OPpDEREF_AV context - 64 OPpDEREF_HV context - 128 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser -*/ - /* OP_ENTERSUB only */ -#define OPpENTERSUB_DB 16 /* Debug subroutine. */ -#define OPpENTERSUB_HASTARG 4 /* Called from OP tree. */ -#define OPpENTERSUB_INARGS 1 /* Lval used as arg to a sub. */ -/* used by OPpDEREF (32|64) */ -/* used by HINT_STRICT_REFS 2 */ - /* Mask for OP_ENTERSUB flags, the absence of which must be propagated - in dynamic context */ +/* Mask for OP_ENTERSUB flags, the absence of which must be propagated + in dynamic context */ #define OPpENTERSUB_LVAL_MASK (OPpLVAL_INTRO|OPpENTERSUB_INARGS) - /* OP_RV2CV only */ -#define OPpENTERSUB_AMPER 8 /* Used & form to call. */ -#define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ -#define OPpMAY_RETURN_CONSTANT 1 /* If a constant sub, return the constant */ - - /* OP_GV only */ -#define OPpEARLY_CV 32 /* foo() called before sub foo was parsed */ - /* OP_?ELEM only */ -#define OPpLVAL_DEFER 16 /* Defer creation of array/hash elem */ - /* OP_RV2[AH]V OP_[AH]SLICE */ -#define OPpSLICEWARNING 4 /* warn about @hash{$scalar} */ - /* OP_RV2[SAH]V, OP_GVSV, OP_ENTERITER only */ -#define OPpOUR_INTRO 16 /* Variable was in an our() */ - /* OP_RV2[AGH]V, OP_PAD[AH]V, OP_[AH]ELEM, OP_[AH]SLICE OP_AV2ARYLEN, - OP_R?KEYS, OP_SUBSTR, OP_POS, OP_VEC */ -#define OPpMAYBE_LVSUB 8 /* We might be an lvalue to return */ - /* OP_RV2HV and OP_PADHV */ -#define OPpTRUEBOOL 32 /* %hash in (%hash || $foo) in - void context */ -#define OPpMAYBE_TRUEBOOL 64 /* %hash in (%hash || $foo) where - cx is not known till run time */ - - /* OP_SUBSTR only */ -#define OPpSUBSTR_REPL_FIRST 16 /* 1st arg is replacement string */ - - /* OP_PADSV only */ -#define OPpPAD_STATE 16 /* is a "state" pad */ - /* for OP_RV2?V, lower bits carry hints (currently only HINT_STRICT_REFS) */ - - /* OP_PADRANGE only */ - /* bit 7 is OPpLVAL_INTRO */ -#define OPpPADRANGE_COUNTMASK 127 /* bits 6..0 hold target range, */ -#define OPpPADRANGE_COUNTSHIFT 7 /* 7 bits in total */ - - /* OP_RV2GV only */ -#define OPpDONT_INIT_GV 4 /* Call gv_fetchpv with GV_NOINIT */ -/* (Therefore will return whatever is currently in the symbol table, not - guaranteed to be a PVGV) */ -#define OPpALLOW_FAKE 16 /* OK to return fake glob */ - -/* Private for OP_ENTERITER and OP_ITER */ -#define OPpITER_REVERSED 4 /* for (reverse ...) */ -#define OPpITER_DEF 8 /* for $_ or for my $_ */ - -/* Private for OP_CONST */ -#define OPpCONST_NOVER 2 /* no 6; */ -#define OPpCONST_SHORTCIRCUIT 4 /* eg the constant 5 in (5 || foo) */ -#define OPpCONST_STRICT 8 /* bareword subject to strict 'subs' */ -#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */ -#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */ - -/* Private for OP_FLIP/FLOP */ -#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */ - -/* Private for OP_LIST */ -#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */ - -/* Private for OP_DELETE */ -#define OPpSLICE 64 /* Operating on a list of keys */ -/* Also OPpLVAL_INTRO (128) */ - -/* Private for OP_EXISTS */ -#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */ - -/* Private for OP_SORT */ -#define OPpSORT_NUMERIC 1 /* Optimized away { $a <=> $b } */ -#define OPpSORT_INTEGER 2 /* Ditto while under "use integer" */ -#define OPpSORT_REVERSE 4 /* Reversed sort */ -#define OPpSORT_INPLACE 8 /* sort in-place; eg @a = sort @a */ -#define OPpSORT_DESCEND 16 /* Descending sort */ -#define OPpSORT_QSORT 32 /* Use quicksort (not mergesort) */ -#define OPpSORT_STABLE 64 /* Use a stable algorithm */ - -/* Private for OP_REVERSE */ -#define OPpREVERSE_INPLACE 8 /* reverse in-place (@a = reverse @a) */ - -/* Private for OP_OPEN and OP_BACKTICK */ -#define OPpOPEN_IN_RAW 16 /* binmode(F,":raw") on input fh */ -#define OPpOPEN_IN_CRLF 32 /* binmode(F,":crlf") on input fh */ -#define OPpOPEN_OUT_RAW 64 /* binmode(F,":raw") on output fh */ -#define OPpOPEN_OUT_CRLF 128 /* binmode(F,":crlf") on output fh */ - -/* Private for COPs */ -#define OPpHUSH_VMSISH 32 /* hush DCL exit msg vmsish mode*/ -/* Note: Used for NATIVE_HINTS (shifted from the values in PL_hints), - currently defined by vms/vmsish.h: - 64 - 128 - */ +/* VMS-specific hints in COPs */ +#define OPpHINT_M_VMSISH_MASK (OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME) + -/* Private for OP_FTXXX */ -#define OPpFT_ACCESS 2 /* use filetest 'access' */ -#define OPpFT_STACKED 4 /* stacked filetest, as "-f" in "-f -x $f" */ -#define OPpFT_STACKING 8 /* stacking filetest, as "-x" in "-f -x $f" */ -#define OPpFT_AFTER_t 16 /* previous op was -t */ - -/* Private for OP_(MAP|GREP)(WHILE|START) */ -#define OPpGREP_LEX 2 /* iterate over lexical $_ */ - -/* Private for OP_ENTEREVAL */ -#define OPpEVAL_HAS_HH 2 /* Does it have a copy of %^H */ -#define OPpEVAL_UNICODE 4 -#define OPpEVAL_BYTES 8 -#define OPpEVAL_COPHH 16 /* Construct %^H from cop hints */ -#define OPpEVAL_RE_REPARSING 32 /* eval_sv(..., G_RE_REPARSING) */ - -/* Private for OP_CALLER, OP_WANTARRAY and OP_RUNCV */ -#define OPpOFFBYONE 128 /* Treat caller(1) as caller(2) */ - -/* Private for OP_COREARGS */ -/* These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE. - See pp.c:S_rv2gv. */ -#define OPpCOREARGS_DEREF1 1 /* Arg 1 is a handle constructor */ -#define OPpCOREARGS_DEREF2 2 /* Arg 2 is a handle constructor */ -#define OPpCOREARGS_SCALARMOD 64 /* \$ rather than \[$@%*] */ -#define OPpCOREARGS_PUSHMARK 128 /* Call pp_pushmark */ - -/* Private for OP_(LAST|REDO|NEXT|GOTO|DUMP) */ -#define OPpPV_IS_UTF8 128 /* label is in UTF8 */ - -/* Private for OP_SPLIT */ -#define OPpSPLIT_IMPLIM 128 /* implicit limit */ struct op { BASEOP @@ -580,18 +390,21 @@ struct loop { #ifdef USE_ITHREADS # define cGVOPx_gv(o) ((GV*)PAD_SVl(cPADOPx(o)->op_padix)) -# define IS_PADGV(v) (v && SvTYPE(v) == SVt_PVGV && isGV_with_GP(v) \ - && GvIN_PAD(v)) -# define IS_PADCONST(v) \ +# ifndef PERL_CORE +# define IS_PADGV(v) (v && isGV(v)) +# define IS_PADCONST(v) \ (v && (SvREADONLY(v) || (SvIsCOW(v) && !SvLEN(v)))) +# endif # define cSVOPx_sv(v) (cSVOPx(v)->op_sv \ ? cSVOPx(v)->op_sv : PAD_SVl((v)->op_targ)) # define cSVOPx_svp(v) (cSVOPx(v)->op_sv \ ? &cSVOPx(v)->op_sv : &PAD_SVl((v)->op_targ)) #else # define cGVOPx_gv(o) ((GV*)cSVOPx(o)->op_sv) -# define IS_PADGV(v) FALSE -# define IS_PADCONST(v) FALSE +# ifndef PERL_CORE +# define IS_PADGV(v) FALSE +# define IS_PADCONST(v) FALSE +# endif # define cSVOPx_sv(v) (cSVOPx(v)->op_sv) # define cSVOPx_svp(v) (&cSVOPx(v)->op_sv) #endif @@ -617,7 +430,7 @@ struct loop { #define OA_DANGEROUS 64 #define OA_DEFGV 128 -/* The next 4 bits encode op class information */ +/* The next 4 bits (8..11) encode op class information */ #define OCSHIFT 8 #define OA_CLASS_MASK (15 << OCSHIFT) @@ -637,9 +450,10 @@ struct loop { #define OA_FILESTATOP (12 << OCSHIFT) #define OA_LOOPEXOP (13 << OCSHIFT) +/* Each remaining nybble of PL_opargs (i.e. bits 12..15, 16..19 etc) + * encode the type for each arg */ #define OASHIFT 12 -/* Remaining nybbles of PL_opargs */ #define OA_SCALAR 1 #define OA_LIST 2 #define OA_AVREF 3 @@ -687,7 +501,10 @@ struct loop { /* flags used by Perl_load_module() */ #define PERL_LOADMOD_DENY 0x1 /* no Module */ #define PERL_LOADMOD_NOIMPORT 0x2 /* use Module () */ -#define PERL_LOADMOD_IMPORT_OPS 0x4 /* use Module (...) */ +#define PERL_LOADMOD_IMPORT_OPS 0x4 /* import arguments + are passed as a sin- + gle op tree, not a + list of SVs */ #if defined(PERL_IN_PERLY_C) || defined(PERL_IN_OP_C) || defined(PERL_IN_TOKE_C) #define ref(o, type) doref(o, type, TRUE) @@ -878,6 +695,11 @@ preprocessing token; the type of I depends on I. #define RV2CVOPCV_MARK_EARLY 0x00000001 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002 +#define RV2CVOPCV_RETURN_STUB 0x00000004 +#ifdef PERL_CORE /* behaviour of this flag is subject to change: */ +# define RV2CVOPCV_MAYBE_NAME_GV 0x00000008 +#endif +#define RV2CVOPCV_FLAG_MASK 0x0000000f /* all of the above */ #define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0) diff --git a/opcode.h b/opcode.h index fbc3fe1..a5abfb8 100644 --- a/opcode.h +++ b/opcode.h @@ -2110,4 +2110,1358 @@ EXTCONST U32 PL_opargs[] = { END_EXTERN_C + +#define OPpARG1_MASK 0x01 +#define OPpCOREARGS_DEREF1 0x01 +#define OPpENTERSUB_INARGS 0x01 +#define OPpSORT_NUMERIC 0x01 +#define OPpTRANS_FROM_UTF 0x01 +#define OPpCONST_NOVER 0x02 +#define OPpCOREARGS_DEREF2 0x02 +#define OPpEVAL_HAS_HH 0x02 +#define OPpFT_ACCESS 0x02 +#define OPpGREP_LEX 0x02 +#define OPpHINT_STRICT_REFS 0x02 +#define OPpSORT_INTEGER 0x02 +#define OPpTRANS_TO_UTF 0x02 +#define OPpARG2_MASK 0x03 +#define OPpCONST_SHORTCIRCUIT 0x04 +#define OPpDONT_INIT_GV 0x04 +#define OPpENTERSUB_HASTARG 0x04 +#define OPpEVAL_UNICODE 0x04 +#define OPpFT_STACKED 0x04 +#define OPpITER_REVERSED 0x04 +#define OPpSLICEWARNING 0x04 +#define OPpSORT_REVERSE 0x04 +#define OPpTRANS_IDENTICAL 0x04 +#define OPpARG3_MASK 0x07 +#define OPpPADRANGE_COUNTSHIFT 0x07 +#define OPpCONST_STRICT 0x08 +#define OPpENTERSUB_AMPER 0x08 +#define OPpEVAL_BYTES 0x08 +#define OPpFT_STACKING 0x08 +#define OPpITER_DEF 0x08 +#define OPpMAYBE_LVSUB 0x08 +#define OPpREVERSE_INPLACE 0x08 +#define OPpSORT_INPLACE 0x08 +#define OPpTRANS_SQUASH 0x08 +#define OPpARG4_MASK 0x0f +#define OPpALLOW_FAKE 0x10 +#define OPpCONST_ENTERED 0x10 +#define OPpENTERSUB_DB 0x10 +#define OPpEVAL_COPHH 0x10 +#define OPpFT_AFTER_t 0x10 +#define OPpLVAL_DEFER 0x10 +#define OPpOPEN_IN_RAW 0x10 +#define OPpOUR_INTRO 0x10 +#define OPpPAD_STATE 0x10 +#define OPpSORT_DESCEND 0x10 +#define OPpSUBSTR_REPL_FIRST 0x10 +#define OPpTARGET_MY 0x10 +#define OPpDEREF_AV 0x20 +#define OPpEARLY_CV 0x20 +#define OPpEVAL_RE_REPARSING 0x20 +#define OPpHUSH_VMSISH 0x20 +#define OPpOPEN_IN_CRLF 0x20 +#define OPpSORT_QSORT 0x20 +#define OPpTRANS_COMPLEMENT 0x20 +#define OPpTRUEBOOL 0x20 +#define OPpASSIGN_BACKWARDS 0x40 +#define OPpASSIGN_COMMON 0x40 +#define OPpCONST_BARE 0x40 +#define OPpCOREARGS_SCALARMOD 0x40 +#define OPpDEREF_HV 0x40 +#define OPpEXISTS_SUB 0x40 +#define OPpFLIP_LINENUM 0x40 +#define OPpHINT_M_VMSISH_STATUS 0x40 +#define OPpLIST_GUESSED 0x40 +#define OPpMAYBE_TRUEBOOL 0x40 +#define OPpMAY_RETURN_CONSTANT 0x40 +#define OPpOPEN_OUT_RAW 0x40 +#define OPpREFCOUNTED 0x40 +#define OPpREPEAT_DOLIST 0x40 +#define OPpRUNTIME 0x40 +#define OPpSLICE 0x40 +#define OPpSORT_STABLE 0x40 +#define OPpTRANS_GROWS 0x40 +#define OPpDEREF 0x60 +#define OPpDEREF_SV 0x60 +#define OPpPADRANGE_COUNTMASK 0x7f +#define OPpASSIGN_CV_TO_GV 0x80 +#define OPpCOREARGS_PUSHMARK 0x80 +#define OPpENTERSUB_NOPAREN 0x80 +#define OPpHINT_M_VMSISH_TIME 0x80 +#define OPpLVALUE 0x80 +#define OPpLVAL_INTRO 0x80 +#define OPpOFFBYONE 0x80 +#define OPpOPEN_OUT_CRLF 0x80 +#define OPpPV_IS_UTF8 0x80 +#define OPpSPLIT_IMPLIM 0x80 +#define OPpTRANS_DELETE 0x80 +START_EXTERN_C + +#ifndef PERL_GLOBAL_STRUCT_INIT + +# ifndef DOINIT + +/* data about the flags in op_private */ + +EXTCONST I16 PL_op_private_bitdef_ix[]; +EXTCONST U16 PL_op_private_bitdefs[]; +EXTCONST char PL_op_private_labels[]; +EXTCONST I16 PL_op_private_bitfields[]; +EXTCONST U8 PL_op_private_valid[]; + +# else + + +/* PL_op_private_labels[]: the short descriptions of private flags. + * All labels are concatenated into a single char array + * (separated by \0's) for compactness. + */ + +EXTCONST char PL_op_private_labels[] = { + '$','M','O','D','\0', + '+','1','\0', + '-','\0', + '<','U','T','F','\0', + '>','U','T','F','\0', + 'A','M','P','E','R','\0', + 'B','A','R','E','\0', + 'B','K','W','A','R','D','\0', + 'B','O','O','L','\0', + 'B','O','O','L','?','\0', + 'B','Y','T','E','S','\0', + 'C','O','M','M','O','N','\0', + 'C','O','M','P','L','\0', + 'C','O','N','S','T','\0', + 'C','O','P','H','H','\0', + 'C','V','2','G','V','\0', + 'D','B','G','\0', + 'D','E','F','\0', + 'D','E','L','\0', + 'D','E','R','E','F','1','\0', + 'D','E','R','E','F','2','\0', + 'D','E','S','C','\0', + 'D','O','L','I','S','T','\0', + 'D','R','E','F','A','V','\0', + 'D','R','E','F','H','V','\0', + 'D','R','E','F','S','V','\0', + 'E','A','R','L','Y','C','V','\0', + 'E','N','T','E','R','E','D','\0', + 'F','A','K','E','\0', + 'F','T','A','C','C','E','S','S','\0', + 'F','T','A','F','T','E','R','t','\0', + 'F','T','S','T','A','C','K','E','D','\0', + 'F','T','S','T','A','C','K','I','N','G','\0', + 'G','R','E','P','L','E','X','\0', + 'G','R','O','W','S','\0', + 'G','U','E','S','S','E','D','\0', + 'H','A','S','_','H','H','\0', + 'H','U','S','H','\0', + 'I','D','E','N','T','\0', + 'I','M','P','L','I','M','\0', + 'I','N','A','R','G','S','\0', + 'I','N','B','I','N','\0', + 'I','N','C','R','\0', + 'I','N','P','L','A','C','E','\0', + 'I','N','T','\0', + 'L','I','N','E','N','U','M','\0', + 'L','V','\0', + 'L','V','D','E','F','E','R','\0', + 'L','V','I','N','T','R','O','\0', + 'L','V','S','U','B','\0', + 'M','A','R','K','\0', + 'N','O','(',')','\0', + 'N','O','I','N','I','T','\0', + 'N','O','V','E','R','\0', + 'N','U','M','\0', + 'O','U','R','I','N','T','R','\0', + 'O','U','T','B','I','N','\0', + 'O','U','T','C','R','\0', + 'Q','S','O','R','T','\0', + 'R','E','F','C','\0', + 'R','E','P','A','R','S','E','\0', + 'R','E','P','L','1','S','T','\0', + 'R','E','V','\0', + 'R','E','V','E','R','S','E','D','\0', + 'R','T','I','M','E','\0', + 'S','H','O','R','T','\0', + 'S','L','I','C','E','\0', + 'S','L','I','C','E','W','A','R','N','\0', + 'S','Q','U','A','S','H','\0', + 'S','T','A','B','L','E','\0', + 'S','T','A','T','E','\0', + 'S','T','R','I','C','T','\0', + 'S','U','B','\0', + 'T','A','R','G','\0', + 'T','A','R','G','M','Y','\0', + 'U','N','I','\0', + 'U','T','F','\0', + 'V','M','S','I','S','H','_','S','T','A','T','U','S','\0', + 'V','M','S','I','S','H','_','T','I','M','E','\0', + +}; + + + +/* PL_op_private_bitfields[]: details about each bit field type. + * Each defintition consists of the following list of words: + * bitmin + * label (index into PL_op_private_labels[]; -1 if no label) + * repeat for each enum entry (if any): + * enum value + * enum label (index into PL_op_private_labels[]) + * -1 + */ + +EXTCONST I16 PL_op_private_bitfields[] = { + 0, 8, -1, + 0, 8, -1, + 0, 8, -1, + 0, 8, -1, + 0, 8, -1, + 0, 8, -1, + 5, -1, 1, 124, 2, 131, 3, 138, -1, + +}; + + +/* PL_op_private_bitdef_ix[]: map an op number to a starting position + * in PL_op_private_bitdefs. If -1, the op has no bits defined */ + +EXTCONST I16 PL_op_private_bitdef_ix[] = { + -1, /* null */ + -1, /* stub */ + 0, /* scalar */ + 1, /* pushmark */ + 3, /* wantarray */ + 4, /* const */ + 9, /* gvsv */ + 11, /* gv */ + 12, /* gelem */ + 13, /* padsv */ + 16, /* padav */ + 20, /* padhv */ + -1, /* padany */ + 26, /* pushre */ + 27, /* rv2gv */ + 34, /* rv2sv */ + 39, /* av2arylen */ + 41, /* rv2cv */ + -1, /* anoncode */ + 48, /* prototype */ + 49, /* refgen */ + 50, /* srefgen */ + 51, /* ref */ + 52, /* bless */ + 53, /* backtick */ + 58, /* glob */ + 59, /* readline */ + -1, /* rcatline */ + 60, /* regcmaybe */ + 61, /* regcreset */ + 62, /* regcomp */ + 63, /* match */ + 65, /* qr */ + 66, /* subst */ + 68, /* substcont */ + 70, /* trans */ + 78, /* transr */ + 86, /* sassign */ + 89, /* aassign */ + 92, /* chop */ + 93, /* schop */ + 94, /* chomp */ + 96, /* schomp */ + 98, /* defined */ + 99, /* undef */ + 100, /* study */ + 101, /* pos */ + 104, /* preinc */ + 105, /* i_preinc */ + 106, /* predec */ + 107, /* i_predec */ + 108, /* postinc */ + 109, /* i_postinc */ + 111, /* postdec */ + 112, /* i_postdec */ + 114, /* pow */ + 116, /* multiply */ + 118, /* i_multiply */ + 120, /* divide */ + 122, /* i_divide */ + 124, /* modulo */ + 126, /* i_modulo */ + 128, /* repeat */ + 130, /* add */ + 132, /* i_add */ + 134, /* subtract */ + 136, /* i_subtract */ + 138, /* concat */ + 140, /* stringify */ + 142, /* left_shift */ + 144, /* right_shift */ + 146, /* lt */ + 147, /* i_lt */ + 148, /* gt */ + 149, /* i_gt */ + 150, /* le */ + 151, /* i_le */ + 152, /* ge */ + 153, /* i_ge */ + 154, /* eq */ + 155, /* i_eq */ + 156, /* ne */ + 157, /* i_ne */ + 158, /* ncmp */ + 159, /* i_ncmp */ + 160, /* slt */ + 161, /* sgt */ + 162, /* sle */ + 163, /* sge */ + 164, /* seq */ + 165, /* sne */ + 166, /* scmp */ + 167, /* bit_and */ + 168, /* bit_xor */ + 169, /* bit_or */ + 170, /* negate */ + 171, /* i_negate */ + 173, /* not */ + 174, /* complement */ + 175, /* smartmatch */ + 176, /* atan2 */ + 178, /* sin */ + 180, /* cos */ + 182, /* rand */ + 184, /* srand */ + 186, /* exp */ + 188, /* log */ + 190, /* sqrt */ + 192, /* int */ + 194, /* hex */ + 196, /* oct */ + 198, /* abs */ + 200, /* length */ + 202, /* substr */ + 206, /* vec */ + 209, /* index */ + 211, /* rindex */ + 213, /* sprintf */ + 214, /* formline */ + 215, /* ord */ + 217, /* chr */ + 219, /* crypt */ + 221, /* ucfirst */ + 222, /* lcfirst */ + 223, /* uc */ + 224, /* lc */ + 225, /* quotemeta */ + 226, /* rv2av */ + 232, /* aelemfast */ + 233, /* aelemfast_lex */ + 234, /* aelem */ + 239, /* aslice */ + 242, /* kvaslice */ + 243, /* aeach */ + 244, /* akeys */ + 245, /* avalues */ + 246, /* each */ + 247, /* values */ + 248, /* keys */ + 250, /* delete */ + 253, /* exists */ + 255, /* rv2hv */ + 263, /* helem */ + 268, /* hslice */ + 271, /* kvhslice */ + 272, /* unpack */ + 273, /* pack */ + 274, /* split */ + 275, /* join */ + 276, /* list */ + 278, /* lslice */ + 279, /* anonlist */ + 280, /* anonhash */ + 281, /* splice */ + 282, /* push */ + 284, /* pop */ + 285, /* shift */ + 286, /* unshift */ + 288, /* sort */ + 295, /* reverse */ + 297, /* grepstart */ + 298, /* grepwhile */ + 300, /* mapstart */ + 301, /* mapwhile */ + 303, /* range */ + 304, /* flip */ + 306, /* flop */ + 308, /* and */ + 309, /* or */ + 310, /* xor */ + 311, /* dor */ + 312, /* cond_expr */ + 314, /* andassign */ + 315, /* orassign */ + 316, /* dorassign */ + 317, /* method */ + 318, /* entersub */ + 325, /* leavesub */ + 327, /* leavesublv */ + 329, /* caller */ + 331, /* warn */ + 332, /* die */ + 333, /* reset */ + -1, /* lineseq */ + 334, /* nextstate */ + 337, /* dbstate */ + -1, /* unstack */ + -1, /* enter */ + 340, /* leave */ + -1, /* scope */ + 342, /* enteriter */ + 346, /* iter */ + -1, /* enterloop */ + 347, /* leaveloop */ + -1, /* return */ + 349, /* last */ + 351, /* next */ + 353, /* redo */ + 355, /* dump */ + 357, /* goto */ + 359, /* exit */ + -1, /* method_named */ + 360, /* entergiven */ + 361, /* leavegiven */ + 362, /* enterwhen */ + 363, /* leavewhen */ + -1, /* break */ + -1, /* continue */ + 364, /* open */ + 369, /* close */ + 370, /* pipe_op */ + 371, /* fileno */ + 372, /* umask */ + 373, /* binmode */ + 374, /* tie */ + 375, /* untie */ + 376, /* tied */ + 377, /* dbmopen */ + 378, /* dbmclose */ + 379, /* sselect */ + 380, /* select */ + 381, /* getc */ + 382, /* read */ + 383, /* enterwrite */ + 384, /* leavewrite */ + -1, /* prtf */ + -1, /* print */ + -1, /* say */ + 386, /* sysopen */ + 387, /* sysseek */ + 388, /* sysread */ + 389, /* syswrite */ + 390, /* eof */ + 391, /* tell */ + 392, /* seek */ + 393, /* truncate */ + 394, /* fcntl */ + 395, /* ioctl */ + 396, /* flock */ + 398, /* send */ + 399, /* recv */ + 400, /* socket */ + 401, /* sockpair */ + 402, /* bind */ + 403, /* connect */ + 404, /* listen */ + 405, /* accept */ + 406, /* shutdown */ + 407, /* gsockopt */ + 408, /* ssockopt */ + 409, /* getsockname */ + 410, /* getpeername */ + 411, /* lstat */ + 412, /* stat */ + 413, /* ftrread */ + 418, /* ftrwrite */ + 423, /* ftrexec */ + 428, /* fteread */ + 433, /* ftewrite */ + 438, /* fteexec */ + 443, /* ftis */ + 447, /* ftsize */ + 451, /* ftmtime */ + 455, /* ftatime */ + 459, /* ftctime */ + 463, /* ftrowned */ + 467, /* fteowned */ + 471, /* ftzero */ + 475, /* ftsock */ + 479, /* ftchr */ + 483, /* ftblk */ + 487, /* ftfile */ + 491, /* ftdir */ + 495, /* ftpipe */ + 499, /* ftsuid */ + 503, /* ftsgid */ + 507, /* ftsvtx */ + 511, /* ftlink */ + 515, /* fttty */ + 519, /* fttext */ + 523, /* ftbinary */ + 527, /* chdir */ + 529, /* chown */ + 531, /* chroot */ + 533, /* unlink */ + 535, /* chmod */ + 537, /* utime */ + 539, /* rename */ + 541, /* link */ + 543, /* symlink */ + 545, /* readlink */ + 546, /* mkdir */ + 548, /* rmdir */ + 550, /* open_dir */ + 551, /* readdir */ + 552, /* telldir */ + 553, /* seekdir */ + 554, /* rewinddir */ + 555, /* closedir */ + -1, /* fork */ + 556, /* wait */ + 557, /* waitpid */ + 559, /* system */ + 561, /* exec */ + 563, /* kill */ + 565, /* getppid */ + 566, /* getpgrp */ + 568, /* setpgrp */ + 570, /* getpriority */ + 572, /* setpriority */ + 574, /* time */ + -1, /* tms */ + 575, /* localtime */ + 576, /* gmtime */ + 577, /* alarm */ + 578, /* sleep */ + 580, /* shmget */ + 581, /* shmctl */ + 582, /* shmread */ + 583, /* shmwrite */ + 584, /* msgget */ + 585, /* msgctl */ + 586, /* msgsnd */ + 587, /* msgrcv */ + 588, /* semop */ + 589, /* semget */ + 590, /* semctl */ + 591, /* require */ + 592, /* dofile */ + -1, /* hintseval */ + 593, /* entereval */ + 599, /* leaveeval */ + 601, /* entertry */ + -1, /* leavetry */ + 602, /* ghbyname */ + 603, /* ghbyaddr */ + -1, /* ghostent */ + 604, /* gnbyname */ + 605, /* gnbyaddr */ + -1, /* gnetent */ + 606, /* gpbyname */ + 607, /* gpbynumber */ + -1, /* gprotoent */ + 608, /* gsbyname */ + 609, /* gsbyport */ + -1, /* gservent */ + 610, /* shostent */ + 611, /* snetent */ + 612, /* sprotoent */ + 613, /* sservent */ + -1, /* ehostent */ + -1, /* enetent */ + -1, /* eprotoent */ + -1, /* eservent */ + 614, /* gpwnam */ + 615, /* gpwuid */ + -1, /* gpwent */ + -1, /* spwent */ + -1, /* epwent */ + 616, /* ggrnam */ + 617, /* ggrgid */ + -1, /* ggrent */ + -1, /* sgrent */ + -1, /* egrent */ + -1, /* getlogin */ + 618, /* syscall */ + 619, /* lock */ + 620, /* once */ + -1, /* custom */ + 621, /* reach */ + 622, /* rkeys */ + 624, /* rvalues */ + 625, /* coreargs */ + 629, /* runcv */ + 630, /* fc */ + -1, /* padcv */ + -1, /* introcv */ + -1, /* clonecv */ + 631, /* padrange */ + +}; + + + +/* PL_op_private_bitdefs[]: given a starting position in this array (as + * supplied by PL_op_private_bitdef_ix[]), each word (until a stop bit is + * seen) defines the meaning of a particular op_private bit for a + * particular op. Each word consists of: + * bit 0: stop bit: this is the last bit def for the current op + * bit 1: bitfield: if set, this defines a bit field rather than a flag + * bits 2..4: unsigned number in the range 0..7 which is the bit number + * bits 5..15: unsigned number in the range 0..2047 which is an index + * into PL_op_private_labels[] (for a flag), or + * into PL_op_private_bitfields[] (for a bit field) + */ + +EXTCONST U16 PL_op_private_bitdefs[] = { + /* scalar */ 0x0003, + /* pushmark */ 0x25bc, 0x37b1, + /* wantarray */ 0x00bd, + /* const */ 0x0358, 0x1330, 0x386c, 0x3328, 0x2985, + /* gvsv */ 0x25bc, 0x2ad1, + /* gv */ 0x1235, + /* gelem */ 0x0067, + /* padsv */ 0x25bc, 0x025a, 0x37b1, + /* padav */ 0x25bc, 0x37b0, 0x26ac, 0x34a9, + /* padhv */ 0x25bc, 0x0578, 0x04d4, 0x37b0, 0x26ac, 0x34a9, + /* pushre */ 0x3279, + /* rv2gv */ 0x25bc, 0x025a, 0x1430, 0x26ac, 0x28a8, 0x3864, 0x0003, + /* rv2sv */ 0x25bc, 0x025a, 0x2ad0, 0x3864, 0x0003, + /* av2arylen */ 0x26ac, 0x0003, + /* rv2cv */ 0x281c, 0x0898, 0x0ad0, 0x028c, 0x39c8, 0x3864, 0x0003, + /* prototype */ 0x0003, + /* refgen */ 0x0003, + /* srefgen */ 0x0003, + /* ref */ 0x0003, + /* bless */ 0x012f, + /* backtick */ 0x2cbc, 0x2bd8, 0x2134, 0x2070, 0x0003, + /* glob */ 0x012f, + /* readline */ 0x0003, + /* regcmaybe */ 0x0003, + /* regcreset */ 0x0003, + /* regcomp */ 0x0003, + /* match */ 0x3278, 0x3a71, + /* qr */ 0x3279, + /* subst */ 0x3278, 0x3a71, + /* substcont */ 0x3278, 0x0003, + /* trans */ 0x0bdc, 0x1ab8, 0x07d4, 0x3a70, 0x35ec, 0x1de8, 0x01e4, 0x0141, + /* transr */ 0x0bdc, 0x1ab8, 0x07d4, 0x3a70, 0x35ec, 0x1de8, 0x01e4, 0x0141, + /* sassign */ 0x0a1c, 0x03f8, 0x0067, + /* aassign */ 0x06f8, 0x26ac, 0x0067, + /* chop */ 0x0003, + /* schop */ 0x0003, + /* chomp */ 0x3a70, 0x0003, + /* schomp */ 0x3a70, 0x0003, + /* defined */ 0x0003, + /* undef */ 0x0003, + /* study */ 0x0003, + /* pos */ 0x25bc, 0x26ac, 0x0003, + /* preinc */ 0x0003, + /* i_preinc */ 0x0003, + /* predec */ 0x0003, + /* i_predec */ 0x0003, + /* postinc */ 0x0003, + /* i_postinc */ 0x3a70, 0x0003, + /* postdec */ 0x0003, + /* i_postdec */ 0x3a70, 0x0003, + /* pow */ 0x3a70, 0x0067, + /* multiply */ 0x3a70, 0x0067, + /* i_multiply */ 0x3a70, 0x0067, + /* divide */ 0x3a70, 0x0067, + /* i_divide */ 0x3a70, 0x0067, + /* modulo */ 0x3a70, 0x0067, + /* i_modulo */ 0x3a70, 0x0067, + /* repeat */ 0x0eb8, 0x0067, + /* add */ 0x3a70, 0x0067, + /* i_add */ 0x3a70, 0x0067, + /* subtract */ 0x3a70, 0x0067, + /* i_subtract */ 0x3a70, 0x0067, + /* concat */ 0x3a70, 0x0067, + /* stringify */ 0x3a70, 0x012f, + /* left_shift */ 0x3a70, 0x0067, + /* right_shift */ 0x3a70, 0x0067, + /* lt */ 0x0067, + /* i_lt */ 0x0067, + /* gt */ 0x0067, + /* i_gt */ 0x0067, + /* le */ 0x0067, + /* i_le */ 0x0067, + /* ge */ 0x0067, + /* i_ge */ 0x0067, + /* eq */ 0x0067, + /* i_eq */ 0x0067, + /* ne */ 0x0067, + /* i_ne */ 0x0067, + /* ncmp */ 0x0067, + /* i_ncmp */ 0x0067, + /* slt */ 0x0067, + /* sgt */ 0x0067, + /* sle */ 0x0067, + /* sge */ 0x0067, + /* seq */ 0x0067, + /* sne */ 0x0067, + /* scmp */ 0x0067, + /* bit_and */ 0x0067, + /* bit_xor */ 0x0067, + /* bit_or */ 0x0067, + /* negate */ 0x0003, + /* i_negate */ 0x3a70, 0x0003, + /* not */ 0x0003, + /* complement */ 0x0003, + /* smartmatch */ 0x0067, + /* atan2 */ 0x3a70, 0x012f, + /* sin */ 0x3a70, 0x0003, + /* cos */ 0x3a70, 0x0003, + /* rand */ 0x3a70, 0x012f, + /* srand */ 0x3a70, 0x012f, + /* exp */ 0x3a70, 0x0003, + /* log */ 0x3a70, 0x0003, + /* sqrt */ 0x3a70, 0x0003, + /* int */ 0x3a70, 0x0003, + /* hex */ 0x3a70, 0x0003, + /* oct */ 0x3a70, 0x0003, + /* abs */ 0x3a70, 0x0003, + /* length */ 0x3a70, 0x0003, + /* substr */ 0x25bc, 0x2fd0, 0x26ac, 0x00cb, + /* vec */ 0x25bc, 0x26ac, 0x0067, + /* index */ 0x3a70, 0x012f, + /* rindex */ 0x3a70, 0x012f, + /* sprintf */ 0x012f, + /* formline */ 0x012f, + /* ord */ 0x3a70, 0x0003, + /* chr */ 0x3a70, 0x0003, + /* crypt */ 0x3a70, 0x012f, + /* ucfirst */ 0x0003, + /* lcfirst */ 0x0003, + /* uc */ 0x0003, + /* lc */ 0x0003, + /* quotemeta */ 0x0003, + /* rv2av */ 0x25bc, 0x2ad0, 0x26ac, 0x34a8, 0x3864, 0x0003, + /* aelemfast */ 0x01ff, + /* aelemfast_lex */ 0x01ff, + /* aelem */ 0x25bc, 0x025a, 0x24b0, 0x26ac, 0x0067, + /* aslice */ 0x25bc, 0x26ac, 0x34a9, + /* kvaslice */ 0x26ad, + /* aeach */ 0x0003, + /* akeys */ 0x0003, + /* avalues */ 0x0003, + /* each */ 0x0003, + /* values */ 0x0003, + /* keys */ 0x26ac, 0x0003, + /* delete */ 0x25bc, 0x33f8, 0x0003, + /* exists */ 0x3958, 0x0003, + /* rv2hv */ 0x25bc, 0x0578, 0x04d4, 0x2ad0, 0x26ac, 0x34a8, 0x3864, 0x0003, + /* helem */ 0x25bc, 0x025a, 0x24b0, 0x26ac, 0x0067, + /* hslice */ 0x25bc, 0x26ac, 0x34a9, + /* kvhslice */ 0x26ad, + /* unpack */ 0x012f, + /* pack */ 0x012f, + /* split */ 0x1ebd, + /* join */ 0x012f, + /* list */ 0x25bc, 0x1b79, + /* lslice */ 0x0067, + /* anonlist */ 0x012f, + /* anonhash */ 0x012f, + /* splice */ 0x012f, + /* push */ 0x3a70, 0x012f, + /* pop */ 0x0003, + /* shift */ 0x0003, + /* unshift */ 0x3a70, 0x012f, + /* sort */ 0x36d8, 0x2d74, 0x0e10, 0x21cc, 0x30c8, 0x22c4, 0x2a41, + /* reverse */ 0x21cc, 0x0003, + /* grepstart */ 0x19a5, + /* grepwhile */ 0x19a4, 0x0003, + /* mapstart */ 0x19a5, + /* mapwhile */ 0x19a4, 0x0003, + /* range */ 0x0003, + /* flip */ 0x2358, 0x0003, + /* flop */ 0x2358, 0x0003, + /* and */ 0x0003, + /* or */ 0x0003, + /* xor */ 0x0067, + /* dor */ 0x0003, + /* cond_expr */ 0x25bc, 0x0003, + /* andassign */ 0x0003, + /* orassign */ 0x0003, + /* dorassign */ 0x0003, + /* method */ 0x0003, + /* entersub */ 0x25bc, 0x025a, 0x0ad0, 0x028c, 0x39c8, 0x3864, 0x1f81, + /* leavesub */ 0x2e38, 0x0003, + /* leavesublv */ 0x2e38, 0x0003, + /* caller */ 0x00bc, 0x012f, + /* warn */ 0x012f, + /* die */ 0x012f, + /* reset */ 0x012f, + /* nextstate */ 0x3e1c, 0x3c58, 0x1d55, + /* dbstate */ 0x3e1c, 0x3c58, 0x1d55, + /* leave */ 0x245c, 0x2e39, + /* enteriter */ 0x25bc, 0x2ad0, 0x0b4c, 0x3149, + /* iter */ 0x3149, + /* leaveloop */ 0x245c, 0x0067, + /* last */ 0x3bdc, 0x0003, + /* next */ 0x3bdc, 0x0003, + /* redo */ 0x3bdc, 0x0003, + /* dump */ 0x3bdc, 0x0003, + /* goto */ 0x3bdc, 0x0003, + /* exit */ 0x012f, + /* entergiven */ 0x0003, + /* leavegiven */ 0x0003, + /* enterwhen */ 0x0003, + /* leavewhen */ 0x0003, + /* open */ 0x2cbc, 0x2bd8, 0x2134, 0x2070, 0x012f, + /* close */ 0x012f, + /* pipe_op */ 0x012f, + /* fileno */ 0x012f, + /* umask */ 0x012f, + /* binmode */ 0x012f, + /* tie */ 0x012f, + /* untie */ 0x0003, + /* tied */ 0x0003, + /* dbmopen */ 0x012f, + /* dbmclose */ 0x0003, + /* sselect */ 0x012f, + /* select */ 0x012f, + /* getc */ 0x012f, + /* read */ 0x012f, + /* enterwrite */ 0x012f, + /* leavewrite */ 0x2e38, 0x0003, + /* sysopen */ 0x012f, + /* sysseek */ 0x012f, + /* sysread */ 0x012f, + /* syswrite */ 0x012f, + /* eof */ 0x012f, + /* tell */ 0x012f, + /* seek */ 0x012f, + /* truncate */ 0x012f, + /* fcntl */ 0x012f, + /* ioctl */ 0x012f, + /* flock */ 0x3a70, 0x012f, + /* send */ 0x012f, + /* recv */ 0x012f, + /* socket */ 0x012f, + /* sockpair */ 0x012f, + /* bind */ 0x012f, + /* connect */ 0x012f, + /* listen */ 0x012f, + /* accept */ 0x012f, + /* shutdown */ 0x012f, + /* gsockopt */ 0x012f, + /* ssockopt */ 0x012f, + /* getsockname */ 0x0003, + /* getpeername */ 0x0003, + /* lstat */ 0x0003, + /* stat */ 0x0003, + /* ftrread */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* ftrwrite */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* ftrexec */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* fteread */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* ftewrite */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* fteexec */ 0x15f0, 0x184c, 0x1708, 0x14c4, 0x0003, + /* ftis */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftsize */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftmtime */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftatime */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftctime */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftrowned */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* fteowned */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftzero */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftsock */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftchr */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftblk */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftfile */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftdir */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftpipe */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftsuid */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftsgid */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftsvtx */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftlink */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* fttty */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* fttext */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* ftbinary */ 0x15f0, 0x184c, 0x1708, 0x0003, + /* chdir */ 0x3a70, 0x012f, + /* chown */ 0x3a70, 0x012f, + /* chroot */ 0x3a70, 0x0003, + /* unlink */ 0x3a70, 0x012f, + /* chmod */ 0x3a70, 0x012f, + /* utime */ 0x3a70, 0x012f, + /* rename */ 0x3a70, 0x012f, + /* link */ 0x3a70, 0x012f, + /* symlink */ 0x3a70, 0x012f, + /* readlink */ 0x0003, + /* mkdir */ 0x3a70, 0x012f, + /* rmdir */ 0x3a70, 0x0003, + /* open_dir */ 0x012f, + /* readdir */ 0x0003, + /* telldir */ 0x0003, + /* seekdir */ 0x012f, + /* rewinddir */ 0x0003, + /* closedir */ 0x0003, + /* wait */ 0x3a71, + /* waitpid */ 0x3a70, 0x012f, + /* system */ 0x3a70, 0x012f, + /* exec */ 0x3a70, 0x012f, + /* kill */ 0x3a70, 0x012f, + /* getppid */ 0x3a71, + /* getpgrp */ 0x3a70, 0x012f, + /* setpgrp */ 0x3a70, 0x012f, + /* getpriority */ 0x3a70, 0x012f, + /* setpriority */ 0x3a70, 0x012f, + /* time */ 0x3a71, + /* localtime */ 0x0003, + /* gmtime */ 0x012f, + /* alarm */ 0x0003, + /* sleep */ 0x3a70, 0x012f, + /* shmget */ 0x012f, + /* shmctl */ 0x012f, + /* shmread */ 0x012f, + /* shmwrite */ 0x012f, + /* msgget */ 0x012f, + /* msgctl */ 0x012f, + /* msgsnd */ 0x012f, + /* msgrcv */ 0x012f, + /* semop */ 0x012f, + /* semget */ 0x012f, + /* semctl */ 0x012f, + /* require */ 0x0003, + /* dofile */ 0x0003, + /* entereval */ 0x2ed4, 0x0950, 0x062c, 0x3b48, 0x1c64, 0x0003, + /* leaveeval */ 0x2e38, 0x0003, + /* entertry */ 0x0003, + /* ghbyname */ 0x0003, + /* ghbyaddr */ 0x012f, + /* gnbyname */ 0x0003, + /* gnbyaddr */ 0x012f, + /* gpbyname */ 0x0003, + /* gpbynumber */ 0x012f, + /* gsbyname */ 0x012f, + /* gsbyport */ 0x012f, + /* shostent */ 0x0003, + /* snetent */ 0x0003, + /* sprotoent */ 0x0003, + /* sservent */ 0x0003, + /* gpwnam */ 0x0003, + /* gpwuid */ 0x0003, + /* ggrnam */ 0x0003, + /* ggrgid */ 0x0003, + /* syscall */ 0x012f, + /* lock */ 0x0003, + /* once */ 0x0003, + /* reach */ 0x0003, + /* rkeys */ 0x26ac, 0x0003, + /* rvalues */ 0x0003, + /* coreargs */ 0x277c, 0x0018, 0x0d24, 0x0c41, + /* runcv */ 0x00bd, + /* fc */ 0x0003, + /* padrange */ 0x25bc, 0x019b, + +}; + + +/* PL_op_private_valid: for each op, indexed by op_type, indicate which + * flags bits in op_private are legal */ + +EXTCONST U8 PL_op_private_valid[] = { + /* NULL */ (0xff), + /* STUB */ (0), + /* SCALAR */ (OPpARG1_MASK), + /* PUSHMARK */ (OPpPAD_STATE|OPpLVAL_INTRO), + /* WANTARRAY */ (OPpOFFBYONE), + /* CONST */ (OPpCONST_NOVER|OPpCONST_SHORTCIRCUIT|OPpCONST_STRICT|OPpCONST_ENTERED|OPpCONST_BARE), + /* GVSV */ (OPpOUR_INTRO|OPpLVAL_INTRO), + /* GV */ (OPpEARLY_CV), + /* GELEM */ (OPpARG2_MASK), + /* PADSV */ (OPpPAD_STATE|OPpDEREF|OPpLVAL_INTRO), + /* PADAV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpLVAL_INTRO), + /* PADHV */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpPAD_STATE|OPpTRUEBOOL|OPpMAYBE_TRUEBOOL|OPpLVAL_INTRO), + /* PADANY */ (0), + /* PUSHRE */ (OPpRUNTIME), + /* RV2GV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpDONT_INIT_GV|OPpMAYBE_LVSUB|OPpALLOW_FAKE|OPpDEREF|OPpLVAL_INTRO), + /* RV2SV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpOUR_INTRO|OPpDEREF|OPpLVAL_INTRO), + /* AV2ARYLEN */ (OPpARG1_MASK|OPpMAYBE_LVSUB), + /* RV2CV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpENTERSUB_DB|OPpMAY_RETURN_CONSTANT|OPpENTERSUB_NOPAREN), + /* ANONCODE */ (0), + /* PROTOTYPE */ (OPpARG1_MASK), + /* REFGEN */ (OPpARG1_MASK), + /* SREFGEN */ (OPpARG1_MASK), + /* REF */ (OPpARG1_MASK), + /* BLESS */ (OPpARG4_MASK), + /* BACKTICK */ (OPpARG1_MASK|OPpOPEN_IN_RAW|OPpOPEN_IN_CRLF|OPpOPEN_OUT_RAW|OPpOPEN_OUT_CRLF), + /* GLOB */ (OPpARG4_MASK), + /* READLINE */ (OPpARG1_MASK), + /* RCATLINE */ (0), + /* REGCMAYBE */ (OPpARG1_MASK), + /* REGCRESET */ (OPpARG1_MASK), + /* REGCOMP */ (OPpARG1_MASK), + /* MATCH */ (OPpTARGET_MY|OPpRUNTIME), + /* QR */ (OPpRUNTIME), + /* SUBST */ (OPpTARGET_MY|OPpRUNTIME), + /* SUBSTCONT */ (OPpARG1_MASK|OPpRUNTIME), + /* TRANS */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), + /* TRANSR */ (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTARGET_MY|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE), + /* SASSIGN */ (OPpARG2_MASK|OPpASSIGN_BACKWARDS|OPpASSIGN_CV_TO_GV), + /* AASSIGN */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpASSIGN_COMMON), + /* CHOP */ (OPpARG1_MASK), + /* SCHOP */ (OPpARG1_MASK), + /* CHOMP */ (OPpARG1_MASK|OPpTARGET_MY), + /* SCHOMP */ (OPpARG1_MASK|OPpTARGET_MY), + /* DEFINED */ (OPpARG1_MASK), + /* UNDEF */ (OPpARG1_MASK), + /* STUDY */ (OPpARG1_MASK), + /* POS */ (OPpARG1_MASK|OPpMAYBE_LVSUB|OPpLVAL_INTRO), + /* PREINC */ (OPpARG1_MASK), + /* I_PREINC */ (OPpARG1_MASK), + /* PREDEC */ (OPpARG1_MASK), + /* I_PREDEC */ (OPpARG1_MASK), + /* POSTINC */ (OPpARG1_MASK), + /* I_POSTINC */ (OPpARG1_MASK|OPpTARGET_MY), + /* POSTDEC */ (OPpARG1_MASK), + /* I_POSTDEC */ (OPpARG1_MASK|OPpTARGET_MY), + /* POW */ (OPpARG2_MASK|OPpTARGET_MY), + /* MULTIPLY */ (OPpARG2_MASK|OPpTARGET_MY), + /* I_MULTIPLY */ (OPpARG2_MASK|OPpTARGET_MY), + /* DIVIDE */ (OPpARG2_MASK|OPpTARGET_MY), + /* I_DIVIDE */ (OPpARG2_MASK|OPpTARGET_MY), + /* MODULO */ (OPpARG2_MASK|OPpTARGET_MY), + /* I_MODULO */ (OPpARG2_MASK|OPpTARGET_MY), + /* REPEAT */ (OPpARG2_MASK|OPpREPEAT_DOLIST), + /* ADD */ (OPpARG2_MASK|OPpTARGET_MY), + /* I_ADD */ (OPpARG2_MASK|OPpTARGET_MY), + /* SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY), + /* I_SUBTRACT */ (OPpARG2_MASK|OPpTARGET_MY), + /* CONCAT */ (OPpARG2_MASK|OPpTARGET_MY), + /* STRINGIFY */ (OPpARG4_MASK|OPpTARGET_MY), + /* LEFT_SHIFT */ (OPpARG2_MASK|OPpTARGET_MY), + /* RIGHT_SHIFT */ (OPpARG2_MASK|OPpTARGET_MY), + /* LT */ (OPpARG2_MASK), + /* I_LT */ (OPpARG2_MASK), + /* GT */ (OPpARG2_MASK), + /* I_GT */ (OPpARG2_MASK), + /* LE */ (OPpARG2_MASK), + /* I_LE */ (OPpARG2_MASK), + /* GE */ (OPpARG2_MASK), + /* I_GE */ (OPpARG2_MASK), + /* EQ */ (OPpARG2_MASK), + /* I_EQ */ (OPpARG2_MASK), + /* NE */ (OPpARG2_MASK), + /* I_NE */ (OPpARG2_MASK), + /* NCMP */ (OPpARG2_MASK), + /* I_NCMP */ (OPpARG2_MASK), + /* SLT */ (OPpARG2_MASK), + /* SGT */ (OPpARG2_MASK), + /* SLE */ (OPpARG2_MASK), + /* SGE */ (OPpARG2_MASK), + /* SEQ */ (OPpARG2_MASK), + /* SNE */ (OPpARG2_MASK), + /* SCMP */ (OPpARG2_MASK), + /* BIT_AND */ (OPpARG2_MASK), + /* BIT_XOR */ (OPpARG2_MASK), + /* BIT_OR */ (OPpARG2_MASK), + /* NEGATE */ (OPpARG1_MASK), + /* I_NEGATE */ (OPpARG1_MASK|OPpTARGET_MY), + /* NOT */ (OPpARG1_MASK), + /* COMPLEMENT */ (OPpARG1_MASK), + /* SMARTMATCH */ (OPpARG2_MASK), + /* ATAN2 */ (OPpARG4_MASK|OPpTARGET_MY), + /* SIN */ (OPpARG1_MASK|OPpTARGET_MY), + /* COS */ (OPpARG1_MASK|OPpTARGET_MY), + /* RAND */ (OPpARG4_MASK|OPpTARGET_MY), + /* SRAND */ (OPpARG4_MASK|OPpTARGET_MY), + /* EXP */ (OPpARG1_MASK|OPpTARGET_MY), + /* LOG */ (OPpARG1_MASK|OPpTARGET_MY), + /* SQRT */ (OPpARG1_MASK|OPpTARGET_MY), + /* INT */ (OPpARG1_MASK|OPpTARGET_MY), + /* HEX */ (OPpARG1_MASK|OPpTARGET_MY), + /* OCT */ (OPpARG1_MASK|OPpTARGET_MY), + /* ABS */ (OPpARG1_MASK|OPpTARGET_MY), + /* LENGTH */ (OPpARG1_MASK|OPpTARGET_MY), + /* SUBSTR */ (OPpARG3_MASK|OPpMAYBE_LVSUB|OPpSUBSTR_REPL_FIRST|OPpLVAL_INTRO), + /* VEC */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_INTRO), + /* INDEX */ (OPpARG4_MASK|OPpTARGET_MY), + /* RINDEX */ (OPpARG4_MASK|OPpTARGET_MY), + /* SPRINTF */ (OPpARG4_MASK), + /* FORMLINE */ (OPpARG4_MASK), + /* ORD */ (OPpARG1_MASK|OPpTARGET_MY), + /* CHR */ (OPpARG1_MASK|OPpTARGET_MY), + /* CRYPT */ (OPpARG4_MASK|OPpTARGET_MY), + /* UCFIRST */ (OPpARG1_MASK), + /* LCFIRST */ (OPpARG1_MASK), + /* UC */ (OPpARG1_MASK), + /* LC */ (OPpARG1_MASK), + /* QUOTEMETA */ (OPpARG1_MASK), + /* RV2AV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpOUR_INTRO|OPpLVAL_INTRO), + /* AELEMFAST */ (255), + /* AELEMFAST_LEX */ (255), + /* AELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO), + /* ASLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO), + /* KVASLICE */ (OPpMAYBE_LVSUB), + /* AEACH */ (OPpARG1_MASK), + /* AKEYS */ (OPpARG1_MASK), + /* AVALUES */ (OPpARG1_MASK), + /* EACH */ (OPpARG1_MASK), + /* VALUES */ (OPpARG1_MASK), + /* KEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB), + /* DELETE */ (OPpARG1_MASK|OPpSLICE|OPpLVAL_INTRO), + /* EXISTS */ (OPpARG1_MASK|OPpEXISTS_SUB), + /* RV2HV */ (OPpARG1_MASK|OPpHINT_STRICT_REFS|OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpOUR_INTRO|OPpTRUEBOOL|OPpMAYBE_TRUEBOOL|OPpLVAL_INTRO), + /* HELEM */ (OPpARG2_MASK|OPpMAYBE_LVSUB|OPpLVAL_DEFER|OPpDEREF|OPpLVAL_INTRO), + /* HSLICE */ (OPpSLICEWARNING|OPpMAYBE_LVSUB|OPpLVAL_INTRO), + /* KVHSLICE */ (OPpMAYBE_LVSUB), + /* UNPACK */ (OPpARG4_MASK), + /* PACK */ (OPpARG4_MASK), + /* SPLIT */ (OPpSPLIT_IMPLIM), + /* JOIN */ (OPpARG4_MASK), + /* LIST */ (OPpLIST_GUESSED|OPpLVAL_INTRO), + /* LSLICE */ (OPpARG2_MASK), + /* ANONLIST */ (OPpARG4_MASK), + /* ANONHASH */ (OPpARG4_MASK), + /* SPLICE */ (OPpARG4_MASK), + /* PUSH */ (OPpARG4_MASK|OPpTARGET_MY), + /* POP */ (OPpARG1_MASK), + /* SHIFT */ (OPpARG1_MASK), + /* UNSHIFT */ (OPpARG4_MASK|OPpTARGET_MY), + /* SORT */ (OPpSORT_NUMERIC|OPpSORT_INTEGER|OPpSORT_REVERSE|OPpSORT_INPLACE|OPpSORT_DESCEND|OPpSORT_QSORT|OPpSORT_STABLE), + /* REVERSE */ (OPpARG1_MASK|OPpREVERSE_INPLACE), + /* GREPSTART */ (OPpGREP_LEX), + /* GREPWHILE */ (OPpARG1_MASK|OPpGREP_LEX), + /* MAPSTART */ (OPpGREP_LEX), + /* MAPWHILE */ (OPpARG1_MASK|OPpGREP_LEX), + /* RANGE */ (OPpARG1_MASK), + /* FLIP */ (OPpARG1_MASK|OPpFLIP_LINENUM), + /* FLOP */ (OPpARG1_MASK|OPpFLIP_LINENUM), + /* AND */ (OPpARG1_MASK), + /* OR */ (OPpARG1_MASK), + /* XOR */ (OPpARG2_MASK), + /* DOR */ (OPpARG1_MASK), + /* COND_EXPR */ (OPpARG1_MASK|OPpLVAL_INTRO), + /* ANDASSIGN */ (OPpARG1_MASK), + /* ORASSIGN */ (OPpARG1_MASK), + /* DORASSIGN */ (OPpARG1_MASK), + /* METHOD */ (OPpARG1_MASK), + /* ENTERSUB */ (OPpENTERSUB_INARGS|OPpHINT_STRICT_REFS|OPpENTERSUB_HASTARG|OPpENTERSUB_AMPER|OPpENTERSUB_DB|OPpDEREF|OPpLVAL_INTRO), + /* LEAVESUB */ (OPpARG1_MASK|OPpREFCOUNTED), + /* LEAVESUBLV */ (OPpARG1_MASK|OPpREFCOUNTED), + /* CALLER */ (OPpARG4_MASK|OPpOFFBYONE), + /* WARN */ (OPpARG4_MASK), + /* DIE */ (OPpARG4_MASK), + /* RESET */ (OPpARG4_MASK), + /* LINESEQ */ (0), + /* NEXTSTATE */ (OPpHUSH_VMSISH|OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME), + /* DBSTATE */ (OPpHUSH_VMSISH|OPpHINT_M_VMSISH_STATUS|OPpHINT_M_VMSISH_TIME), + /* UNSTACK */ (0), + /* ENTER */ (0), + /* LEAVE */ (OPpREFCOUNTED|OPpLVALUE), + /* SCOPE */ (0), + /* ENTERITER */ (OPpITER_REVERSED|OPpITER_DEF|OPpOUR_INTRO|OPpLVAL_INTRO), + /* ITER */ (OPpITER_REVERSED), + /* ENTERLOOP */ (0), + /* LEAVELOOP */ (OPpARG2_MASK|OPpLVALUE), + /* RETURN */ (0), + /* LAST */ (OPpARG1_MASK|OPpPV_IS_UTF8), + /* NEXT */ (OPpARG1_MASK|OPpPV_IS_UTF8), + /* REDO */ (OPpARG1_MASK|OPpPV_IS_UTF8), + /* DUMP */ (OPpARG1_MASK|OPpPV_IS_UTF8), + /* GOTO */ (OPpARG1_MASK|OPpPV_IS_UTF8), + /* EXIT */ (OPpARG4_MASK), + /* METHOD_NAMED */ (0), + /* ENTERGIVEN */ (OPpARG1_MASK), + /* LEAVEGIVEN */ (OPpARG1_MASK), + /* ENTERWHEN */ (OPpARG1_MASK), + /* LEAVEWHEN */ (OPpARG1_MASK), + /* BREAK */ (0), + /* CONTINUE */ (0), + /* OPEN */ (OPpARG4_MASK|OPpOPEN_IN_RAW|OPpOPEN_IN_CRLF|OPpOPEN_OUT_RAW|OPpOPEN_OUT_CRLF), + /* CLOSE */ (OPpARG4_MASK), + /* PIPE_OP */ (OPpARG4_MASK), + /* FILENO */ (OPpARG4_MASK), + /* UMASK */ (OPpARG4_MASK), + /* BINMODE */ (OPpARG4_MASK), + /* TIE */ (OPpARG4_MASK), + /* UNTIE */ (OPpARG1_MASK), + /* TIED */ (OPpARG1_MASK), + /* DBMOPEN */ (OPpARG4_MASK), + /* DBMCLOSE */ (OPpARG1_MASK), + /* SSELECT */ (OPpARG4_MASK), + /* SELECT */ (OPpARG4_MASK), + /* GETC */ (OPpARG4_MASK), + /* READ */ (OPpARG4_MASK), + /* ENTERWRITE */ (OPpARG4_MASK), + /* LEAVEWRITE */ (OPpARG1_MASK|OPpREFCOUNTED), + /* PRTF */ (0), + /* PRINT */ (0), + /* SAY */ (0), + /* SYSOPEN */ (OPpARG4_MASK), + /* SYSSEEK */ (OPpARG4_MASK), + /* SYSREAD */ (OPpARG4_MASK), + /* SYSWRITE */ (OPpARG4_MASK), + /* EOF */ (OPpARG4_MASK), + /* TELL */ (OPpARG4_MASK), + /* SEEK */ (OPpARG4_MASK), + /* TRUNCATE */ (OPpARG4_MASK), + /* FCNTL */ (OPpARG4_MASK), + /* IOCTL */ (OPpARG4_MASK), + /* FLOCK */ (OPpARG4_MASK|OPpTARGET_MY), + /* SEND */ (OPpARG4_MASK), + /* RECV */ (OPpARG4_MASK), + /* SOCKET */ (OPpARG4_MASK), + /* SOCKPAIR */ (OPpARG4_MASK), + /* BIND */ (OPpARG4_MASK), + /* CONNECT */ (OPpARG4_MASK), + /* LISTEN */ (OPpARG4_MASK), + /* ACCEPT */ (OPpARG4_MASK), + /* SHUTDOWN */ (OPpARG4_MASK), + /* GSOCKOPT */ (OPpARG4_MASK), + /* SSOCKOPT */ (OPpARG4_MASK), + /* GETSOCKNAME */ (OPpARG1_MASK), + /* GETPEERNAME */ (OPpARG1_MASK), + /* LSTAT */ (OPpARG1_MASK), + /* STAT */ (OPpARG1_MASK), + /* FTRREAD */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTRWRITE */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTREXEC */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTEREAD */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTEWRITE */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTEEXEC */ (OPpARG1_MASK|OPpFT_ACCESS|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTIS */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTSIZE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTMTIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTATIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTCTIME */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTROWNED */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTEOWNED */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTZERO */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTSOCK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTCHR */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTBLK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTFILE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTDIR */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTPIPE */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTSUID */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTSGID */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTSVTX */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTLINK */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTTTY */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTTEXT */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* FTBINARY */ (OPpARG1_MASK|OPpFT_STACKED|OPpFT_STACKING|OPpFT_AFTER_t), + /* CHDIR */ (OPpARG4_MASK|OPpTARGET_MY), + /* CHOWN */ (OPpARG4_MASK|OPpTARGET_MY), + /* CHROOT */ (OPpARG1_MASK|OPpTARGET_MY), + /* UNLINK */ (OPpARG4_MASK|OPpTARGET_MY), + /* CHMOD */ (OPpARG4_MASK|OPpTARGET_MY), + /* UTIME */ (OPpARG4_MASK|OPpTARGET_MY), + /* RENAME */ (OPpARG4_MASK|OPpTARGET_MY), + /* LINK */ (OPpARG4_MASK|OPpTARGET_MY), + /* SYMLINK */ (OPpARG4_MASK|OPpTARGET_MY), + /* READLINK */ (OPpARG1_MASK), + /* MKDIR */ (OPpARG4_MASK|OPpTARGET_MY), + /* RMDIR */ (OPpARG1_MASK|OPpTARGET_MY), + /* OPEN_DIR */ (OPpARG4_MASK), + /* READDIR */ (OPpARG1_MASK), + /* TELLDIR */ (OPpARG1_MASK), + /* SEEKDIR */ (OPpARG4_MASK), + /* REWINDDIR */ (OPpARG1_MASK), + /* CLOSEDIR */ (OPpARG1_MASK), + /* FORK */ (0), + /* WAIT */ (OPpTARGET_MY), + /* WAITPID */ (OPpARG4_MASK|OPpTARGET_MY), + /* SYSTEM */ (OPpARG4_MASK|OPpTARGET_MY), + /* EXEC */ (OPpARG4_MASK|OPpTARGET_MY), + /* KILL */ (OPpARG4_MASK|OPpTARGET_MY), + /* GETPPID */ (OPpTARGET_MY), + /* GETPGRP */ (OPpARG4_MASK|OPpTARGET_MY), + /* SETPGRP */ (OPpARG4_MASK|OPpTARGET_MY), + /* GETPRIORITY */ (OPpARG4_MASK|OPpTARGET_MY), + /* SETPRIORITY */ (OPpARG4_MASK|OPpTARGET_MY), + /* TIME */ (OPpTARGET_MY), + /* TMS */ (0), + /* LOCALTIME */ (OPpARG1_MASK), + /* GMTIME */ (OPpARG4_MASK), + /* ALARM */ (OPpARG1_MASK), + /* SLEEP */ (OPpARG4_MASK|OPpTARGET_MY), + /* SHMGET */ (OPpARG4_MASK), + /* SHMCTL */ (OPpARG4_MASK), + /* SHMREAD */ (OPpARG4_MASK), + /* SHMWRITE */ (OPpARG4_MASK), + /* MSGGET */ (OPpARG4_MASK), + /* MSGCTL */ (OPpARG4_MASK), + /* MSGSND */ (OPpARG4_MASK), + /* MSGRCV */ (OPpARG4_MASK), + /* SEMOP */ (OPpARG4_MASK), + /* SEMGET */ (OPpARG4_MASK), + /* SEMCTL */ (OPpARG4_MASK), + /* REQUIRE */ (OPpARG1_MASK), + /* DOFILE */ (OPpARG1_MASK), + /* HINTSEVAL */ (0), + /* ENTEREVAL */ (OPpARG1_MASK|OPpEVAL_HAS_HH|OPpEVAL_UNICODE|OPpEVAL_BYTES|OPpEVAL_COPHH|OPpEVAL_RE_REPARSING), + /* LEAVEEVAL */ (OPpARG1_MASK|OPpREFCOUNTED), + /* ENTERTRY */ (OPpARG1_MASK), + /* LEAVETRY */ (0), + /* GHBYNAME */ (OPpARG1_MASK), + /* GHBYADDR */ (OPpARG4_MASK), + /* GHOSTENT */ (0), + /* GNBYNAME */ (OPpARG1_MASK), + /* GNBYADDR */ (OPpARG4_MASK), + /* GNETENT */ (0), + /* GPBYNAME */ (OPpARG1_MASK), + /* GPBYNUMBER */ (OPpARG4_MASK), + /* GPROTOENT */ (0), + /* GSBYNAME */ (OPpARG4_MASK), + /* GSBYPORT */ (OPpARG4_MASK), + /* GSERVENT */ (0), + /* SHOSTENT */ (OPpARG1_MASK), + /* SNETENT */ (OPpARG1_MASK), + /* SPROTOENT */ (OPpARG1_MASK), + /* SSERVENT */ (OPpARG1_MASK), + /* EHOSTENT */ (0), + /* ENETENT */ (0), + /* EPROTOENT */ (0), + /* ESERVENT */ (0), + /* GPWNAM */ (OPpARG1_MASK), + /* GPWUID */ (OPpARG1_MASK), + /* GPWENT */ (0), + /* SPWENT */ (0), + /* EPWENT */ (0), + /* GGRNAM */ (OPpARG1_MASK), + /* GGRGID */ (OPpARG1_MASK), + /* GGRENT */ (0), + /* SGRENT */ (0), + /* EGRENT */ (0), + /* GETLOGIN */ (0), + /* SYSCALL */ (OPpARG4_MASK), + /* LOCK */ (OPpARG1_MASK), + /* ONCE */ (OPpARG1_MASK), + /* CUSTOM */ (0xff), + /* REACH */ (OPpARG1_MASK), + /* RKEYS */ (OPpARG1_MASK|OPpMAYBE_LVSUB), + /* RVALUES */ (OPpARG1_MASK), + /* COREARGS */ (OPpCOREARGS_DEREF1|OPpCOREARGS_DEREF2|OPpCOREARGS_SCALARMOD|OPpCOREARGS_PUSHMARK), + /* RUNCV */ (OPpOFFBYONE), + /* FC */ (OPpARG1_MASK), + /* PADCV */ (0), + /* INTROCV */ (0), + /* CLONECV */ (0), + /* PADRANGE */ (OPpPADRANGE_COUNTMASK|OPpLVAL_INTRO), + +}; + +# endif /* !DOINIT */ +#endif /* !PERL_GLOBAL_STRUCT_INIT */ + +END_EXTERN_C + + + /* ex: set ro: */ diff --git a/pad.c b/pad.c index 00a76f2..fafb946 100644 --- a/pad.c +++ b/pad.c @@ -56,7 +56,8 @@ at that depth of recursion into the CV. The 0th slot of a frame AV is an AV which is @_. Other entries are storage for variables and op targets. Iterating over the PADNAMELIST iterates over all possible pad -items. Pad slots for targets (SVs_PADTMP) and GVs end up having &PL_sv_no +items. Pad slots for targets (SVs_PADTMP) +and GVs end up having &PL_sv_undef "names", while slots for constants have &PL_sv_no "names" (see pad_alloc()). That &PL_sv_no is used is an implementation detail subject to change. To test for it, use C. @@ -229,6 +230,7 @@ Perl_pad_new(pTHX_ int flags) if (! (flags & padnew_CLONE)) { SAVESPTR(PL_comppad_name); SAVEI32(PL_padix); + SAVEI32(PL_constpadix); SAVEI32(PL_comppad_name_fill); SAVEI32(PL_min_intro_pending); SAVEI32(PL_max_intro_pending); @@ -285,6 +287,7 @@ Perl_pad_new(pTHX_ int flags) PL_comppad_name_fill = 0; PL_min_intro_pending = 0; PL_padix = 0; + PL_constpadix = 0; PL_cv_has_eval = 0; } @@ -316,10 +319,17 @@ children can still follow the full lexical scope chain. void Perl_cv_undef(pTHX_ CV *cv) { + PERL_ARGS_ASSERT_CV_UNDEF; + cv_undef_flags(cv, 0); +} + +void +Perl_cv_undef_flags(pTHX_ CV *cv, U32 flags) +{ const PADLIST *padlist = CvPADLIST(cv); bool const slabbed = !!CvSLABBED(cv); - PERL_ARGS_ASSERT_CV_UNDEF; + PERL_ARGS_ASSERT_CV_UNDEF_FLAGS; DEBUG_X(PerlIO_printf(Perl_debug_log, "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n", @@ -362,8 +372,13 @@ Perl_cv_undef(pTHX_ CV *cv) #endif SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ sv_unmagic((SV *)cv, PERL_MAGIC_checkcall); - if (CvNAMED(cv)) CvNAME_HEK_set(cv, NULL); - else CvGV_set(cv, NULL); + if (!(flags & CV_UNDEF_KEEP_NAME)) { + if (CvNAMED(cv)) { + CvNAME_HEK_set(cv, NULL); + CvNAMED_off(cv); + } + else CvGV_set(cv, NULL); + } /* This statement and the subsequence if block was pad_undef(). */ pad_peg("pad_undef"); @@ -466,9 +481,10 @@ Perl_cv_undef(pTHX_ CV *cv) CvXSUB(cv) = NULL; } /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the - * ref status of CvOUTSIDE and CvGV, and ANON, which pp_entersub uses - * to choose an error message */ - CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON); + * ref status of CvOUTSIDE and CvGV, and ANON, NAMED and + * LEXICAL, which are used to determine the sub's name. */ + CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC|CVf_ANON|CVf_LEXICAL + |CVf_NAMED); } /* @@ -730,30 +746,42 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) else { /* For a tmp, scan the pad from PL_padix upwards * for a slot which has no name and no active value. + * For a constant, likewise, but use PL_constpadix. */ SV * const * const names = AvARRAY(PL_comppad_name); const SSize_t names_fill = AvFILLp(PL_comppad_name); + const bool konst = cBOOL(tmptype & SVf_READONLY); + retval = konst ? PL_constpadix : PL_padix; for (;;) { /* * Entries that close over unavailable variables * in outer subs contain values not marked PADMY. * Thus we must skip, not just pad values that are * marked as current pad values, but also those with names. + * If pad_reset is enabled, ‘current’ means different + * things depending on whether we are allocating a con- + * stant or a target. For a target, things marked PADTMP + * can be reused; not so for constants. */ - if (++PL_padix <= names_fill && - (sv = names[PL_padix]) && sv != &PL_sv_undef) + if (++retval <= names_fill && + (sv = names[retval]) && sv != &PL_sv_undef) continue; - sv = *av_fetch(PL_comppad, PL_padix, TRUE); - if (!(SvFLAGS(sv) & (SVs_PADTMP | SVs_PADMY)) && - !IS_PADGV(sv)) + sv = *av_fetch(PL_comppad, retval, TRUE); + if (!(SvFLAGS(sv) & +#ifdef USE_PAD_RESET + (SVs_PADMY|(konst ? SVs_PADTMP : 0)) +#else + (SVs_PADMY|SVs_PADTMP) +#endif + )) break; } - if (tmptype & SVf_READONLY) { - av_store(PL_comppad_name, PL_padix, &PL_sv_no); + if (konst) { + av_store(PL_comppad_name, retval, &PL_sv_no); tmptype &= ~SVf_READONLY; tmptype |= SVs_PADTMP; } - retval = PL_padix; + *(konst ? &PL_constpadix : &PL_padix) = retval; } SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); @@ -954,13 +982,17 @@ Perl_pad_findmy_pvn(pTHX_ const char *namepv, STRLEN namelen, U32 flags) if ((PADOFFSET)offset != NOT_IN_PAD) return offset; + /* Skip the ‘our’ hack for subroutines, as the warning does not apply. + */ + if (*namepv == '&') return NOT_IN_PAD; + /* look for an our that's being introduced; this allows * our $foo = 0 unless defined $foo; * to not give a warning. (Yes, this is a hack) */ nameav = PadlistARRAY(CvPADLIST(PL_compcv))[0]; name_svp = AvARRAY(nameav); - for (offset = AvFILLp(nameav); offset > 0; offset--) { + for (offset = PadnamelistMAXNAMED(nameav); offset > 0; offset--) { const SV * const namesv = name_svp[offset]; if (namesv && PadnameLEN(namesv) == namelen && !SvFAKE(namesv) @@ -1467,6 +1499,12 @@ Perl_pad_block_start(pTHX_ int full) PL_min_intro_pending = 0; SAVEI32(PL_comppad_name_fill); SAVEI32(PL_padix_floor); + /* PL_padix_floor is what PL_padix is reset to at the start of each + statement, by pad_reset(). We set it when entering a new scope + to keep things like this working: + print "$foo$bar", do { this(); that() . "foo" }; + We must not let "$foo$bar" and the later concatenation share the + same target. */ PL_padix_floor = PL_padix; PL_pad_reset_pending = FALSE; } @@ -1610,7 +1648,7 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) /* if pad tmps aren't shared between ops, then there's no need to * create a new tmp when an existing op is freed */ -#ifdef USE_BROKEN_PAD_RESET +#ifdef USE_PAD_RESET PL_curpad[po] = newSV(0); SvPADTMP_on(PL_curpad[po]); #else @@ -1623,8 +1661,11 @@ Perl_pad_swipe(pTHX_ PADOFFSET po, bool refadjust) } PadnamelistARRAY(PL_comppad_name)[po] = &PL_sv_undef; } - if ((I32)po < PL_padix) - PL_padix = po - 1; + /* Use PL_constpadix here, not PL_padix. The latter may have been + reset by pad_reset. We don’t want pad_alloc to have to scan the + whole pad when allocating a constant. */ + if ((I32)po < PL_constpadix) + PL_constpadix = po - 1; } /* @@ -1635,16 +1676,15 @@ Mark all the current temporaries for reuse =cut */ -/* XXX pad_reset() is currently disabled because it results in serious bugs. - * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed - * on the stack by OPs that use them, there are several ways to get an alias - * to a shared TARG. Such an alias will change randomly and unpredictably. - * We avoid doing this until we can think of a Better Way. - * GSAR 97-10-29 */ +/* pad_reset() causes pad temp TARGs (operator targets) to be shared + * between OPs from different statements. During compilation, at the start + * of each statement pad_reset resets PL_padix back to its previous value. + * When allocating a target, pad_alloc begins its scan through the pad at + * PL_padix+1. */ static void S_pad_reset(pTHX) { -#ifdef USE_BROKEN_PAD_RESET +#ifdef USE_PAD_RESET if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_reset curpad, %p!=%p", AvARRAY(PL_comppad), PL_curpad); @@ -1657,11 +1697,6 @@ S_pad_reset(pTHX) ); if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ - I32 po; - for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { - if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) - SvPADTMP_off(PL_curpad[po]); - } PL_padix = PL_padix_floor; } #endif @@ -1743,8 +1778,7 @@ Perl_pad_tidy(pTHX_ padtidy_type type) * pad are anonymous subs, constants and GVs. * The rest are created anew during cloning. */ - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]) - || IS_PADGV(PL_curpad[ix])) + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) continue; namesv = namep[ix]; if (!(PadnamePV(namesv) && @@ -1767,12 +1801,9 @@ Perl_pad_tidy(pTHX_ padtidy_type type) PADOFFSET ix; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!namep[ix]) namep[ix] = &PL_sv_undef; - if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix]) - || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) + if (!PL_curpad[ix] || SvIMMORTAL(PL_curpad[ix])) continue; - if (!SvPADMY(PL_curpad[ix])) { - SvPADTMP_on(PL_curpad[ix]); - } else if (!SvFAKE(namep[ix])) { + if (SvPADMY(PL_curpad[ix]) && !SvFAKE(namep[ix])) { /* This is a work around for how the current implementation of ?{ } blocks in regexps interacts with lexicals. @@ -1808,7 +1839,9 @@ Free the SV at offset po in the current pad. void Perl_pad_free(pTHX_ PADOFFSET po) { +#ifndef USE_PAD_RESET SV *sv; +#endif ASSERT_CURPAD_LEGAL("pad_free"); if (!PL_curpad) return; @@ -1823,13 +1856,14 @@ Perl_pad_free(pTHX_ PADOFFSET po) PTR2UV(PL_comppad), PTR2UV(PL_curpad), (long)po) ); - +#ifndef USE_PAD_RESET sv = PL_curpad[po]; if (sv && sv != &PL_sv_undef && !SvPADMY(sv)) SvFLAGS(sv) &= ~SVs_PADTMP; if ((I32)po < PL_padix) PL_padix = po - 1; +#endif } /* @@ -2060,20 +2094,26 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) assert(SvTYPE(ppad[ix]) == SVt_PVCV); subclones = 1; sv = newSV_type(SVt_PVCV); + CvLEXICAL_on(sv); } else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv)) { /* my sub */ /* Just provide a stub, but name it. It will be upgrade to the real thing on scope entry. */ + dVAR; + U32 hash; + PERL_HASH(hash, SvPVX_const(namesv)+1, + SvCUR(namesv) - 1); sv = newSV_type(SVt_PVCV); CvNAME_HEK_set( sv, share_hek(SvPVX_const(namesv)+1, SvCUR(namesv) - 1 * (SvUTF8(namesv) ? -1 : 1), - 0) + hash) ); + CvLEXICAL_on(sv); } else sv = SvREFCNT_inc(ppad[ix]); else if (sigil == '@') @@ -2089,7 +2129,7 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv) } } } - else if (IS_PADGV(ppad[ix]) || (namesv && PadnamePV(namesv))) { + else if (namesv && PadnamePV(namesv)) { sv = SvREFCNT_inc_NN(ppad[ix]); } else { @@ -2196,6 +2236,49 @@ Perl_cv_clone_into(pTHX_ CV *proto, CV *target) } /* +=for apidoc cv_name + +Returns an SV containing the name of the CV, mainly for use in error +reporting. The CV may actually be a GV instead, in which case the returned +SV holds the GV's name. Anything other than a GV or CV is treated as a +string already holding the sub name, but this could change in the future. + +An SV may be passed as a second argument. If so, the name will be assigned +to it and it will be returned. Otherwise the returned SV will be a new +mortal. + +=cut +*/ + +SV * +Perl_cv_name(pTHX_ CV *cv, SV *sv) +{ + PERL_ARGS_ASSERT_CV_NAME; + if (!isGV_with_GP(cv) && SvTYPE(cv) != SVt_PVCV) { + if (sv) sv_setsv(sv,(SV *)cv); + return sv ? (sv) : (SV *)cv; + } + { + SV * const retsv = sv ? (sv) : sv_newmortal(); + if (SvTYPE(cv) == SVt_PVCV) { + if (CvNAMED(cv)) { + if (CvLEXICAL(cv)) sv_sethek(retsv, CvNAME_HEK(cv)); + else { + sv_sethek(retsv, HvNAME_HEK(CvSTASH(cv))); + sv_catpvs(retsv, "::"); + sv_cathek(retsv, CvNAME_HEK(cv)); + } + } + else if (CvLEXICAL(cv)) + sv_sethek(retsv, GvNAME_HEK(GvEGV(CvGV(cv)))); + else gv_efullname3(retsv, CvGV(cv), NULL); + } + else gv_efullname3(retsv,(GV *)cv,NULL); + return retsv; + } +} + +/* =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv For any anon CVs in the pad, change CvOUTSIDE of that CV from @@ -2297,7 +2380,7 @@ Perl_pad_push(pTHX_ PADLIST *padlist, int depth) SvPADMY_on(sv); } } - else if (IS_PADGV(oldpad[ix]) || PadnamePV(names[ix])) { + else if (PadnamePV(names[ix])) { av_store(newpad, ix, SvREFCNT_inc_NN(oldpad[ix])); } else { @@ -2433,8 +2516,7 @@ Perl_padlist_dup(pTHX_ PADLIST *srcpad, CLONE_PARAMS *param) } } } - else if (IS_PADGV(oldpad[ix]) - || ( names_fill >= ix && names[ix] + else if (( names_fill >= ix && names[ix] && PadnamePV(names[ix]) )) { pad1a[ix] = sv_dup_inc(oldpad[ix], param); } diff --git a/pad.h b/pad.h index c29a13f..d800b19 100644 --- a/pad.h +++ b/pad.h @@ -240,7 +240,7 @@ for C. =for apidoc m|SV *|PAD_SETSV |PADOFFSET po|SV* sv Set the slot at offset C in the current pad to C -=for apidoc m|void|PAD_SV |PADOFFSET po +=for apidoc m|SV *|PAD_SV |PADOFFSET po Get the value at offset C in the current pad =for apidoc m|SV *|PAD_SVl |PADOFFSET po diff --git a/parser.h b/parser.h index 75f676c..11367b6 100644 --- a/parser.h +++ b/parser.h @@ -56,7 +56,7 @@ typedef struct yy_parser { U8 lex_defer; /* state after determined token */ U8 lex_dojoin; /* doing an array interpolation 1 = @{...} 2 = ->@ */ - U8 lex_expect; /* expect after determined token */ + U8 lex_expect; /* UNUSED */ U8 expect; /* how to interpret ambiguous tokens */ I32 lex_formbrack; /* bracket count at outer format level */ OP *lex_inpat; /* in pattern $) and $| are special */ diff --git a/patchlevel.h b/patchlevel.h index 6bf40ed..21de76c 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -15,7 +15,7 @@ #define PERL_REVISION 5 /* age */ #define PERL_VERSION 21 /* epoch */ -#define PERL_SUBVERSION 3 /* generation */ +#define PERL_SUBVERSION 4 /* generation */ /* The following numbers describe the earliest compatible version of Perl ("compatibility" here being defined as sufficient binary/API @@ -36,7 +36,7 @@ */ #define PERL_API_REVISION 5 #define PERL_API_VERSION 21 -#define PERL_API_SUBVERSION 3 +#define PERL_API_SUBVERSION 4 /* XXX Note: The selection of non-default Configure options, such as -Duselonglong may invalidate these settings. Currently, Configure diff --git a/perl.c b/perl.c index e84f1d5..478b415 100644 --- a/perl.c +++ b/perl.c @@ -1034,6 +1034,7 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_foldable); SvREFCNT_dec(PL_utf8_foldclosures); SvREFCNT_dec(PL_AboveLatin1); + SvREFCNT_dec(PL_InBitmap); SvREFCNT_dec(PL_UpperLatin1); SvREFCNT_dec(PL_Latin1); SvREFCNT_dec(PL_NonL1NonFinalFold); @@ -1047,6 +1048,7 @@ perl_destruct(pTHXx) PL_utf8_idcont = NULL; PL_utf8_foldclosures = NULL; PL_AboveLatin1 = NULL; + PL_InBitmap = NULL; PL_HasMultiCharFold = NULL; PL_Latin1 = NULL; PL_NonL1NonFinalFold = NULL; @@ -2070,9 +2072,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) it should be reported immediately as a build failure. */ (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, Perl_newSVpvf(aTHX_ - "BEGIN { do {local $!; -f q%c%"SVf"/buildcustomize.pl%c} and do q%c%"SVf"/buildcustomize.pl%c || die $@ }", - 0, SVfARG(*inc0), 0, - 0, SVfARG(*inc0), 0)); + "BEGIN { my $f = q%c%s%"SVf"/buildcustomize.pl%c; " + "do {local $!; -f $f }" + " and do $f || die $@ || qq '$f: $!' }", + 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); } # else /* SITELIB_EXP is a function call on Win32. */ @@ -2881,7 +2884,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* =for apidoc p||eval_pv -Tells Perl to C the given string and return an SV* result. +Tells Perl to C the given string in scalar context and return an SV* result. =cut */ @@ -3906,7 +3909,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) * if -T are the first chars together; otherwise one gets * "Too late" message. */ if ( argc > 1 && argv[1][0] == '-' - && (argv[1][1] == 't' || argv[1][1] == 'T') ) + && isALPHA_FOLD_EQ(argv[1][1], 't')) return 1; return 0; } diff --git a/perl.h b/perl.h index ece022d..d711b20 100644 --- a/perl.h +++ b/perl.h @@ -28,6 +28,17 @@ # include "config.h" #endif +/* NOTE 1: that with gcc -std=c89 the __STDC_VERSION__ is *not* defined + * because the __STDC_VERSION__ became a thing only with C90. Therefore, + * with gcc, HAS_C99 will never become true as long as we use -std=c89. + + * NOTE 2: headers lie. Do not expect that if HAS_C99 gets to be true, + * all the C99 features are there and are correct. */ +#if (defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || \ + defined(_STDC_C99) +# define HAS_C99 1 +#endif + /* See L for detailed notes on * PERL_IMPLICIT_CONTEXT and PERL_IMPLICIT_SYS */ @@ -307,18 +318,19 @@ /* gcc -Wall: * for silencing unused variables that are actually used most of the time, - * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs + * but we cannot quite get rid of, such as "ax" in PPCODE+noargs xsubs, + * or variables/arguments that are used only in certain configurations. */ #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else -# define PERL_UNUSED_ARG(x) ((void)x) +# define PERL_UNUSED_ARG(x) ((void)sizeof(x)) # endif #endif #ifndef PERL_UNUSED_VAR -# define PERL_UNUSED_VAR(x) ((void)x) +# define PERL_UNUSED_VAR(x) ((void)sizeof(x)) #endif #if defined(USE_ITHREADS) || defined(PERL_GLOBAL_STRUCT) @@ -700,6 +712,10 @@ # endif #endif +#ifdef I_STDINT +# include +#endif + #include #ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */ @@ -1546,6 +1562,10 @@ EXTERN_C char *crypt(const char *, const char *); #define PERL_SNPRINTF_CHECK(len, max, api) STMT_START { if ((max) > 0 && (Size_t)len >= (max)) Perl_croak_nocontext("panic: %s buffer overflow", STRINGIFY(api)); } STMT_END +#ifdef USE_QUADMATH +# define my_snprintf Perl_my_snprintf +# define PERL_MY_SNPRINTF_GUARDED +#else #if defined(HAS_SNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_snprintf(buffer, max, ...) ({ int len = snprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, snprintf); len; }) @@ -1557,7 +1577,10 @@ EXTERN_C char *crypt(const char *, const char *); # define my_snprintf Perl_my_snprintf # define PERL_MY_SNPRINTF_GUARDED #endif +#endif +/* There is no quadmath_vsnprintf, and therefore my_vsnprintf() + * dies if called under USE_QUADMATH. */ #if defined(HAS_VSNPRINTF) && defined(HAS_C99_VARIADIC_MACROS) && !(defined(DEBUGGING) && !defined(PERL_USE_GCC_BRACE_GROUPS)) && !defined(PERL_GCC_PEDANTIC) # ifdef PERL_USE_GCC_BRACE_GROUPS # define my_vsnprintf(buffer, max, ...) ({ int len = vsnprintf(buffer, max, __VA_ARGS__); PERL_SNPRINTF_CHECK(len, max, vsnprintf); len; }) @@ -1838,94 +1861,151 @@ typedef NVTYPE NV; # ifdef I_SUNMATH # include # endif -# define NV_DIG LDBL_DIG -# ifdef LDBL_MANT_DIG -# define NV_MANT_DIG LDBL_MANT_DIG -# endif -# ifdef LDBL_MIN -# define NV_MIN LDBL_MIN -# endif -# ifdef LDBL_MAX -# define NV_MAX LDBL_MAX -# endif -# ifdef LDBL_MIN_EXP -# define NV_MIN_EXP LDBL_MIN_EXP +# if defined(USE_QUADMATH) && defined(I_QUADMATH) +# include # endif -# ifdef LDBL_MAX_EXP -# define NV_MAX_EXP LDBL_MAX_EXP -# endif -# ifdef LDBL_MIN_10_EXP -# define NV_MIN_10_EXP LDBL_MIN_10_EXP -# endif -# ifdef LDBL_MAX_10_EXP -# define NV_MAX_10_EXP LDBL_MAX_10_EXP -# endif -# ifdef LDBL_EPSILON -# define NV_EPSILON LDBL_EPSILON -# endif -# ifdef LDBL_MAX -# define NV_MAX LDBL_MAX +# ifdef FLT128_DIG +# define NV_DIG FLT128_DIG +# define NV_MANT_DIG FLT128_MANT_DIG +# define NV_MIN FLT128_MIN +# define NV_MAX FLT128_MAX +# define NV_MIN_EXP FLT128_MIN_EXP +# define NV_MAX_EXP FLT128_MAX_EXP +# define NV_EPSILON FLT128_EPSILON +# define NV_MIN_10_EXP FLT128_MIN_10_EXP +# define NV_MAX_10_EXP FLT128_MAX_10_EXP +# define NV_INF HUGE_VALQ +# define NV_NAN nanq("0") +# elif defined(LDBL_DIG) +# define NV_DIG LDBL_DIG +# ifdef LDBL_MANT_DIG +# define NV_MANT_DIG LDBL_MANT_DIG +# endif +# ifdef LDBL_MIN +# define NV_MIN LDBL_MIN +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX +# endif +# ifdef LDBL_MIN_EXP +# define NV_MIN_EXP LDBL_MIN_EXP +# endif +# ifdef LDBL_MAX_EXP +# define NV_MAX_EXP LDBL_MAX_EXP +# endif +# ifdef LDBL_MIN_10_EXP +# define NV_MIN_10_EXP LDBL_MIN_10_EXP +# endif +# ifdef LDBL_MAX_10_EXP +# define NV_MAX_10_EXP LDBL_MAX_10_EXP +# endif +# ifdef LDBL_EPSILON +# define NV_EPSILON LDBL_EPSILON +# endif +# ifdef LDBL_MAX +# define NV_MAX LDBL_MAX /* Having LDBL_MAX doesn't necessarily mean that we have LDBL_MIN... -Allen */ -# else -# ifdef HUGE_VALL -# define NV_MAX HUGE_VALL # else -# ifdef HUGE_VAL -# define NV_MAX ((NV)HUGE_VAL) +# ifdef HUGE_VALL +# define NV_MAX HUGE_VALL # endif # endif # endif -# ifdef HAS_SQRTL +# if defined(USE_QUADMATH) && defined(I_QUADMATH) +# define Perl_acos acosq +# define Perl_asin asinq +# define Perl_atan atanq +# define Perl_atan2 atan2q +# define Perl_ceil ceilq +# define Perl_cos cosq +# define Perl_cosh coshq +# define Perl_exp expq +/* no Perl_fabs, but there's PERL_ABS */ +# define Perl_floor floorq +# define Perl_fmod fmodq +# define Perl_log logq +# define Perl_log10 log10q +# define Perl_pow powq +# define Perl_sin sinq +# define Perl_sinh sinhq +# define Perl_sqrt sqrtq +# define Perl_tan tanq +# define Perl_tanh tanhq +# define Perl_modf(x,y) modfq(x,y) +# define Perl_frexp(x,y) frexpq(x,y) +# define Perl_ldexp(x, y) ldexpq(x,y) +# define Perl_isinf(x) isinfq(x) +# define Perl_isnan(x) isnanq(x) +# define Perl_isfinite(x) !(isnanq(x) || isinfq(x)) +# elif defined(HAS_SQRTL) +# define Perl_acos acosl +# define Perl_asin asinl +# define Perl_atan atanl +# define Perl_atan2 atan2l +# define Perl_ceil ceill # define Perl_cos cosl -# define Perl_sin sinl -# define Perl_sqrt sqrtl +# define Perl_cosh coshl # define Perl_exp expl -# define Perl_log logl -# define Perl_atan2 atan2l -# define Perl_pow powl +/* no Perl_fabs, but there's PERL_ABS */ # define Perl_floor floorl -# define Perl_ceil ceill # define Perl_fmod fmodl +# define Perl_log logl +# define Perl_log10 log10l +# define Perl_pow powl +# define Perl_sin sinl +# define Perl_sinh sinhl +# define Perl_sqrt sqrtl +# define Perl_tan tanl +# define Perl_tanh tanhl # endif /* e.g. libsunmath doesn't have modfl and frexpl as of mid-March 2000 */ -# ifdef HAS_MODFL -# define Perl_modf(x,y) modfl(x,y) +# ifndef Perl_modf +# ifdef HAS_MODFL +# define Perl_modf(x,y) modfl(x,y) /* eg glibc 2.2 series seems to provide modfl on ppc and arm, but has no prototype in */ -# ifndef HAS_MODFL_PROTO +# ifndef HAS_MODFL_PROTO EXTERN_C long double modfl(long double, long double *); -# endif -# else -# if defined(HAS_AINTL) && defined(HAS_COPYSIGNL) +# endif +# elif (defined(HAS_TRUNCL) || defined(HAS_AINTL)) && defined(HAS_COPYSIGNL) extern long double Perl_my_modfl(long double x, long double *ip); # define Perl_modf(x,y) Perl_my_modfl(x,y) # endif # endif -# ifdef HAS_FREXPL -# define Perl_frexp(x,y) frexpl(x,y) -# else -# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL) - extern long double Perl_my_frexpl(long double x, int *e); -# define Perl_frexp(x,y) Perl_my_frexpl(x,y) +# ifndef Perl_frexp +# ifdef HAS_FREXPL +# define Perl_frexp(x,y) frexpl(x,y) +# else +# if defined(HAS_ILOGBL) && defined(HAS_SCALBNL) +extern long double Perl_my_frexpl(long double x, int *e); +# define Perl_frexp(x,y) Perl_my_frexpl(x,y) +# endif # endif # endif -# ifdef HAS_LDEXPL -# define Perl_ldexp(x, y) ldexpl(x,y) -# else -# if defined(HAS_SCALBNL) && FLT_RADIX == 2 -# define Perl_ldexp(x,y) scalbnl(x,y) +# ifndef Perl_ldexp +# ifdef HAS_LDEXPL +# define Perl_ldexp(x, y) ldexpl(x,y) +# else +# if defined(HAS_SCALBNL) && FLT_RADIX == 2 +# define Perl_ldexp(x,y) scalbnl(x,y) +# endif # endif # endif # ifndef Perl_isnan -# ifdef HAS_ISNANL +# if defined(HAS_ISNANL) && !(defined(isnan) && defined(HAS_C99)) # define Perl_isnan(x) isnanl(x) # endif # endif # ifndef Perl_isinf -# ifdef HAS_FINITEL -# define Perl_isinf(x) !(finitel(x)||Perl_isnan(x)) +# if defined(HAS_ISINFL) && !(defined(isinf) && defined(HAS_C99)) +# define Perl_isinf(x) isinfl(x) +# elif defined(LDBL_MAX) +# define Perl_isinf(x) ((x) > LDBL_MAX || (x) < -LDBL_MAX) # endif # endif +# ifndef Perl_isfinite +# define Perl_isfinite(x) Perl_isfinitel(x) +# endif #else # define NV_DIG DBL_DIG # ifdef DBL_MANT_DIG @@ -1960,31 +2040,121 @@ EXTERN_C long double modfl(long double, long double *); # define NV_MAX HUGE_VAL # endif # endif + +/* These math interfaces are C89. */ +# define Perl_acos acos +# define Perl_asin asin +# define Perl_atan atan +# define Perl_atan2 atan2 +# define Perl_ceil ceil # define Perl_cos cos -# define Perl_sin sin -# define Perl_sqrt sqrt +# define Perl_cosh cosh # define Perl_exp exp -# define Perl_log log -# define Perl_atan2 atan2 -# define Perl_pow pow +/* no Perl_fabs, but there's PERL_ABS */ # define Perl_floor floor -# define Perl_ceil ceil # define Perl_fmod fmod +# define Perl_log log +# define Perl_log10 log10 +# define Perl_pow pow +# define Perl_sin sin +# define Perl_sinh sinh +# define Perl_sqrt sqrt +# define Perl_tan tan +# define Perl_tanh tanh + # define Perl_modf(x,y) modf(x,y) # define Perl_frexp(x,y) frexp(x,y) # define Perl_ldexp(x,y) ldexp(x,y) + +# ifndef Perl_isnan +# ifdef HAS_ISNAN +# define Perl_isnan(x) isnan(x) +# endif +# endif +# ifndef Perl_isinf +# if defined(HAS_ISINF) +# define Perl_isinf(x) isinf(x) +# elif defined(DBL_MAX) +# define Perl_isinf(x) ((x) > DBL_MAX || (x) < -DBL_MAX) +# endif +# endif +# ifndef Perl_isfinite +# ifdef HAS_ISFINITE +# define Perl_isfinite(x) isfinite(x) +# elif defined(HAS_FINITE) +# define Perl_isfinite(x) finite(x) +# endif +# endif +#endif + +/* fpclassify(): C99. It is supposed to be a macro that switches on +* the sizeof() of its argument, so there's no need for e.g. fpclassifyl().*/ +#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) +# include +# if defined(FP_INFINITE) && defined(FP_NAN) +# define Perl_fp_class(x) fpclassify(x) +# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) +# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) +# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) +# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) +# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) +# elif defined(FP_PLUS_INF) && defined(FP_QNAN) +/* Some versions of HP-UX (10.20) have (only) fpclassify() but which is + * actually not the C99 fpclassify, with its own set of return defines. */ +# define Perl_fp_class(x) fpclassify(x) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif #endif -/* rumor has it that Win32 has _fpclass() */ +/* fp_classify(): Legacy: VMS, maybe Unicos? The values, however, + * are identical to the C99 fpclassify(). */ +#if !defined(Perl_fp_class) && defined(HAS_FP_CLASSIFY) +# include +# ifdef __VMS + /* FP_INFINITE and others are here rather than in math.h as C99 stipulates */ +# include + /* oh, and the isnormal macro has a typo in it! */ +# undef isnormal +# define isnormal(x) Perl_fp_class_norm(x) +# endif +# if defined(FP_INFINITE) && defined(FP_NAN) +# define Perl_fp_class(x) fp_classify(x) +# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_INFINITE) +# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_NAN) +# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_NORMAL) +# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_SUBNORMAL) +# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif +#endif -/* SGI has fpclassl... but not with the same result values, - * and it's via a typedef (not via #define), so will need to redo Configure - * to use. Not worth the trouble, IMO, at least until the below is used - * more places. Also has fp_class_l, BTW, via fp_class.h. Feel free to check - * with me for the SGI manpages, SGI testing, etcetera, if you want to - * try getting this to work with IRIX. - Allen */ +/* Feel free to check with me for the SGI manpages, SGI testing, + * etcetera, if you want to try getting this to work with IRIX. + * + * - Allen */ +/* fpclass(): SysV, at least Solaris and some versions of IRIX. */ #if !defined(Perl_fp_class) && (defined(HAS_FPCLASS)||defined(HAS_FPCLASSL)) +/* Solaris and IRIX have fpclass/fpclassl, but they are using + * an enum typedef, not cpp symbols, and Configure doesn't detect that. + * Define some symbols also as cpp symbols so we can detect them. */ +# if defined(__sun) || defined(__irix__) /* XXX Configure test instead */ +# define FP_PINF FP_PINF +# define FP_QNAN FP_QNAN +# endif +# include # ifdef I_IEEFP # include # endif @@ -1992,134 +2162,221 @@ EXTERN_C long double modfl(long double, long double *); # include # endif # if defined(USE_LONG_DOUBLE) && defined(HAS_FPCLASSL) -# define Perl_fp_class() fpclassl(x) +# define Perl_fp_class(x) fpclassl(x) # else -# define Perl_fp_class() fpclass(x) +# define Perl_fp_class(x) fpclass(x) # endif -# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) -# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) -# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_CLASS_SNAN||Perl_fp_class(x)==FP_CLASS_QNAN) -# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) -# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) -# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_CLASS_NINF||Perl_fp_class(x)==FP_CLASS_PINF) -# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) -# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) -# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_CLASS_NNORM||Perl_fp_class(x)==FP_CLASS_PNORM) -# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) -# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) -# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM||Perl_fp_class(x)==FP_CLASS_PDENORM) -# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) -# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) -# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_CLASS_NZERO||Perl_fp_class(x)==FP_CLASS_PZERO) -#endif - -#if !defined(Perl_fp_class) && defined(HAS_FP_CLASS) -# include -# if !defined(FP_SNAN) && defined(I_FP_CLASS) -# include +# if defined(FP_CLASS_PINF) && defined(FP_CLASS_SNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_CLASS_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_CLASS_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_CLASS_NINF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_CLASS_PINF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_CLASS_NNORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_CLASS_PNORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_CLASS_NDENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_CLASS_PDENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_CLASS_NZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_CLASS_PZERO) +# elif defined(FP_PINF) && defined(FP_QNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NINF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PINF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NNORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PNORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NDENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PDENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ # endif -# define Perl_fp_class(x) fp_class(x) -# define Perl_fp_class_snan(x) (fp_class(x)==FP_SNAN) -# define Perl_fp_class_qnan(x) (fp_class(x)==FP_QNAN) -# define Perl_fp_class_nan(x) (fp_class(x)==FP_SNAN||fp_class(x)==FP_QNAN) -# define Perl_fp_class_ninf(x) (fp_class(x)==FP_NEG_INF) -# define Perl_fp_class_pinf(x) (fp_class(x)==FP_POS_INF) -# define Perl_fp_class_inf(x) (fp_class(x)==FP_NEG_INF||fp_class(x)==FP_POS_INF) -# define Perl_fp_class_nnorm(x) (fp_class(x)==FP_NEG_NORM) -# define Perl_fp_class_pnorm(x) (fp_class(x)==FP_POS_NORM) -# define Perl_fp_class_norm(x) (fp_class(x)==FP_NEG_NORM||fp_class(x)==FP_POS_NORM) -# define Perl_fp_class_ndenorm(x) (fp_class(x)==FP_NEG_DENORM) -# define Perl_fp_class_pdenorm(x) (fp_class(x)==FP_POS_DENORM) -# define Perl_fp_class_denorm(x) (fp_class(x)==FP_NEG_DENORM||fp_class(x)==FP_POS_DENORM) -# define Perl_fp_class_nzero(x) (fp_class(x)==FP_NEG_ZERO) -# define Perl_fp_class_pzero(x) (fp_class(x)==FP_POS_ZERO) -# define Perl_fp_class_zero(x) (fp_class(x)==FP_NEG_ZERO||fp_class(x)==FP_POS_ZERO) #endif -#if !defined(Perl_fp_class) && defined(HAS_FPCLASSIFY) +/* fp_class(): Legacy: at least Tru64, some versions of IRIX. */ +#if !defined(Perl_fp_class) && (defined(HAS_FP_CLASS)||defined(HAS_FP_CLASSL)) # include -# define Perl_fp_class(x) fpclassify(x) -# define Perl_fp_class_nan(x) (fp_classify(x)==FP_SNAN||fp_classify(x)==FP_QNAN) -# define Perl_fp_class_inf(x) (fp_classify(x)==FP_INFINITE) -# define Perl_fp_class_norm(x) (fp_classify(x)==FP_NORMAL) -# define Perl_fp_class_denorm(x) (fp_classify(x)==FP_SUBNORMAL) -# define Perl_fp_class_zero(x) (fp_classify(x)==FP_ZERO) +# if !defined(FP_SNAN) && defined(I_FP_CLASS) +# include +# endif +# if defined(FP_POS_INF) && defined(FP_QNAN) +# ifdef __irix__ /* XXX Configure test instead */ +# ifdef USE_LONG_DOUBLE +# define Perl_fp_class(x) fp_class_l(x) +# else +# define Perl_fp_class(x) fp_class_d(x) +# endif +# else +# if defined(USE_LONG_DOUBLE) && defined(HAS_FP_CLASSL) +# define Perl_fp_class(x) fp_classl(x) +# else +# define Perl_fp_class(x) fp_class(x) +# endif +# endif +# if defined(FP_POS_INF) && defined(FP_QNAN) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_SNAN) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_QNAN) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_NEG_INF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_POS_INF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_NEG_NORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_POS_NORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_NEG_DENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_POS_DENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_NEG_ZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_POS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif +# endif #endif +/* class(), _class(): Legacy: AIX. */ #if !defined(Perl_fp_class) && defined(HAS_CLASS) # include -# ifndef _cplusplus -# define Perl_fp_class(x) class(x) -# else -# define Perl_fp_class(x) _class(x) +# if defined(FP_PLUS_NORM) && defined(FP_PLUS_INF) +# ifndef _cplusplus +# define Perl_fp_class(x) class(x) +# else +# define Perl_fp_class(x) _class(x) +# endif +# if defined(FP_PLUS_INF) && defined(FP_NANQ) +# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) +# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) +# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) +# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) +# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) +# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) +# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) +# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) +# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) +# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) +# else +# undef Perl_fp_class /* Unknown set of defines */ +# endif # endif -# define Perl_fp_class_snan(x) (Perl_fp_class(x)==FP_NANS) -# define Perl_fp_class_qnan(x) (Perl_fp_class(x)==FP_NANQ) -# define Perl_fp_class_nan(x) (Perl_fp_class(x)==FP_SNAN||Perl_fp_class(x)==FP_QNAN) -# define Perl_fp_class_ninf(x) (Perl_fp_class(x)==FP_MINUS_INF) -# define Perl_fp_class_pinf(x) (Perl_fp_class(x)==FP_PLUS_INF) -# define Perl_fp_class_inf(x) (Perl_fp_class(x)==FP_MINUS_INF||Perl_fp_class(x)==FP_PLUS_INF) -# define Perl_fp_class_nnorm(x) (Perl_fp_class(x)==FP_MINUS_NORM) -# define Perl_fp_class_pnorm(x) (Perl_fp_class(x)==FP_PLUS_NORM) -# define Perl_fp_class_norm(x) (Perl_fp_class(x)==FP_MINUS_NORM||Perl_fp_class(x)==FP_PLUS_NORM) -# define Perl_fp_class_ndenorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM) -# define Perl_fp_class_pdenorm(x) (Perl_fp_class(x)==FP_PLUS_DENORM) -# define Perl_fp_class_denorm(x) (Perl_fp_class(x)==FP_MINUS_DENORM||Perl_fp_class(x)==FP_PLUS_DENORM) -# define Perl_fp_class_nzero(x) (Perl_fp_class(x)==FP_MINUS_ZERO) -# define Perl_fp_class_pzero(x) (Perl_fp_class(x)==FP_PLUS_ZERO) -# define Perl_fp_class_zero(x) (Perl_fp_class(x)==FP_MINUS_ZERO||Perl_fp_class(x)==FP_PLUS_ZERO) -#endif - -/* rumor has it that Win32 has _isnan() */ +#endif -#ifndef Perl_isnan -# ifdef HAS_ISNAN -# define Perl_isnan(x) isnan((NV)x) -# else -# ifdef Perl_fp_class_nan -# define Perl_isnan(x) Perl_fp_class_nan(x) -# else -# ifdef HAS_UNORDERED -# define Perl_isnan(x) unordered((x), 0.0) -# else -# define Perl_isnan(x) ((x)!=(x)) -# endif -# endif -# endif +/* Win32: _fpclass(), _isnan(), _finite(). */ +#ifdef WIN32 +# ifndef Perl_isnan +# define Perl_isnan(x) _isnan(x) +# endif +# ifndef Perl_isfinite +# define Perl_isfinite(x) _finite(x) +# endif +# ifndef Perl_fp_class_snan +/* No simple way to #define Perl_fp_class because _fpclass() + * returns a set of bits. */ +# define Perl_fp_class_snan(x) (_fpclass(x) & _FPCLASS_SNAN) +# define Perl_fp_class_qnan(x) (_fpclass(x) & _FPCLASS_QNAN) +# define Perl_fp_class_nan(x) (_fpclass(x) & (_FPCLASS_SNAN|_FPCLASS_QNAN)) +# define Perl_fp_class_ninf(x) (_fpclass(x) & _FPCLASS_NINF)) +# define Perl_fp_class_pinf(x) (_fpclass(x) & _FPCLASS_PINF)) +# define Perl_fp_class_inf(x) (_fpclass(x) & (_FPCLASS_NINF|_FPCLASS_PINF)) +# define Perl_fp_class_nnorm(x) (_fpclass(x) & _FPCLASS_NN) +# define Perl_fp_class_pnorm(x) (_fpclass(x) & _FPCLASS_PN) +# define Perl_fp_class_norm(x) (_fpclass(x) & (_FPCLASS_NN|_FPCLASS_PN)) +# define Perl_fp_class_ndenorm(x) (_fpclass(x) & _FPCLASS_ND) +# define Perl_fp_class_pdenorm(x) (_fpclass(x) & _FPCLASS_PD) +# define Perl_fp_class_denorm(x) (_fpclass(x) & (_FPCLASS_ND|_FPCLASS_PD)) +# define Perl_fp_class_nzero(x) (_fpclass(x) & _FPCLASS_NZ) +# define Perl_fp_class_pzero(x) (_fpclass(x) & _FPCLASS_PZ) +# define Perl_fp_class_zero(x) (_fpclass(x) & (_FPCLASS_NZ|_FPCLASS_PZ)) +# endif +#endif + +#if !defined(Perl_fp_class_inf) && \ + defined(Perl_fp_class_pinf) && defined(Perl_fp_class_ninf) +# define Perl_fp_class_inf(x) \ + (Perl_fp_class_pinf(x) || Perl_fp_class_ninf(x)) +#endif + +#if !defined(Perl_fp_class_nan) && \ + defined(Perl_fp_class_snan) && defined(Perl_fp_class_qnan) +# define Perl_fp_class_nan(x) \ + (Perl_fp_class_snan(x) || Perl_fp_class_qnan(x)) +#endif + +#if !defined(Perl_fp_class_zero) && \ + defined(Perl_fp_class_pzero) && defined(Perl_fp_class_nzero) +# define Perl_fp_class_zero(x) \ + (Perl_fp_class_pzero(x) || Perl_fp_class_nzero(x)) +#endif + +#if !defined(Perl_fp_class_norm) && \ + defined(Perl_fp_class_pnorm) && defined(Perl_fp_class_nnorm) +# define Perl_fp_class_norm(x) \ + (Perl_fp_class_pnorm(x) || Perl_fp_class_nnorm(x)) +#endif + +#if !defined(Perl_fp_class_denorm) && \ + defined(Perl_fp_class_pdenorm) && defined(Perl_fp_class_ndenorm) +# define Perl_fp_class_denorm(x) \ + (Perl_fp_class_pdenorm(x) || Perl_fp_class_ndenorm(x)) #endif #ifdef UNDER_CE int isnan(double d); #endif -#ifndef Perl_isinf -# ifdef HAS_ISINF -# define Perl_isinf(x) isinf((NV)x) +#ifndef Perl_isnan +# ifdef Perl_fp_class_nan +# define Perl_isnan(x) Perl_fp_class_nan(x) # else -# ifdef Perl_fp_class_inf -# define Perl_isinf(x) Perl_fp_class_inf(x) +# ifdef HAS_UNORDERED +# define Perl_isnan(x) unordered((x), 0.0) # else -# define Perl_isinf(x) ((x)==NV_INF) +# define Perl_isnan(x) ((x)!=(x)) # endif # endif #endif +#ifndef Perl_isinf +# ifdef Perl_fp_class_inf +# define Perl_isinf(x) Perl_fp_class_inf(x) +# endif +#endif + #ifndef Perl_isfinite -# ifdef HAS_FINITE -# define Perl_isfinite(x) finite((NV)x) +# if defined(HAS_ISFINITE) && !defined(isfinite) +# define Perl_isfinite(x) isfinite((double)(x)) +# elif defined(HAS_FINITE) +# define Perl_isfinite(x) finite((double)(x)) +# elif defined(Perl_fp_class_finite) +# define Perl_isfinite(x) Perl_fp_class_finite(x) # else -# ifdef HAS_ISFINITE -# define Perl_isfinite(x) isfinite(x) -# else -# ifdef Perl_fp_class_finite -# define Perl_isfinite(x) Perl_fp_class_finite(x) -# else -# define Perl_isfinite(x) !(Perl_is_inf(x)||Perl_is_nan(x)) -# endif -# endif +/* For the infinities the multiplication returns nan, + * for the nan the multiplication also returns nan, + * for everything else (that is, finite) zero should be returned. */ +# define Perl_isfinite(x) (((x) * 0) == 0) +# endif +#endif + +#ifndef Perl_isinf +# if defined(Perl_isfinite) && defined(Perl_isnan) +# define Perl_isinf(x) !(Perl_isfinite(x)||Perl_isnan(x)) # endif #endif +/* We need Perl_isfinitel (ends with ell) (if available) even when + * not USE_LONG_DOUBLE because the printf code (sv_catpvfn_flags) + * needs that. */ +#if defined(HAS_LONG_DOUBLE) && !defined(Perl_isfinitel) +/* If isfinite() is a macro and looks like we have C99, + * we assume it's the type-aware C99 isfinite(). */ +# if defined(HAS_ISFINITE) && defined(isfinite) && defined(HAS_C99) +# define Perl_isfinitel(x) isfinite(x) +# elif defined(HAS_ISFINITEL) +# define Perl_isfinitel(x) isfinitel(x) +# elif defined(HAS_FINITEL) +# define Perl_isfinitel(x) finitel(x) +# elif defined(HAS_INFL) && defined(HAS_NANL) +# define Perl_isfinitel(x) !(isinfl(x)||isnanl(x)) +# else +# define Perl_isfinitel(x) ((x) * 0 == 0) /* See Perl_isfinite. */ +# endif +#endif + /* The default is to use Perl's own atof() implementation (in numeric.c). * Usually that is the one to use but for some platforms (e.g. UNICOS) * it is however best to use the native implementation of atof. @@ -3912,6 +4169,10 @@ char *strcpy(), *strcat(); #ifdef I_MATH # include +# ifdef __VMS + /* isfinite and others are here rather than in math.h as C99 stipulates */ +# include +# endif #else START_EXTERN_C double exp (double); @@ -3928,8 +4189,27 @@ START_EXTERN_C END_EXTERN_C #endif -#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(LDBL_INFINITY) -# define NV_INF LDBL_INFINITY +#ifdef WIN32 +# if !defined(NV_INF) && defined(HUGE_VAL) +# define NV_INF HUGE_VAL +# endif +/* For WIN32 the best NV_NAN is the __PL_nan_u trick, see below. + * There is no supported way of getting the NAN across all the crts. */ +#endif + +/* If you are thinking of using HUGE_VAL for infinity, or using + * functions to generate NV_INF (e.g. exp(1e9), log(-1.0)), + * stop. Neither will work portably: HUGE_VAL can be just DBL_MAX, + * and the math functions might be just generating DBL_MAX, or even + * zero. */ + +#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) +# if !defined(NV_INF) && defined(LDBL_INFINITY) +# define NV_INF LDBL_INFINITY +# endif +# if !defined(NV_INF) && defined(INFINITYL) +# define NV_INF INFINITYL +# endif #endif #if !defined(NV_INF) && defined(DBL_INFINITY) # define NV_INF (NV)DBL_INFINITY @@ -3940,17 +4220,40 @@ END_EXTERN_C #if !defined(NV_INF) && defined(INF) # define NV_INF (NV)INF #endif -#if !defined(NV_INF) && defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) -# define NV_INF (NV)HUGE_VALL +#if !defined(NV_INF) +# if INTSIZE == 4 +/* At this point we assume the IEEE 754 floating point (and of course, + * we also assume a floating point format that can encode an infinity). + * We will coerce an int32 (which will encode the infinity) into + * a 32-bit float, which will then be cast into NV. + * + * Note that we intentionally use a float and 32-bit int, instead of + * shifting a small integer into a full IV, and from that into a full + * NV, because: + * + * (1) an IV might not be wide enough to cover all the bits of an NV. + * (2) the exponent part (including the infinity and nan bits) of a NV + * might be wider than just 16 bits. + * + * Below the NV_NAN logic has similar __PL_nan_u fallback, the only + * difference being the int32 constant being coerced. */ +# define __PL_inf_float_int32 0x7F800000 +static const union { unsigned int __i; float __f; } __PL_inf_u = + { __PL_inf_float_int32 }; +# define NV_INF ((NV)(__PL_inf_u.__f)) +# endif #endif -#if !defined(NV_INF) && defined(HUGE_VAL) -# define NV_INF (NV)HUGE_VAL +#if !defined(NV_INF) +# define NV_INF ((NV)1.0/0.0) /* Some compilers will warn. */ #endif #if !defined(NV_NAN) && defined(USE_LONG_DOUBLE) # if !defined(NV_NAN) && defined(LDBL_NAN) # define NV_NAN LDBL_NAN # endif +# if !defined(NV_NAN) && defined(NANL) +# define NV_NAN NANL +# endif # if !defined(NV_NAN) && defined(LDBL_QNAN) # define NV_NAN LDBL_QNAN # endif @@ -3967,15 +4270,30 @@ END_EXTERN_C #if !defined(NV_NAN) && defined(DBL_SNAN) # define NV_NAN (NV)DBL_SNAN #endif +#if !defined(NV_NAN) && defined(NAN) +# define NV_NAN (NV)NAN +#endif #if !defined(NV_NAN) && defined(QNAN) # define NV_NAN (NV)QNAN #endif #if !defined(NV_NAN) && defined(SNAN) # define NV_NAN (NV)SNAN #endif -#if !defined(NV_NAN) && defined(NAN) -# define NV_NAN (NV)NAN +#if !defined(NV_NAN) +# if INTSIZE == 4 +/* See the discussion near __PL_inf_u. */ +# define __PL_nan_float_int32 0x7FC00000 +static const union { unsigned int __i; float __f; } __PL_nan_u = + { __PL_nan_float_int32 }; +# define NV_NAN ((NV)(__PL_nan_u.__f)) +# endif #endif +#if !defined(NV_NAN) +# define NV_NAN ((NV)0.0/0.0) /* Some compilers will warn. */ +#endif +/* Do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF). + * Though IEEE-754-logically correct, some compilers (like Visual C 2003) + * falsely misoptimize that to zero (x-x is zero, right?) */ #ifndef __cplusplus # if !defined(WIN32) && !defined(VMS) @@ -4726,6 +5044,9 @@ EXTCONST char PL_bincompat_options[] = # ifdef USE_PERLIO " USE_PERLIO" # endif +# ifdef USE_QUADMATH + " USE_QUADMATH" +# endif # ifdef USE_REENTRANT_API " USE_REENTRANT_API" # endif @@ -5498,6 +5819,18 @@ typedef struct am_table_short AMTS; #endif /* !USE_LOCALE_NUMERIC */ +#ifdef USE_QUADMATH +# define Perl_strtod(s, e) strtoflt128(s, e) +#elif defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) +# if defined(HAS_STRTOLD) +# define Perl_strtod(s, e) strtold(s, e) +# elif defined(HAS_STRTOD) +# define Perl_strtod(s, e) (NV)strtod(s, e) /* Unavoidable loss. */ +# endif +#elif defined(HAS_STRTOD) +# define Perl_strtod(s, e) strtod(s, e) +#endif + #if !defined(Strtol) && defined(USE_64_BIT_INT) && defined(IV_IS_QUAD) && \ (QUADKIND == QUAD_IS_LONG_LONG || QUADKIND == QUAD_IS___INT64) # ifdef __hpux diff --git a/perly.act b/perly.act index 61850f4..2d12b05 100644 --- a/perly.act +++ b/perly.act @@ -7,8 +7,8 @@ case 2: #line 114 "perly.y" { - PL_parser->expect = XSTATE; - } + parser->expect = XSTATE; + ;} break; case 3: @@ -16,14 +16,14 @@ case 2: { newPROG(block_end((ps[(3) - (4)].val.ival),(ps[(4) - (4)].val.opval))); (yyval.ival) = 0; - } + ;} break; case 4: #line 123 "perly.y" { parser->expect = XTERM; - } + ;} break; case 5: @@ -31,14 +31,14 @@ case 2: { PL_eval_root = (ps[(3) - (3)].val.opval); (yyval.ival) = 0; - } + ;} break; case 6: #line 132 "perly.y" { parser->expect = XBLOCK; - } + ;} break; case 7: @@ -49,14 +49,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - } + ;} break; case 8: #line 144 "perly.y" { parser->expect = XSTATE; - } + ;} break; case 9: @@ -67,14 +67,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - } + ;} break; case 10: #line 156 "perly.y" { parser->expect = XSTATE; - } + ;} break; case 11: @@ -85,14 +85,14 @@ case 2: (yyval.ival) = 0; yyunlex(); parser->yychar = YYEOF; - } + ;} break; case 12: #line 168 "perly.y" { parser->expect = XSTATE; - } + ;} break; case 13: @@ -100,46 +100,46 @@ case 2: { PL_eval_root = (ps[(3) - (3)].val.opval); (yyval.ival) = 0; - } + ;} break; case 14: #line 180 "perly.y" - { if (PL_parser->copline > (line_t)(ps[(1) - (4)].val.ival)) - PL_parser->copline = (line_t)(ps[(1) - (4)].val.ival); + { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival)) + parser->copline = (line_t)(ps[(1) - (4)].val.ival); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); - } + ;} break; case 15: #line 188 "perly.y" - { if (PL_parser->copline > (line_t)(ps[(1) - (7)].val.ival)) - PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival); + { if (parser->copline > (line_t)(ps[(1) - (7)].val.ival)) + parser->copline = (line_t)(ps[(1) - (7)].val.ival); (yyval.opval) = block_end((ps[(2) - (7)].val.ival), (ps[(5) - (7)].val.opval)); - } + ;} break; case 16: #line 195 "perly.y" - { (yyval.ival) = block_start(TRUE); } + { (yyval.ival) = block_start(TRUE); ;} break; case 17: #line 199 "perly.y" - { if (PL_parser->copline > (line_t)(ps[(1) - (4)].val.ival)) - PL_parser->copline = (line_t)(ps[(1) - (4)].val.ival); + { if (parser->copline > (line_t)(ps[(1) - (4)].val.ival)) + parser->copline = (line_t)(ps[(1) - (4)].val.ival); (yyval.opval) = block_end((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval)); - } + ;} break; case 18: #line 206 "perly.y" - { (yyval.ival) = block_start(FALSE); } + { (yyval.ival) = block_start(FALSE); ;} break; case 19: #line 211 "perly.y" - { (yyval.opval) = (OP*)NULL; } + { (yyval.opval) = (OP*)NULL; ;} break; case 20: @@ -148,12 +148,12 @@ case 2: PL_pad_reset_pending = TRUE; if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval)) PL_hints |= HINT_BLOCK_SCOPE; - } + ;} break; case 21: #line 222 "perly.y" - { (yyval.opval) = (OP*)NULL; } + { (yyval.opval) = (OP*)NULL; ;} break; case 22: @@ -162,38 +162,38 @@ case 2: PL_pad_reset_pending = TRUE; if ((ps[(1) - (2)].val.opval) && (ps[(2) - (2)].val.opval)) PL_hints |= HINT_BLOCK_SCOPE; - } + ;} break; case 23: #line 233 "perly.y" { (yyval.opval) = (ps[(1) - (1)].val.opval) ? newSTATEOP(0, NULL, (ps[(1) - (1)].val.opval)) : NULL; - } + ;} break; case 24: #line 237 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 25: #line 241 "perly.y" { (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval)); - } + ;} break; case 26: #line 245 "perly.y" { (yyval.opval) = newSTATEOP(SVf_UTF8 * (ps[(1) - (2)].val.pval)[strlen((ps[(1) - (2)].val.pval))+1], (ps[(1) - (2)].val.pval), (ps[(2) - (2)].val.opval)); - } + ;} break; case 27: #line 252 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 28: @@ -206,7 +206,7 @@ case 2: SvREFCNT_inc_simple_void(fmtcv); pad_add_anon(fmtcv, OP_NULL); } - } + ;} break; case 29: @@ -229,9 +229,9 @@ case 2: CvOUTSIDE(PL_compcv) ))[(ps[(2) - (3)].val.opval)->op_targ])) CvCLONE_on(PL_compcv); - PL_parser->in_my = 0; - PL_parser->in_my_stash = NULL; - } + parser->in_my = 0; + parser->in_my_stash = NULL; + ;} break; case 30: @@ -244,7 +244,7 @@ case 2: ; (yyval.opval) = (OP*)NULL; intro_my(); - } + ;} break; case 31: @@ -254,12 +254,12 @@ case 2: if ((ps[(2) - (4)].val.opval)) package_version((ps[(2) - (4)].val.opval)); (yyval.opval) = (OP*)NULL; - } + ;} break; case 32: #line 303 "perly.y" - { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ } + { CvSPECIAL_on(PL_compcv); /* It's a BEGIN {} */ ;} break; case 33: @@ -268,7 +268,7 @@ case 2: SvREFCNT_inc_simple_void(PL_compcv); utilize((ps[(1) - (7)].val.ival), (ps[(2) - (7)].val.ival), (ps[(4) - (7)].val.opval), (ps[(5) - (7)].val.opval), (ps[(6) - (7)].val.opval)); (yyval.opval) = (OP*)NULL; - } + ;} break; case 34: @@ -276,8 +276,8 @@ case 2: { (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); - PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (7)].val.ival); + ;} break; case 35: @@ -285,8 +285,8 @@ case 2: { (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newCONDOP(0, (ps[(4) - (7)].val.opval), op_scope((ps[(6) - (7)].val.opval)), (ps[(7) - (7)].val.opval))); - PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (7)].val.ival); + ;} break; case 36: @@ -299,18 +299,18 @@ case 2: || PAD_COMPNAME_FLAGS_isOUR(offset) ? 0 : offset)); - PL_parser->copline = (line_t)(ps[(1) - (6)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (6)].val.ival); + ;} break; case 37: #line 334 "perly.y" - { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); } + { (yyval.opval) = block_end((ps[(3) - (6)].val.ival), newWHENOP((ps[(4) - (6)].val.opval), op_scope((ps[(6) - (6)].val.opval)))); ;} break; case 38: #line 336 "perly.y" - { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); } + { (yyval.opval) = newWHENOP(0, op_scope((ps[(2) - (2)].val.opval))); ;} break; case 39: @@ -319,8 +319,8 @@ case 2: (yyval.opval) = block_end((ps[(3) - (8)].val.ival), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival))); - PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (8)].val.ival); + ;} break; case 40: @@ -329,102 +329,110 @@ case 2: (yyval.opval) = block_end((ps[(3) - (8)].val.ival), newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (ps[(4) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval), (ps[(6) - (8)].val.ival))); - PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (8)].val.ival); + ;} break; case 41: -#line 353 "perly.y" +#line 352 "perly.y" + { parser->expect = XTERM; ;} + break; + + case 42: +#line 354 "perly.y" + { parser->expect = XTERM; ;} + break; + + case 43: +#line 357 "perly.y" { - OP *initop = (ps[(4) - (11)].val.opval); + OP *initop = (ps[(4) - (13)].val.opval); OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, - scalar((ps[(6) - (11)].val.opval)), (ps[(11) - (11)].val.opval), (ps[(9) - (11)].val.opval), (ps[(8) - (11)].val.ival)); + scalar((ps[(7) - (13)].val.opval)), (ps[(13) - (13)].val.opval), (ps[(11) - (13)].val.opval), (ps[(10) - (13)].val.ival)); if (initop) { forop = op_prepend_elem(OP_LINESEQ, initop, op_append_elem(OP_LINESEQ, newOP(OP_UNSTACK, OPf_SPECIAL), forop)); } - (yyval.opval) = block_end((ps[(3) - (11)].val.ival), forop); - PL_parser->copline = (line_t)(ps[(1) - (11)].val.ival); - } + (yyval.opval) = block_end((ps[(3) - (13)].val.ival), forop); + parser->copline = (line_t)(ps[(1) - (13)].val.ival); + ;} break; - case 42: -#line 367 "perly.y" + case 44: +#line 371 "perly.y" { (yyval.opval) = block_end((ps[(3) - (9)].val.ival), newFOROP(0, (ps[(4) - (9)].val.opval), (ps[(6) - (9)].val.opval), (ps[(8) - (9)].val.opval), (ps[(9) - (9)].val.opval))); - PL_parser->copline = (line_t)(ps[(1) - (9)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (9)].val.ival); + ;} break; - case 43: -#line 372 "perly.y" + case 45: +#line 376 "perly.y" { (yyval.opval) = block_end((ps[(4) - (8)].val.ival), newFOROP(0, op_lvalue((ps[(2) - (8)].val.opval), OP_ENTERLOOP), (ps[(5) - (8)].val.opval), (ps[(7) - (8)].val.opval), (ps[(8) - (8)].val.opval))); - PL_parser->copline = (line_t)(ps[(1) - (8)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (8)].val.ival); + ;} break; - case 44: -#line 378 "perly.y" + case 46: +#line 382 "perly.y" { (yyval.opval) = block_end((ps[(3) - (7)].val.ival), newFOROP(0, (OP*)NULL, (ps[(4) - (7)].val.opval), (ps[(6) - (7)].val.opval), (ps[(7) - (7)].val.opval))); - PL_parser->copline = (line_t)(ps[(1) - (7)].val.ival); - } + parser->copline = (line_t)(ps[(1) - (7)].val.ival); + ;} break; - case 45: -#line 384 "perly.y" + case 47: +#line 388 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (OP*)NULL, (ps[(1) - (2)].val.opval), (ps[(2) - (2)].val.opval), 0); - } + ;} break; - case 46: -#line 390 "perly.y" + case 48: +#line 394 "perly.y" { package((ps[(3) - (5)].val.opval)); if ((ps[(2) - (5)].val.opval)) { package_version((ps[(2) - (5)].val.opval)); } - } + ;} break; - case 47: -#line 397 "perly.y" + case 49: +#line 401 "perly.y" { /* a block is a loop that happens once */ (yyval.opval) = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (OP*)NULL, block_end((ps[(5) - (8)].val.ival), (ps[(7) - (8)].val.opval)), (OP*)NULL, 0); - if (PL_parser->copline > (line_t)(ps[(4) - (8)].val.ival)) - PL_parser->copline = (line_t)(ps[(4) - (8)].val.ival); - } + if (parser->copline > (line_t)(ps[(4) - (8)].val.ival)) + parser->copline = (line_t)(ps[(4) - (8)].val.ival); + ;} break; - case 48: -#line 405 "perly.y" + case 50: +#line 409 "perly.y" { - PL_parser->expect = XSTATE; (yyval.opval) = (ps[(1) - (2)].val.opval); - } + ;} break; - case 49: -#line 410 "perly.y" + case 51: +#line 413 "perly.y" { - PL_parser->expect = XSTATE; (yyval.opval) = (OP*)NULL; - PL_parser->copline = NOLINE; - } + parser->copline = NOLINE; + ;} break; - case 50: -#line 419 "perly.y" + case 52: +#line 421 "perly.y" { OP *list; if ((ps[(2) - (2)].val.opval)) { OP *term = (ps[(2) - (2)].val.opval); @@ -433,202 +441,202 @@ case 2: else { list = (ps[(1) - (2)].val.opval); } - if (PL_parser->copline == NOLINE) - PL_parser->copline = CopLINE(PL_curcop)-1; - else PL_parser->copline--; + if (parser->copline == NOLINE) + parser->copline = CopLINE(PL_curcop)-1; + else parser->copline--; (yyval.opval) = newSTATEOP(0, NULL, convert(OP_FORMLINE, 0, list)); - } - break; - - case 51: -#line 436 "perly.y" - { (yyval.opval) = NULL; } - break; - - case 52: -#line 438 "perly.y" - { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); } + ;} break; case 53: -#line 443 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 438 "perly.y" + { (yyval.opval) = NULL; ;} break; case 54: -#line 445 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 440 "perly.y" + { (yyval.opval) = op_unscope((ps[(2) - (3)].val.opval)); ;} break; case 55: -#line 447 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } +#line 445 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 56: -#line 449 "perly.y" - { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } +#line 447 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 57: -#line 451 "perly.y" - { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); } +#line 449 "perly.y" + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} break; case 58: -#line 453 "perly.y" - { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); } +#line 451 "perly.y" + { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} break; case 59: -#line 455 "perly.y" - { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL); - PL_parser->copline = (line_t)(ps[(2) - (3)].val.ival); } +#line 453 "perly.y" + { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, scalar((ps[(3) - (3)].val.opval)), (ps[(1) - (3)].val.opval)); ;} break; case 60: -#line 458 "perly.y" - { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); } +#line 455 "perly.y" + { (yyval.opval) = newLOOPOP(OPf_PARENS, 1, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval)); ;} break; case 61: -#line 463 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 457 "perly.y" + { (yyval.opval) = newFOROP(0, (OP*)NULL, (ps[(3) - (3)].val.opval), (ps[(1) - (3)].val.opval), (OP*)NULL); + parser->copline = (line_t)(ps[(2) - (3)].val.ival); ;} break; case 62: +#line 460 "perly.y" + { (yyval.opval) = newWHENOP((ps[(3) - (3)].val.opval), op_scope((ps[(1) - (3)].val.opval))); ;} + break; + + case 63: #line 465 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} + break; + + case 64: +#line 467 "perly.y" { ((ps[(2) - (2)].val.opval))->op_flags |= OPf_PARENS; (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); - } + ;} break; - case 63: -#line 470 "perly.y" - { PL_parser->copline = (line_t)(ps[(1) - (6)].val.ival); + case 65: +#line 472 "perly.y" + { parser->copline = (line_t)(ps[(1) - (6)].val.ival); (yyval.opval) = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,(ps[(3) - (6)].val.opval)), op_scope((ps[(5) - (6)].val.opval)), (ps[(6) - (6)].val.opval)); PL_hints |= HINT_BLOCK_SCOPE; - } + ;} break; - case 64: -#line 480 "perly.y" - { (yyval.opval) = (OP*)NULL; } + case 66: +#line 482 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; - case 65: -#line 482 "perly.y" - { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); } + case 67: +#line 484 "perly.y" + { (yyval.opval) = op_scope((ps[(2) - (2)].val.opval)); ;} break; - case 66: -#line 487 "perly.y" + case 68: +#line 489 "perly.y" { (yyval.ival) = (PL_min_intro_pending && PL_max_intro_pending >= PL_min_intro_pending); - intro_my(); } - break; - - case 67: -#line 493 "perly.y" - { (yyval.opval) = (OP*)NULL; } + intro_my(); ;} break; case 69: -#line 499 "perly.y" - { YYSTYPE tmplval; - (void)scan_num("1", &tmplval); - (yyval.opval) = tmplval.opval; } +#line 495 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 71: -#line 507 "perly.y" - { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); } - break; - - case 72: -#line 512 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } +#line 501 "perly.y" + { YYSTYPE tmplval; + (void)scan_num("1", &tmplval); + (yyval.opval) = tmplval.opval; ;} break; case 73: -#line 516 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } +#line 509 "perly.y" + { (yyval.opval) = invert(scalar((ps[(1) - (1)].val.opval))); ;} break; case 74: -#line 520 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); } +#line 514 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} break; case 75: -#line 523 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 518 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} break; case 76: -#line 524 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 522 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); intro_my(); ;} break; case 77: -#line 528 "perly.y" - { (yyval.ival) = start_subparse(FALSE, 0); - SAVEFREESV(PL_compcv); } +#line 525 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 78: -#line 534 "perly.y" - { (yyval.ival) = start_subparse(FALSE, CVf_ANON); - SAVEFREESV(PL_compcv); } +#line 526 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 79: -#line 539 "perly.y" - { (yyval.ival) = start_subparse(TRUE, 0); - SAVEFREESV(PL_compcv); } +#line 530 "perly.y" + { (yyval.ival) = start_subparse(FALSE, 0); + SAVEFREESV(PL_compcv); ;} break; - case 82: -#line 550 "perly.y" - { (yyval.opval) = (OP*)NULL; } + case 80: +#line 536 "perly.y" + { (yyval.ival) = start_subparse(FALSE, CVf_ANON); + SAVEFREESV(PL_compcv); ;} break; - case 84: -#line 556 "perly.y" - { (yyval.opval) = (OP*)NULL; } + case 81: +#line 541 "perly.y" + { (yyval.ival) = start_subparse(TRUE, 0); + SAVEFREESV(PL_compcv); ;} break; - case 85: -#line 558 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); } + case 84: +#line 552 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 86: -#line 560 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 558 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 87: -#line 565 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); } +#line 560 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} break; case 88: -#line 567 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 562 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 89: -#line 571 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 567 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} break; case 90: +#line 569 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} + break; + + case 91: #line 573 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} + break; + + case 92: +#line 575 "perly.y" { if (!FEATURE_SIGNATURES_IS_ENABLED) Perl_croak(aTHX_ "Experimental " @@ -637,343 +645,334 @@ case 2: packWARN(WARN_EXPERIMENTAL__SIGNATURES), "The signatures feature is experimental"); (yyval.opval) = parse_subsignature(); - } + ;} break; - case 91: -#line 583 "perly.y" + case 93: +#line 585 "perly.y" { (yyval.opval) = op_append_list(OP_LINESEQ, (ps[(2) - (3)].val.opval), newSTATEOP(0, NULL, sawparens(newNULLLIST()))); - PL_parser->expect = XBLOCK; - } + parser->expect = XBLOCK; + ;} break; - case 92: -#line 592 "perly.y" + case 94: +#line 594 "perly.y" { - if (PL_parser->copline > (line_t)(ps[(3) - (5)].val.ival)) - PL_parser->copline = (line_t)(ps[(3) - (5)].val.ival); + if (parser->copline > (line_t)(ps[(3) - (5)].val.ival)) + parser->copline = (line_t)(ps[(3) - (5)].val.ival); (yyval.opval) = block_end((ps[(1) - (5)].val.ival), op_append_list(OP_LINESEQ, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval))); - } + ;} break; - case 93: -#line 601 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } + case 95: +#line 603 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 94: -#line 602 "perly.y" - { (yyval.opval) = (OP*)NULL; - PL_parser->expect = XSTATE; - } + case 96: +#line 604 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; - case 95: + case 97: #line 609 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; - case 96: + case 98: #line 611 "perly.y" - { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } + { (yyval.opval) = newLOGOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; - case 97: + case 99: #line 613 "perly.y" - { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } + { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; - case 99: + case 101: #line 619 "perly.y" - { (yyval.opval) = (ps[(1) - (2)].val.opval); } + { (yyval.opval) = (ps[(1) - (2)].val.opval); ;} break; - case 100: + case 102: #line 621 "perly.y" { OP* term = (ps[(3) - (3)].val.opval); (yyval.opval) = op_append_elem(OP_LIST, (ps[(1) - (3)].val.opval), term); - } + ;} break; - case 102: + case 104: #line 630 "perly.y" { (yyval.opval) = convert((ps[(1) - (3)].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (3)].val.ival),(ps[(2) - (3)].val.opval)), (ps[(3) - (3)].val.opval)) ); - } + ;} break; - case 103: + case 105: #line 634 "perly.y" { (yyval.opval) = convert((ps[(1) - (5)].val.ival), OPf_STACKED, op_prepend_elem(OP_LIST, newGVREF((ps[(1) - (5)].val.ival),(ps[(3) - (5)].val.opval)), (ps[(4) - (5)].val.opval)) ); - } + ;} break; - case 104: + case 106: #line 638 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, scalar((ps[(1) - (6)].val.opval)), (ps[(5) - (6)].val.opval)), newUNOP(OP_METHOD, 0, (ps[(3) - (6)].val.opval)))); - } + ;} break; - case 105: + case 107: #line 644 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, scalar((ps[(1) - (3)].val.opval)), newUNOP(OP_METHOD, 0, (ps[(3) - (3)].val.opval)))); - } + ;} break; - case 106: + case 108: #line 649 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (3)].val.opval), (ps[(3) - (3)].val.opval)), newUNOP(OP_METHOD, 0, (ps[(1) - (3)].val.opval)))); - } + ;} break; - case 107: + case 109: #line 655 "perly.y" { (yyval.opval) = convert(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(2) - (5)].val.opval), (ps[(4) - (5)].val.opval)), newUNOP(OP_METHOD, 0, (ps[(1) - (5)].val.opval)))); - } + ;} break; - case 108: + case 110: #line 661 "perly.y" - { (yyval.opval) = convert((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } + { (yyval.opval) = convert((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} break; - case 109: + case 111: #line 663 "perly.y" - { (yyval.opval) = convert((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); } + { (yyval.opval) = convert((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;} break; - case 110: + case 112: #line 665 "perly.y" { SvREFCNT_inc_simple_void(PL_compcv); - (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); } + (yyval.opval) = newANONATTRSUB((ps[(2) - (3)].val.ival), 0, (OP*)NULL, (ps[(3) - (3)].val.opval)); ;} break; - case 111: + case 113: #line 668 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, op_prepend_elem(OP_LIST, (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)), (ps[(1) - (5)].val.opval))); - } + ;} break; - case 114: + case 116: #line 683 "perly.y" - { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); - PL_parser->expect = XOPERATOR; - } + { (yyval.opval) = newBINOP(OP_GELEM, 0, (ps[(1) - (5)].val.opval), scalar((ps[(3) - (5)].val.opval))); ;} break; - case 115: -#line 687 "perly.y" + case 117: +#line 685 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, oopsAV((ps[(1) - (4)].val.opval)), scalar((ps[(3) - (4)].val.opval))); - } + ;} break; - case 116: -#line 690 "perly.y" + case 118: +#line 688 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (5)].val.opval)),OP_RV2AV), scalar((ps[(4) - (5)].val.opval))); - } + ;} break; - case 117: -#line 695 "perly.y" + case 119: +#line 693 "perly.y" { (yyval.opval) = newBINOP(OP_AELEM, 0, ref(newAVREF((ps[(1) - (4)].val.opval)),OP_RV2AV), scalar((ps[(3) - (4)].val.opval))); - } + ;} break; - case 118: -#line 700 "perly.y" + case 120: +#line 698 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, oopsHV((ps[(1) - (5)].val.opval)), jmaybe((ps[(3) - (5)].val.opval))); - PL_parser->expect = XOPERATOR; - } + ;} break; - case 119: -#line 704 "perly.y" + case 121: +#line 701 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (6)].val.opval)),OP_RV2HV), - jmaybe((ps[(4) - (6)].val.opval))); - PL_parser->expect = XOPERATOR; - } + jmaybe((ps[(4) - (6)].val.opval))); ;} break; - case 120: -#line 710 "perly.y" + case 122: +#line 705 "perly.y" { (yyval.opval) = newBINOP(OP_HELEM, 0, ref(newHVREF((ps[(1) - (5)].val.opval)),OP_RV2HV), - jmaybe((ps[(3) - (5)].val.opval))); - PL_parser->expect = XOPERATOR; - } - break; - - case 121: -#line 716 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); } - break; - - case 122: -#line 719 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval), - newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); } + jmaybe((ps[(3) - (5)].val.opval))); ;} break; case 123: -#line 724 "perly.y" +#line 709 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), - newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); } + newCVREF(0, scalar((ps[(1) - (4)].val.opval)))); ;} break; case 124: -#line 728 "perly.y" +#line 712 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); } + op_append_elem(OP_LIST, (ps[(4) - (5)].val.opval), + newCVREF(0, scalar((ps[(1) - (5)].val.opval))))); ;} break; case 125: -#line 731 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); } +#line 717 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, + op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), + newCVREF(0, scalar((ps[(1) - (4)].val.opval))))); ;} break; case 126: -#line 733 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); } +#line 721 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, + newCVREF(0, scalar((ps[(1) - (3)].val.opval)))); ;} break; case 127: -#line 735 "perly.y" - { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); } +#line 724 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(5) - (6)].val.opval), (ps[(2) - (6)].val.opval)); ;} break; case 128: -#line 740 "perly.y" - { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); } +#line 726 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(3) - (4)].val.opval), (ps[(1) - (4)].val.opval)); ;} break; case 129: -#line 742 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 728 "perly.y" + { (yyval.opval) = newSLICEOP(0, (ps[(4) - (5)].val.opval), (OP*)NULL); ;} break; case 130: -#line 744 "perly.y" - { if ((ps[(2) - (3)].val.ival) != OP_REPEAT) - scalar((ps[(1) - (3)].val.opval)); - (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval))); - } +#line 733 "perly.y" + { (yyval.opval) = newASSIGNOP(OPf_STACKED, (ps[(1) - (3)].val.opval), (ps[(2) - (3)].val.ival), (ps[(3) - (3)].val.opval)); ;} break; case 131: -#line 749 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 735 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 132: -#line 751 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 737 "perly.y" + { if ((ps[(2) - (3)].val.ival) != OP_REPEAT) + scalar((ps[(1) - (3)].val.opval)); + (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, (ps[(1) - (3)].val.opval), scalar((ps[(3) - (3)].val.opval))); + ;} break; case 133: -#line 753 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 742 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 134: -#line 755 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 744 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 135: -#line 757 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 746 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 136: -#line 759 "perly.y" - { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 748 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 137: -#line 761 "perly.y" - { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); } +#line 750 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 138: -#line 763 "perly.y" - { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } +#line 752 "perly.y" + { (yyval.opval) = newBINOP((ps[(2) - (3)].val.ival), 0, scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 139: -#line 765 "perly.y" - { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } +#line 754 "perly.y" + { (yyval.opval) = newRANGE((ps[(2) - (3)].val.ival), scalar((ps[(1) - (3)].val.opval)), scalar((ps[(3) - (3)].val.opval))); ;} break; case 140: -#line 767 "perly.y" - { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } +#line 756 "perly.y" + { (yyval.opval) = newLOGOP(OP_AND, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; case 141: -#line 769 "perly.y" - { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); } +#line 758 "perly.y" + { (yyval.opval) = newLOGOP(OP_OR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; case 142: -#line 774 "perly.y" - { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); } +#line 760 "perly.y" + { (yyval.opval) = newLOGOP(OP_DOR, 0, (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; case 143: -#line 776 "perly.y" - { (yyval.opval) = (ps[(2) - (2)].val.opval); } +#line 762 "perly.y" + { (yyval.opval) = bind_match((ps[(2) - (3)].val.ival), (ps[(1) - (3)].val.opval), (ps[(3) - (3)].val.opval)); ;} break; case 144: -#line 779 "perly.y" - { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); } +#line 767 "perly.y" + { (yyval.opval) = newUNOP(OP_NEGATE, 0, scalar((ps[(2) - (2)].val.opval))); ;} break; case 145: -#line 781 "perly.y" - { (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); } +#line 769 "perly.y" + { (yyval.opval) = (ps[(2) - (2)].val.opval); ;} break; case 146: -#line 783 "perly.y" - { (yyval.opval) = newUNOP(OP_POSTINC, 0, - op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); } +#line 772 "perly.y" + { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;} break; case 147: -#line 786 "perly.y" - { (yyval.opval) = newUNOP(OP_POSTDEC, 0, - op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));} +#line 774 "perly.y" + { (yyval.opval) = newUNOP(OP_COMPLEMENT, 0, scalar((ps[(2) - (2)].val.opval))); ;} break; case 148: -#line 789 "perly.y" +#line 776 "perly.y" + { (yyval.opval) = newUNOP(OP_POSTINC, 0, + op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTINC)); ;} + break; + + case 149: +#line 779 "perly.y" + { (yyval.opval) = newUNOP(OP_POSTDEC, 0, + op_lvalue(scalar((ps[(1) - (2)].val.opval)), OP_POSTDEC));;} + break; + + case 150: +#line 782 "perly.y" { (yyval.opval) = convert(OP_JOIN, 0, op_append_elem( OP_LIST, @@ -983,124 +982,124 @@ case 2: )), (ps[(1) - (2)].val.opval) )); - } - break; - - case 149: -#line 800 "perly.y" - { (yyval.opval) = newUNOP(OP_PREINC, 0, - op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); } - break; - - case 150: -#line 803 "perly.y" - { (yyval.opval) = newUNOP(OP_PREDEC, 0, - op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); } + ;} break; case 151: -#line 810 "perly.y" - { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); } +#line 793 "perly.y" + { (yyval.opval) = newUNOP(OP_PREINC, 0, + op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREINC)); ;} break; case 152: -#line 812 "perly.y" - { (yyval.opval) = newANONLIST((OP*)NULL);} +#line 796 "perly.y" + { (yyval.opval) = newUNOP(OP_PREDEC, 0, + op_lvalue(scalar((ps[(2) - (2)].val.opval)), OP_PREDEC)); ;} break; case 153: -#line 814 "perly.y" - { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); } +#line 803 "perly.y" + { (yyval.opval) = newANONLIST((ps[(2) - (3)].val.opval)); ;} break; case 154: -#line 816 "perly.y" - { (yyval.opval) = newANONHASH((OP*)NULL); } +#line 805 "perly.y" + { (yyval.opval) = newANONLIST((OP*)NULL);;} break; case 155: -#line 818 "perly.y" - { SvREFCNT_inc_simple_void(PL_compcv); - (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); } +#line 807 "perly.y" + { (yyval.opval) = newANONHASH((ps[(2) - (4)].val.opval)); ;} break; case 156: -#line 825 "perly.y" - { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));} +#line 809 "perly.y" + { (yyval.opval) = newANONHASH((OP*)NULL); ;} break; case 157: -#line 827 "perly.y" - { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));} +#line 811 "perly.y" + { SvREFCNT_inc_simple_void(PL_compcv); + (yyval.opval) = newANONATTRSUB((ps[(2) - (5)].val.ival), (ps[(3) - (5)].val.opval), (ps[(4) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;} break; - case 162: -#line 835 "perly.y" - { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); } + case 158: +#line 818 "perly.y" + { (yyval.opval) = dofile((ps[(2) - (2)].val.opval), (ps[(1) - (2)].val.ival));;} break; - case 163: -#line 837 "perly.y" - { (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN)); } + case 159: +#line 820 "perly.y" + { (yyval.opval) = newUNOP(OP_NULL, OPf_SPECIAL, op_scope((ps[(2) - (2)].val.opval)));;} break; case 164: -#line 839 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 828 "perly.y" + { (yyval.opval) = newCONDOP(0, (ps[(1) - (5)].val.opval), (ps[(3) - (5)].val.opval), (ps[(5) - (5)].val.opval)); ;} break; case 165: -#line 841 "perly.y" - { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); } +#line 830 "perly.y" + { (yyval.opval) = newUNOP(OP_REFGEN, 0, op_lvalue((ps[(2) - (2)].val.opval),OP_REFGEN)); ;} break; case 166: -#line 843 "perly.y" - { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); } +#line 832 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 167: -#line 845 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 834 "perly.y" + { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;} break; case 168: -#line 847 "perly.y" - { (yyval.opval) = sawparens(newNULLLIST()); } +#line 836 "perly.y" + { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;} break; case 169: -#line 849 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 838 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 170: -#line 851 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 840 "perly.y" + { (yyval.opval) = sawparens(newNULLLIST()); ;} break; case 171: -#line 853 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 842 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 172: -#line 855 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 844 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 173: -#line 857 "perly.y" - { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));} +#line 846 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 174: -#line 859 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 848 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 175: -#line 861 "perly.y" +#line 850 "perly.y" + { (yyval.opval) = newUNOP(OP_AV2ARYLEN, 0, ref((ps[(1) - (1)].val.opval), OP_AV2ARYLEN));;} + break; + + case 176: +#line 852 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + case 177: +#line 854 "perly.y" { (yyval.opval) = op_prepend_elem(OP_ASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_ASLICE, 0, @@ -1109,11 +1108,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (4)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING; - } + ;} break; - case 176: -#line 871 "perly.y" + case 178: +#line 864 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVASLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVASLICE, 0, @@ -1122,11 +1121,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (4)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (4)].val.opval)->op_private & OPpSLICEWARNING; - } + ;} break; - case 177: -#line 881 "perly.y" + case 179: +#line 874 "perly.y" { (yyval.opval) = op_prepend_elem(OP_HSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_HSLICE, 0, @@ -1135,12 +1134,11 @@ case 2: if ((yyval.opval) && (ps[(1) - (5)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING; - PL_parser->expect = XOPERATOR; - } + ;} break; - case 178: -#line 892 "perly.y" + case 180: +#line 884 "perly.y" { (yyval.opval) = op_prepend_elem(OP_KVHSLICE, newOP(OP_PUSHMARK, 0), newLISTOP(OP_KVHSLICE, 0, @@ -1149,158 +1147,157 @@ case 2: if ((yyval.opval) && (ps[(1) - (5)].val.opval)) (yyval.opval)->op_private |= (ps[(1) - (5)].val.opval)->op_private & OPpSLICEWARNING; - PL_parser->expect = XOPERATOR; - } + ;} break; - case 179: -#line 903 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } + case 181: +#line 894 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; - case 180: -#line 905 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); } + case 182: +#line 896 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, scalar((ps[(1) - (1)].val.opval))); ;} break; - case 181: -#line 907 "perly.y" + case 183: +#line 898 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (3)].val.opval))); - } + ;} break; - case 182: -#line 910 "perly.y" + case 184: +#line 901 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(3) - (4)].val.opval), scalar((ps[(1) - (4)].val.opval)))); - } + ;} break; - case 183: -#line 915 "perly.y" + case 185: +#line 906 "perly.y" { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, (ps[(3) - (3)].val.opval), scalar((ps[(2) - (3)].val.opval)))); - } - break; - - case 184: -#line 919 "perly.y" - { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); } - break; - - case 185: -#line 921 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); } + ;} break; case 186: -#line 923 "perly.y" - { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); } +#line 910 "perly.y" + { (yyval.opval) = newSVREF((ps[(1) - (4)].val.opval)); ;} break; case 187: -#line 925 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, - scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); } +#line 912 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;} break; case 188: -#line 928 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); } +#line 914 "perly.y" + { (yyval.opval) = newHVREF((ps[(1) - (4)].val.opval)); ;} break; case 189: -#line 930 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL); - PL_hints |= HINT_BLOCK_SCOPE; } +#line 916 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, 0, + scalar(newCVREF((ps[(3) - (4)].val.ival),(ps[(1) - (4)].val.opval)))); ;} break; case 190: -#line 933 "perly.y" - { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); } +#line 919 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(1) - (4)].val.opval)); ;} break; case 191: -#line 935 "perly.y" - { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); } +#line 921 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), OPf_SPECIAL); + PL_hints |= HINT_BLOCK_SCOPE; ;} break; case 192: -#line 937 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); } +#line 924 "perly.y" + { (yyval.opval) = newLOOPEX((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;} break; case 193: -#line 939 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } +#line 926 "perly.y" + { (yyval.opval) = newUNOP(OP_NOT, 0, scalar((ps[(2) - (2)].val.opval))); ;} break; case 194: -#line 941 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); } +#line 928 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;} break; case 195: -#line 943 "perly.y" - { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); } +#line 930 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} break; case 196: -#line 945 "perly.y" - { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); } +#line 932 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (2)].val.ival), 0, (ps[(2) - (2)].val.opval)); ;} break; case 197: -#line 947 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); } +#line 934 "perly.y" + { (yyval.opval) = newOP(OP_REQUIRE, (ps[(1) - (1)].val.ival) ? OPf_SPECIAL : 0); ;} break; case 198: -#line 949 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, - op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); } +#line 936 "perly.y" + { (yyval.opval) = newUNOP(OP_REQUIRE, (ps[(1) - (2)].val.ival) ? OPf_SPECIAL : 0, (ps[(2) - (2)].val.opval)); ;} break; case 199: -#line 952 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); } +#line 938 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} break; case 200: -#line 954 "perly.y" - { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);} +#line 940 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, + op_append_elem(OP_LIST, (ps[(2) - (2)].val.opval), scalar((ps[(1) - (2)].val.opval)))); ;} break; case 201: -#line 956 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 943 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (1)].val.ival), 0); ;} break; case 202: -#line 958 "perly.y" - { (yyval.opval) = (ps[(1) - (3)].val.opval); } +#line 945 "perly.y" + { (yyval.opval) = newOP((ps[(1) - (3)].val.ival), 0);;} break; case 203: -#line 960 "perly.y" - { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); } +#line 947 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 204: -#line 962 "perly.y" - { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT) - ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0))) - : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); } +#line 949 "perly.y" + { (yyval.opval) = (ps[(1) - (3)].val.opval); ;} break; case 205: -#line 966 "perly.y" - { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); } +#line 951 "perly.y" + { (yyval.opval) = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar((ps[(1) - (1)].val.opval))); ;} break; case 206: -#line 968 "perly.y" +#line 953 "perly.y" + { (yyval.opval) = ((ps[(1) - (3)].val.ival) == OP_NOT) + ? newUNOP((ps[(1) - (3)].val.ival), 0, newSVOP(OP_CONST, 0, newSViv(0))) + : newOP((ps[(1) - (3)].val.ival), OPf_SPECIAL); ;} + break; + + case 207: +#line 957 "perly.y" + { (yyval.opval) = newUNOP((ps[(1) - (4)].val.ival), 0, (ps[(3) - (4)].val.opval)); ;} + break; + + case 208: +#line 959 "perly.y" { if ( (ps[(1) - (1)].val.opval)->op_type != OP_TRANS && (ps[(1) - (1)].val.opval)->op_type != OP_TRANSR @@ -1310,160 +1307,163 @@ case 2: SAVEFREESV(PL_compcv); } else (yyval.ival) = 0; - } + ;} break; - case 207: -#line 979 "perly.y" - { (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival)); } + case 209: +#line 970 "perly.y" + { (yyval.opval) = pmruntime((ps[(1) - (5)].val.opval), (ps[(4) - (5)].val.opval), 1, (ps[(2) - (5)].val.ival)); ;} break; - case 210: -#line 983 "perly.y" + case 212: +#line 974 "perly.y" { (yyval.opval) = newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0), newSVOP(OP_CONST, 0, newSVpvs("Unimplemented"))); - } - break; - - case 212: -#line 992 "perly.y" - { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); } - break; - - case 213: -#line 994 "perly.y" - { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); } + ;} break; case 214: -#line 999 "perly.y" - { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); } +#line 983 "perly.y" + { (yyval.opval) = my_attrs((ps[(2) - (3)].val.opval),(ps[(3) - (3)].val.opval)); ;} break; case 215: -#line 1001 "perly.y" - { (yyval.opval) = sawparens(newNULLLIST()); } +#line 985 "perly.y" + { (yyval.opval) = localize((ps[(2) - (2)].val.opval),(ps[(1) - (2)].val.ival)); ;} break; case 216: -#line 1004 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 990 "perly.y" + { (yyval.opval) = sawparens((ps[(2) - (3)].val.opval)); ;} break; case 217: -#line 1006 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 992 "perly.y" + { (yyval.opval) = sawparens(newNULLLIST()); ;} break; case 218: -#line 1008 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 995 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 219: -#line 1013 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 997 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 220: -#line 1015 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 999 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 221: -#line 1019 "perly.y" - { (yyval.opval) = (OP*)NULL; } +#line 1004 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 222: -#line 1021 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 1006 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 223: -#line 1027 "perly.y" - { PL_parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); } +#line 1010 "perly.y" + { (yyval.opval) = (OP*)NULL; ;} break; case 224: -#line 1031 "perly.y" - { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); } +#line 1012 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} break; case 225: -#line 1035 "perly.y" - { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); } +#line 1018 "perly.y" + { parser->in_my = 0; (yyval.opval) = my((ps[(1) - (1)].val.opval)); ;} break; case 226: -#line 1039 "perly.y" - { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); - if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); - } +#line 1022 "perly.y" + { (yyval.opval) = newCVREF((ps[(1) - (2)].val.ival),(ps[(2) - (2)].val.opval)); ;} break; case 227: -#line 1045 "perly.y" - { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval)); - if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); - } +#line 1026 "perly.y" + { (yyval.opval) = newSVREF((ps[(2) - (2)].val.opval)); ;} break; case 228: -#line 1051 "perly.y" - { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); } +#line 1030 "perly.y" + { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); + if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); + ;} break; case 229: -#line 1053 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); } +#line 1036 "perly.y" + { (yyval.opval) = newHVREF((ps[(2) - (2)].val.opval)); + if ((yyval.opval)) (yyval.opval)->op_private |= (ps[(1) - (2)].val.ival); + ;} break; case 230: -#line 1057 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); } +#line 1042 "perly.y" + { (yyval.opval) = newAVREF((ps[(2) - (2)].val.opval)); ;} + break; + + case 231: +#line 1044 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (4)].val.opval)); ;} break; case 232: -#line 1062 "perly.y" - { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); } +#line 1048 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(2) - (2)].val.opval)); ;} break; case 234: -#line 1067 "perly.y" - { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); } +#line 1053 "perly.y" + { (yyval.opval) = newAVREF((ps[(1) - (3)].val.opval)); ;} break; case 236: -#line 1072 "perly.y" - { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); } - break; - - case 237: -#line 1077 "perly.y" - { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); } +#line 1058 "perly.y" + { (yyval.opval) = newHVREF((ps[(1) - (3)].val.opval)); ;} break; case 238: -#line 1079 "perly.y" - { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); } +#line 1063 "perly.y" + { (yyval.opval) = newGVREF(0,(ps[(1) - (3)].val.opval)); ;} break; case 239: -#line 1081 "perly.y" - { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); } +#line 1068 "perly.y" + { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} break; case 240: -#line 1084 "perly.y" - { (yyval.opval) = (ps[(1) - (1)].val.opval); } +#line 1070 "perly.y" + { (yyval.opval) = scalar((ps[(1) - (1)].val.opval)); ;} + break; + + case 241: +#line 1072 "perly.y" + { (yyval.opval) = op_scope((ps[(1) - (1)].val.opval)); ;} break; + case 242: +#line 1075 "perly.y" + { (yyval.opval) = (ps[(1) - (1)].val.opval); ;} + break; + + +/* Line 1267 of yacc.c. */ + default: break; /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.h b/perly.h index cd92798..395ff5a 100644 --- a/perly.h +++ b/perly.h @@ -5,24 +5,27 @@ */ #ifdef PERL_CORE -/* A Bison parser, made by GNU Bison 2.7.12-4996. */ +/* A Bison parser, made by GNU Bison 2.3. */ -/* Bison interface for Yacc-like parsers in C - - Copyright (C) 1984, 1989-1990, 2000-2013 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify +/* Skeleton interface for Bison's Yacc-like parsers in C + + Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - + the Free Software Foundation; either version 2, or (at your option) + any later version. + This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. - + You should have received a copy of the GNU General Public License - along with this program. If not, see . */ + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301, USA. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work @@ -33,18 +36,10 @@ special exception, which will cause the skeleton and the resulting Bison output files to be licensed under the GNU General Public License without this special exception. - + This special exception was added by the Free Software Foundation in version 2.2 of Bison. */ -/* Enabling traces. */ -#ifndef YYDEBUG -# define YYDEBUG 0 -#endif -#if YYDEBUG -extern int yydebug; -#endif - /* Tokens. */ #ifndef YYTOKENTYPE # define YYTOKENTYPE @@ -133,7 +128,6 @@ extern int yydebug; ARROW = 337 }; #endif - /* Tokens. */ #define GRAMPROG 258 #define GRAMEXPR 259 @@ -217,6 +211,8 @@ extern int yydebug; #define ARROW 337 + + #ifdef PERL_IN_TOKE_C static bool S_is_opval_token(int type) { @@ -243,39 +239,23 @@ S_is_opval_token(int type) { #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED typedef union YYSTYPE { -/* Line 2053 of yacc.c */ - I32 ival; /* __DEFAULT__ (marker for regen_perly.pl; must always be 1st union member) */ char *pval; OP *opval; GV *gvval; - - -/* Line 2053 of yacc.c */ -} YYSTYPE; -# define YYSTYPE_IS_TRIVIAL 1 +} +/* Line 1529 of yacc.c. */ + YYSTYPE; # define yystype YYSTYPE /* obsolescent; will be withdrawn */ # define YYSTYPE_IS_DECLARED 1 +# define YYSTYPE_IS_TRIVIAL 1 #endif -#ifdef YYPARSE_PARAM -#if defined __STDC__ || defined __cplusplus -int yyparse (void *YYPARSE_PARAM); -#else -int yyparse (); -#endif -#else /* ! YYPARSE_PARAM */ -#if defined __STDC__ || defined __cplusplus -int yyparse (void); -#else -int yyparse (); -#endif -#endif /* ! YYPARSE_PARAM */ /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.tab b/perly.tab index bd3a25c..76cef4b 100644 --- a/perly.tab +++ b/perly.tab @@ -11,11 +11,11 @@ /* YYNTOKENS -- Number of terminals. */ #define YYNTOKENS 104 /* YYNNTS -- Number of nonterminals. */ -#define YYNNTS 72 +#define YYNNTS 74 /* YYNRULES -- Number of rules. */ -#define YYNRULES 240 +#define YYNRULES 242 /* YYNRULES -- Number of states. */ -#define YYNSTATES 474 +#define YYNSTATES 476 /* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ #define YYUNDEFTOK 2 @@ -72,115 +72,116 @@ static const yytype_uint16 yyprhs[] = 24, 25, 29, 30, 34, 39, 47, 48, 53, 54, 55, 58, 59, 62, 64, 66, 69, 72, 74, 79, 80, 88, 93, 94, 102, 110, 118, 125, 132, 135, - 144, 153, 165, 175, 184, 192, 195, 196, 205, 208, - 210, 213, 214, 218, 220, 222, 226, 230, 234, 238, - 242, 246, 247, 250, 257, 258, 261, 262, 263, 265, - 266, 268, 270, 272, 274, 276, 278, 279, 280, 281, - 282, 284, 286, 287, 289, 290, 293, 295, 298, 300, - 301, 302, 306, 312, 314, 316, 320, 324, 328, 330, - 333, 337, 339, 343, 349, 356, 360, 364, 370, 373, - 378, 379, 385, 387, 389, 395, 400, 406, 411, 417, - 424, 430, 435, 441, 446, 450, 457, 462, 468, 472, - 476, 480, 484, 488, 492, 496, 500, 504, 508, 512, - 516, 520, 524, 527, 530, 533, 536, 539, 542, 545, - 548, 551, 555, 558, 563, 567, 573, 576, 579, 581, - 583, 585, 587, 593, 596, 598, 601, 605, 607, 610, - 612, 614, 616, 618, 620, 622, 627, 632, 638, 644, - 646, 648, 652, 657, 661, 666, 671, 676, 681, 686, - 688, 691, 694, 696, 699, 702, 704, 707, 709, 712, - 714, 718, 720, 724, 726, 730, 735, 736, 742, 744, - 746, 748, 750, 754, 757, 761, 764, 766, 768, 770, - 771, 773, 774, 776, 778, 781, 784, 787, 790, 793, - 798, 801, 803, 807, 809, 813, 815, 819, 821, 823, - 825 + 144, 153, 154, 155, 169, 179, 188, 196, 199, 200, + 209, 212, 214, 217, 218, 222, 224, 226, 230, 234, + 238, 242, 246, 250, 251, 254, 261, 262, 265, 266, + 267, 269, 270, 272, 274, 276, 278, 280, 282, 283, + 284, 285, 286, 288, 290, 291, 293, 294, 297, 299, + 302, 304, 305, 306, 310, 316, 318, 320, 324, 328, + 332, 334, 337, 341, 343, 347, 353, 360, 364, 368, + 374, 377, 382, 383, 389, 391, 393, 399, 404, 410, + 415, 421, 428, 434, 439, 445, 450, 454, 461, 466, + 472, 476, 480, 484, 488, 492, 496, 500, 504, 508, + 512, 516, 520, 524, 528, 531, 534, 537, 540, 543, + 546, 549, 552, 555, 559, 562, 567, 571, 577, 580, + 583, 585, 587, 589, 591, 597, 600, 602, 605, 609, + 611, 614, 616, 618, 620, 622, 624, 626, 631, 636, + 642, 648, 650, 652, 656, 661, 665, 670, 675, 680, + 685, 690, 692, 695, 698, 700, 703, 706, 708, 711, + 713, 716, 718, 722, 724, 728, 730, 734, 739, 740, + 746, 748, 750, 752, 754, 758, 761, 765, 768, 770, + 772, 774, 775, 777, 778, 780, 782, 785, 788, 791, + 794, 797, 802, 805, 807, 811, 813, 817, 819, 823, + 825, 827, 829 }; /* YYRHS -- A `-1'-separated list of the rules' RHS. */ static const yytype_int16 yyrhs[] = { 105, 0, -1, -1, 3, 106, 114, 117, -1, -1, - 4, 107, 164, -1, -1, 5, 108, 112, -1, -1, + 4, 107, 166, -1, -1, 5, 108, 112, -1, -1, 6, 109, 121, -1, -1, 7, 110, 119, -1, -1, 8, 111, 117, -1, 9, 114, 117, 10, -1, 21, 114, 20, 74, 118, 20, 22, -1, -1, 9, 116, 117, 10, -1, -1, -1, 117, 119, -1, -1, 118, - 125, -1, 121, -1, 120, -1, 36, 121, -1, 36, - 120, -1, 35, -1, 37, 140, 137, 113, -1, -1, - 38, 141, 138, 122, 142, 143, 148, -1, 40, 23, - 23, 20, -1, -1, 41, 138, 123, 23, 23, 163, - 20, -1, 44, 103, 114, 134, 102, 115, 128, -1, - 45, 103, 114, 136, 102, 115, 128, -1, 50, 103, - 114, 134, 102, 115, -1, 51, 103, 114, 134, 102, - 115, -1, 52, 112, -1, 42, 103, 114, 132, 102, - 130, 115, 129, -1, 43, 103, 114, 133, 102, 130, - 115, 129, -1, 49, 103, 114, 135, 20, 132, 20, - 130, 135, 102, 115, -1, 49, 70, 114, 165, 103, - 134, 102, 115, 129, -1, 49, 167, 103, 114, 134, - 102, 115, 129, -1, 49, 103, 114, 134, 102, 115, - 129, -1, 112, 129, -1, -1, 40, 23, 23, 9, - 114, 124, 117, 10, -1, 127, 20, -1, 20, -1, - 26, 126, -1, -1, 73, 117, 74, -1, 1, -1, - 149, -1, 149, 44, 149, -1, 149, 45, 149, -1, - 149, 42, 149, -1, 149, 43, 133, -1, 149, 49, - 149, -1, 149, 51, 149, -1, -1, 46, 115, -1, - 47, 103, 134, 102, 115, 128, -1, -1, 48, 112, - -1, -1, -1, 127, -1, -1, 149, -1, 149, -1, - 149, -1, 131, -1, 133, -1, 23, -1, -1, -1, - -1, -1, 23, -1, 28, -1, -1, 26, -1, -1, - 72, 26, -1, 72, -1, 72, 26, -1, 72, -1, - -1, -1, 103, 146, 102, -1, 114, 145, 9, 117, - 10, -1, 147, -1, 20, -1, 149, 78, 149, -1, - 149, 77, 149, -1, 149, 76, 149, -1, 150, -1, - 150, 80, -1, 150, 80, 159, -1, 159, -1, 60, - 175, 150, -1, 58, 103, 175, 149, 102, -1, 159, - 101, 153, 103, 164, 102, -1, 159, 101, 153, -1, - 24, 175, 163, -1, 25, 175, 103, 164, 102, -1, - 60, 163, -1, 58, 103, 164, 102, -1, -1, 33, - 139, 112, 152, 163, -1, 24, -1, 167, -1, 174, - 9, 149, 20, 10, -1, 167, 11, 149, 12, -1, - 159, 101, 11, 149, 12, -1, 154, 11, 149, 12, - -1, 167, 9, 149, 20, 10, -1, 159, 101, 9, - 149, 20, 10, -1, 154, 9, 149, 20, 10, -1, - 159, 101, 103, 102, -1, 159, 101, 103, 149, 102, - -1, 154, 103, 149, 102, -1, 154, 103, 102, -1, - 103, 149, 102, 11, 149, 12, -1, 29, 11, 149, - 12, -1, 103, 102, 11, 149, 12, -1, 159, 81, - 159, -1, 159, 95, 159, -1, 159, 63, 159, -1, - 159, 64, 159, -1, 159, 89, 159, -1, 159, 61, - 159, -1, 159, 62, 159, -1, 159, 88, 159, -1, - 159, 87, 159, -1, 159, 54, 159, -1, 159, 86, - 159, -1, 159, 85, 159, -1, 159, 84, 159, -1, - 159, 90, 159, -1, 13, 159, -1, 14, 159, -1, - 91, 159, -1, 92, 159, -1, 159, 98, -1, 159, - 97, -1, 159, 96, -1, 100, 159, -1, 99, 159, - -1, 11, 149, 12, -1, 11, 12, -1, 67, 149, - 20, 10, -1, 67, 20, 10, -1, 39, 139, 142, - 143, 147, -1, 66, 159, -1, 66, 112, -1, 155, - -1, 156, -1, 157, -1, 158, -1, 159, 82, 159, - 83, 159, -1, 93, 159, -1, 161, -1, 69, 159, - -1, 103, 149, 102, -1, 29, -1, 103, 102, -1, - 167, -1, 171, -1, 169, -1, 168, -1, 170, -1, - 154, -1, 172, 11, 149, 12, -1, 173, 11, 149, - 12, -1, 172, 9, 149, 20, 10, -1, 173, 9, - 149, 20, 10, -1, 26, -1, 166, -1, 166, 103, - 102, -1, 166, 103, 149, 102, -1, 68, 141, 163, - -1, 159, 101, 15, 18, -1, 159, 101, 16, 18, - -1, 159, 101, 17, 18, -1, 159, 101, 19, 18, - -1, 159, 101, 18, 18, -1, 53, -1, 53, 159, - -1, 79, 150, -1, 59, -1, 59, 112, -1, 59, - 159, -1, 71, -1, 71, 159, -1, 32, -1, 32, - 159, -1, 56, -1, 56, 103, 102, -1, 30, -1, - 30, 103, 102, -1, 31, -1, 57, 103, 102, -1, - 57, 103, 149, 102, -1, -1, 27, 160, 103, 150, - 102, -1, 23, -1, 151, -1, 55, -1, 34, -1, - 70, 162, 144, -1, 70, 162, -1, 103, 149, 102, - -1, 103, 102, -1, 167, -1, 169, -1, 168, -1, - -1, 150, -1, -1, 149, -1, 167, -1, 19, 175, - -1, 15, 175, -1, 16, 175, -1, 17, 175, -1, - 65, 175, -1, 159, 101, 65, 18, -1, 18, 175, - -1, 168, -1, 159, 101, 16, -1, 169, -1, 159, - 101, 17, -1, 171, -1, 159, 101, 18, -1, 23, - -1, 167, -1, 112, -1, 28, -1 + 127, -1, 121, -1, 120, -1, 36, 121, -1, 36, + 120, -1, 35, -1, 37, 142, 139, 113, -1, -1, + 38, 143, 140, 122, 144, 145, 150, -1, 40, 23, + 23, 20, -1, -1, 41, 140, 123, 23, 23, 165, + 20, -1, 44, 103, 114, 136, 102, 115, 130, -1, + 45, 103, 114, 138, 102, 115, 130, -1, 50, 103, + 114, 136, 102, 115, -1, 51, 103, 114, 136, 102, + 115, -1, 52, 112, -1, 42, 103, 114, 134, 102, + 132, 115, 131, -1, 43, 103, 114, 135, 102, 132, + 115, 131, -1, -1, -1, 49, 103, 114, 137, 20, + 124, 134, 20, 125, 132, 137, 102, 115, -1, 49, + 70, 114, 167, 103, 136, 102, 115, 131, -1, 49, + 169, 103, 114, 136, 102, 115, 131, -1, 49, 103, + 114, 136, 102, 115, 131, -1, 112, 131, -1, -1, + 40, 23, 23, 9, 114, 126, 117, 10, -1, 129, + 20, -1, 20, -1, 26, 128, -1, -1, 73, 117, + 74, -1, 1, -1, 151, -1, 151, 44, 151, -1, + 151, 45, 151, -1, 151, 42, 151, -1, 151, 43, + 135, -1, 151, 49, 151, -1, 151, 51, 151, -1, + -1, 46, 115, -1, 47, 103, 136, 102, 115, 130, + -1, -1, 48, 112, -1, -1, -1, 129, -1, -1, + 151, -1, 151, -1, 151, -1, 133, -1, 135, -1, + 23, -1, -1, -1, -1, -1, 23, -1, 28, -1, + -1, 26, -1, -1, 72, 26, -1, 72, -1, 72, + 26, -1, 72, -1, -1, -1, 103, 148, 102, -1, + 114, 147, 9, 117, 10, -1, 149, -1, 20, -1, + 151, 78, 151, -1, 151, 77, 151, -1, 151, 76, + 151, -1, 152, -1, 152, 80, -1, 152, 80, 161, + -1, 161, -1, 60, 177, 152, -1, 58, 103, 177, + 151, 102, -1, 161, 101, 155, 103, 166, 102, -1, + 161, 101, 155, -1, 24, 177, 165, -1, 25, 177, + 103, 166, 102, -1, 60, 165, -1, 58, 103, 166, + 102, -1, -1, 33, 141, 112, 154, 165, -1, 24, + -1, 169, -1, 176, 9, 151, 20, 10, -1, 169, + 11, 151, 12, -1, 161, 101, 11, 151, 12, -1, + 156, 11, 151, 12, -1, 169, 9, 151, 20, 10, + -1, 161, 101, 9, 151, 20, 10, -1, 156, 9, + 151, 20, 10, -1, 161, 101, 103, 102, -1, 161, + 101, 103, 151, 102, -1, 156, 103, 151, 102, -1, + 156, 103, 102, -1, 103, 151, 102, 11, 151, 12, + -1, 29, 11, 151, 12, -1, 103, 102, 11, 151, + 12, -1, 161, 81, 161, -1, 161, 95, 161, -1, + 161, 63, 161, -1, 161, 64, 161, -1, 161, 89, + 161, -1, 161, 61, 161, -1, 161, 62, 161, -1, + 161, 88, 161, -1, 161, 87, 161, -1, 161, 54, + 161, -1, 161, 86, 161, -1, 161, 85, 161, -1, + 161, 84, 161, -1, 161, 90, 161, -1, 13, 161, + -1, 14, 161, -1, 91, 161, -1, 92, 161, -1, + 161, 98, -1, 161, 97, -1, 161, 96, -1, 100, + 161, -1, 99, 161, -1, 11, 151, 12, -1, 11, + 12, -1, 67, 151, 20, 10, -1, 67, 20, 10, + -1, 39, 141, 144, 145, 149, -1, 66, 161, -1, + 66, 112, -1, 157, -1, 158, -1, 159, -1, 160, + -1, 161, 82, 161, 83, 161, -1, 93, 161, -1, + 163, -1, 69, 161, -1, 103, 151, 102, -1, 29, + -1, 103, 102, -1, 169, -1, 173, -1, 171, -1, + 170, -1, 172, -1, 156, -1, 174, 11, 151, 12, + -1, 175, 11, 151, 12, -1, 174, 9, 151, 20, + 10, -1, 175, 9, 151, 20, 10, -1, 26, -1, + 168, -1, 168, 103, 102, -1, 168, 103, 151, 102, + -1, 68, 143, 165, -1, 161, 101, 15, 18, -1, + 161, 101, 16, 18, -1, 161, 101, 17, 18, -1, + 161, 101, 19, 18, -1, 161, 101, 18, 18, -1, + 53, -1, 53, 161, -1, 79, 152, -1, 59, -1, + 59, 112, -1, 59, 161, -1, 71, -1, 71, 161, + -1, 32, -1, 32, 161, -1, 56, -1, 56, 103, + 102, -1, 30, -1, 30, 103, 102, -1, 31, -1, + 57, 103, 102, -1, 57, 103, 151, 102, -1, -1, + 27, 162, 103, 152, 102, -1, 23, -1, 153, -1, + 55, -1, 34, -1, 70, 164, 146, -1, 70, 164, + -1, 103, 151, 102, -1, 103, 102, -1, 169, -1, + 171, -1, 170, -1, -1, 152, -1, -1, 151, -1, + 169, -1, 19, 177, -1, 15, 177, -1, 16, 177, + -1, 17, 177, -1, 65, 177, -1, 161, 101, 65, + 18, -1, 18, 177, -1, 170, -1, 161, 101, 16, + -1, 171, -1, 161, 101, 17, -1, 173, -1, 161, + 101, 18, -1, 23, -1, 169, -1, 112, -1, 28, + -1 }; /* YYRLINE[YYN] -- source line where rule number YYN was defined. */ @@ -190,31 +191,31 @@ static const yytype_uint16 yyrline[] = 156, 155, 168, 167, 179, 187, 195, 198, 206, 211, 212, 222, 223, 232, 236, 240, 244, 251, 253, 264, 263, 295, 303, 302, 310, 316, 322, 333, 335, 337, - 344, 351, 366, 371, 377, 383, 390, 389, 404, 409, - 418, 436, 437, 442, 444, 446, 448, 450, 452, 454, - 457, 463, 464, 469, 480, 481, 487, 493, 494, 499, - 502, 506, 511, 515, 519, 523, 524, 528, 534, 539, - 544, 545, 550, 551, 556, 557, 559, 564, 566, 571, - 573, 572, 591, 601, 602, 608, 610, 612, 614, 618, - 620, 625, 629, 633, 637, 643, 648, 654, 660, 662, - 665, 664, 675, 676, 680, 686, 689, 694, 699, 703, - 709, 715, 718, 723, 727, 730, 732, 734, 739, 741, - 743, 748, 750, 752, 754, 756, 758, 760, 762, 764, - 766, 768, 773, 775, 778, 780, 782, 785, 788, 799, - 802, 809, 811, 813, 815, 817, 824, 826, 830, 831, - 832, 833, 834, 836, 838, 840, 842, 844, 846, 848, - 850, 852, 854, 856, 858, 860, 870, 880, 891, 902, - 904, 906, 909, 914, 918, 920, 922, 924, 927, 929, - 932, 934, 936, 938, 940, 942, 944, 946, 948, 951, - 953, 955, 957, 959, 961, 965, 968, 967, 980, 981, - 982, 987, 991, 993, 998, 1000, 1003, 1005, 1007, 1012, - 1014, 1019, 1020, 1026, 1030, 1034, 1038, 1044, 1050, 1052, - 1056, 1060, 1061, 1065, 1066, 1070, 1071, 1076, 1078, 1080, - 1083 + 344, 352, 354, 351, 370, 375, 381, 387, 394, 393, + 408, 412, 420, 438, 439, 444, 446, 448, 450, 452, + 454, 456, 459, 465, 466, 471, 482, 483, 489, 495, + 496, 501, 504, 508, 513, 517, 521, 525, 526, 530, + 536, 541, 546, 547, 552, 553, 558, 559, 561, 566, + 568, 573, 575, 574, 593, 603, 604, 608, 610, 612, + 614, 618, 620, 625, 629, 633, 637, 643, 648, 654, + 660, 662, 665, 664, 675, 676, 680, 684, 687, 692, + 697, 700, 704, 708, 711, 716, 720, 723, 725, 727, + 732, 734, 736, 741, 743, 745, 747, 749, 751, 753, + 755, 757, 759, 761, 766, 768, 771, 773, 775, 778, + 781, 792, 795, 802, 804, 806, 808, 810, 817, 819, + 823, 824, 825, 826, 827, 829, 831, 833, 835, 837, + 839, 841, 843, 845, 847, 849, 851, 853, 863, 873, + 883, 893, 895, 897, 900, 905, 909, 911, 913, 915, + 918, 920, 923, 925, 927, 929, 931, 933, 935, 937, + 939, 942, 944, 946, 948, 950, 952, 956, 959, 958, + 971, 972, 973, 978, 982, 984, 989, 991, 994, 996, + 998, 1003, 1005, 1010, 1011, 1017, 1021, 1025, 1029, 1035, + 1041, 1043, 1047, 1051, 1052, 1056, 1057, 1061, 1062, 1067, + 1069, 1071, 1074 }; #endif -#if YYDEBUG || YYERROR_VERBOSE || 0 +#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = @@ -233,18 +234,18 @@ static const char *const yytname[] = "ANDOP", "NOTOP", "','", "ASSIGNOP", "'?'", "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP", "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTJOIN", "POSTDEC", "POSTINC", "PREDEC", - "PREINC", "ARROW", "')'", "'('", "$accept", "grammar", "$@1", "$@2", - "$@3", "$@4", "$@5", "$@6", "block", "formblock", "remember", "mblock", + "PREINC", "ARROW", "')'", "'('", "$accept", "grammar", "@1", "@2", "@3", + "@4", "@5", "@6", "block", "formblock", "remember", "mblock", "mremember", "stmtseq", "formstmtseq", "fullstmt", "labfullstmt", - "barestmt", "$@7", "$@8", "$@9", "formline", "formarg", "sideff", "else", - "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr", "mnexpr", "miexpr", - "formname", "startsub", "startanonsub", "startformsub", "subname", - "proto", "subattrlist", "myattrlist", "subsignature", "@10", - "realsubbody", "optsubbody", "expr", "listexpr", "listop", "@11", - "method", "subscripted", "termbinop", "termunop", "anonymous", "termdo", - "term", "@12", "myattrterm", "myterm", "optlistexpr", "optexpr", - "my_scalar", "amper", "scalar", "ary", "hsh", "arylen", "star", - "sliceme", "kvslice", "gelem", "indirob", YY_NULL + "barestmt", "@7", "@8", "@9", "@10", "@11", "formline", "formarg", + "sideff", "else", "cont", "mintro", "nexpr", "texpr", "iexpr", "mexpr", + "mnexpr", "miexpr", "formname", "startsub", "startanonsub", + "startformsub", "subname", "proto", "subattrlist", "myattrlist", + "subsignature", "@12", "realsubbody", "optsubbody", "expr", "listexpr", + "listop", "@13", "method", "subscripted", "termbinop", "termunop", + "anonymous", "termdo", "term", "@14", "myattrterm", "myterm", + "optlistexpr", "optexpr", "my_scalar", "amper", "scalar", "ary", "hsh", + "arylen", "star", "sliceme", "kvslice", "gelem", "indirob", 0 }; #endif @@ -274,27 +275,27 @@ static const yytype_uint8 yyr1[] = 110, 105, 111, 105, 112, 113, 114, 115, 116, 117, 117, 118, 118, 119, 119, 120, 120, 121, 121, 122, 121, 121, 123, 121, 121, 121, 121, 121, 121, 121, - 121, 121, 121, 121, 121, 121, 124, 121, 121, 121, - 125, 126, 126, 127, 127, 127, 127, 127, 127, 127, - 127, 128, 128, 128, 129, 129, 130, 131, 131, 132, - 132, 133, 134, 135, 136, 137, 137, 138, 139, 140, - 141, 141, 142, 142, 143, 143, 143, 144, 144, 145, - 146, 145, 147, 148, 148, 149, 149, 149, 149, 150, - 150, 150, 151, 151, 151, 151, 151, 151, 151, 151, - 152, 151, 153, 153, 154, 154, 154, 154, 154, 154, - 154, 154, 154, 154, 154, 154, 154, 154, 155, 155, - 155, 155, 155, 155, 155, 155, 155, 155, 155, 155, - 155, 155, 156, 156, 156, 156, 156, 156, 156, 156, - 156, 157, 157, 157, 157, 157, 158, 158, 159, 159, - 159, 159, 159, 159, 159, 159, 159, 159, 159, 159, - 159, 159, 159, 159, 159, 159, 159, 159, 159, 159, - 159, 159, 159, 159, 159, 159, 159, 159, 159, 159, - 159, 159, 159, 159, 159, 159, 159, 159, 159, 159, - 159, 159, 159, 159, 159, 159, 160, 159, 159, 159, - 159, 159, 161, 161, 162, 162, 162, 162, 162, 163, - 163, 164, 164, 165, 166, 167, 168, 169, 170, 170, - 171, 172, 172, 173, 173, 174, 174, 175, 175, 175, - 175 + 121, 124, 125, 121, 121, 121, 121, 121, 126, 121, + 121, 121, 127, 128, 128, 129, 129, 129, 129, 129, + 129, 129, 129, 130, 130, 130, 131, 131, 132, 133, + 133, 134, 134, 135, 136, 137, 138, 139, 139, 140, + 141, 142, 143, 143, 144, 144, 145, 145, 145, 146, + 146, 147, 148, 147, 149, 150, 150, 151, 151, 151, + 151, 152, 152, 152, 153, 153, 153, 153, 153, 153, + 153, 153, 154, 153, 155, 155, 156, 156, 156, 156, + 156, 156, 156, 156, 156, 156, 156, 156, 156, 156, + 157, 157, 157, 157, 157, 157, 157, 157, 157, 157, + 157, 157, 157, 157, 158, 158, 158, 158, 158, 158, + 158, 158, 158, 159, 159, 159, 159, 159, 160, 160, + 161, 161, 161, 161, 161, 161, 161, 161, 161, 161, + 161, 161, 161, 161, 161, 161, 161, 161, 161, 161, + 161, 161, 161, 161, 161, 161, 161, 161, 161, 161, + 161, 161, 161, 161, 161, 161, 161, 161, 161, 161, + 161, 161, 161, 161, 161, 161, 161, 161, 162, 161, + 161, 161, 161, 161, 163, 163, 164, 164, 164, 164, + 164, 165, 165, 166, 166, 167, 168, 169, 170, 171, + 172, 172, 173, 174, 174, 175, 175, 176, 176, 177, + 177, 177, 177 }; /* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ @@ -304,82 +305,82 @@ static const yytype_uint8 yyr2[] = 0, 3, 0, 3, 4, 7, 0, 4, 0, 0, 2, 0, 2, 1, 1, 2, 2, 1, 4, 0, 7, 4, 0, 7, 7, 7, 6, 6, 2, 8, - 8, 11, 9, 8, 7, 2, 0, 8, 2, 1, - 2, 0, 3, 1, 1, 3, 3, 3, 3, 3, - 3, 0, 2, 6, 0, 2, 0, 0, 1, 0, - 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, - 1, 1, 0, 1, 0, 2, 1, 2, 1, 0, - 0, 3, 5, 1, 1, 3, 3, 3, 1, 2, - 3, 1, 3, 5, 6, 3, 3, 5, 2, 4, - 0, 5, 1, 1, 5, 4, 5, 4, 5, 6, - 5, 4, 5, 4, 3, 6, 4, 5, 3, 3, + 8, 0, 0, 13, 9, 8, 7, 2, 0, 8, + 2, 1, 2, 0, 3, 1, 1, 3, 3, 3, + 3, 3, 3, 0, 2, 6, 0, 2, 0, 0, + 1, 0, 1, 1, 1, 1, 1, 1, 0, 0, + 0, 0, 1, 1, 0, 1, 0, 2, 1, 2, + 1, 0, 0, 3, 5, 1, 1, 3, 3, 3, + 1, 2, 3, 1, 3, 5, 6, 3, 3, 5, + 2, 4, 0, 5, 1, 1, 5, 4, 5, 4, + 5, 6, 5, 4, 5, 4, 3, 6, 4, 5, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 3, 2, 4, 3, 5, 2, 2, 1, 1, - 1, 1, 5, 2, 1, 2, 3, 1, 2, 1, - 1, 1, 1, 1, 1, 4, 4, 5, 5, 1, - 1, 3, 4, 3, 4, 4, 4, 4, 4, 1, - 2, 2, 1, 2, 2, 1, 2, 1, 2, 1, - 3, 1, 3, 1, 3, 4, 0, 5, 1, 1, - 1, 1, 3, 2, 3, 2, 1, 1, 1, 0, - 1, 0, 1, 1, 2, 2, 2, 2, 2, 4, - 2, 1, 3, 1, 3, 1, 3, 1, 1, 1, - 1 + 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 3, 2, 4, 3, 5, 2, 2, + 1, 1, 1, 1, 5, 2, 1, 2, 3, 1, + 2, 1, 1, 1, 1, 1, 1, 4, 4, 5, + 5, 1, 1, 3, 4, 3, 4, 4, 4, 4, + 4, 1, 2, 2, 1, 2, 2, 1, 2, 1, + 2, 1, 3, 1, 3, 1, 3, 4, 0, 5, + 1, 1, 1, 1, 3, 2, 3, 2, 1, 1, + 1, 0, 1, 0, 1, 1, 2, 2, 2, 2, + 2, 4, 2, 1, 3, 1, 3, 1, 3, 1, + 1, 1, 1 }; -/* YYDEFACT[STATE-NAME] -- Default reduction number in state STATE-NUM. - Performed when YYTABLE doesn't specify something else to do. Zero +/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state + STATE-NUM when YYTABLE doesn't specify something else to do. Zero means the default is an error. */ static const yytype_uint8 yydefact[] = { - 0, 2, 4, 6, 8, 10, 12, 0, 16, 221, + 0, 2, 4, 6, 8, 10, 12, 0, 16, 223, 0, 0, 0, 19, 1, 19, 0, 0, 0, 0, - 0, 0, 0, 0, 208, 0, 0, 179, 206, 167, - 201, 203, 197, 78, 211, 78, 189, 210, 199, 0, - 0, 192, 219, 0, 0, 0, 0, 0, 0, 195, - 0, 0, 0, 0, 0, 0, 0, 222, 98, 209, - 174, 158, 159, 160, 161, 101, 164, 5, 180, 169, - 172, 171, 173, 170, 0, 0, 0, 16, 7, 53, - 49, 27, 79, 0, 0, 77, 0, 0, 0, 0, - 0, 0, 0, 0, 64, 9, 0, 54, 0, 11, - 24, 23, 0, 0, 152, 0, 142, 143, 237, 240, - 239, 238, 225, 226, 227, 230, 224, 219, 0, 0, - 0, 0, 198, 0, 82, 190, 0, 0, 221, 193, - 194, 237, 220, 108, 238, 0, 228, 157, 156, 0, - 0, 80, 81, 219, 165, 0, 213, 216, 218, 217, - 196, 191, 144, 145, 163, 150, 149, 168, 0, 0, - 0, 0, 99, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 210, 0, 0, 181, 208, 169, + 203, 205, 199, 80, 213, 80, 191, 212, 201, 0, + 0, 194, 221, 0, 0, 0, 0, 0, 0, 197, + 0, 0, 0, 0, 0, 0, 0, 224, 100, 211, + 176, 160, 161, 162, 163, 103, 166, 5, 182, 171, + 174, 173, 175, 172, 0, 0, 0, 16, 7, 55, + 51, 27, 81, 0, 0, 79, 0, 0, 0, 0, + 0, 0, 0, 0, 66, 9, 0, 56, 0, 11, + 24, 23, 0, 0, 154, 0, 144, 145, 239, 242, + 241, 240, 227, 228, 229, 232, 226, 221, 0, 0, + 0, 0, 200, 0, 84, 192, 0, 0, 223, 195, + 196, 239, 222, 110, 240, 0, 230, 159, 158, 0, + 0, 82, 83, 221, 167, 0, 215, 218, 220, 219, + 198, 193, 146, 147, 165, 152, 151, 170, 0, 0, + 0, 0, 101, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 148, 147, 146, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 19, 76, 77, 0, 32, 16, 16, - 16, 16, 16, 16, 0, 16, 16, 38, 0, 45, - 48, 0, 0, 0, 0, 0, 0, 26, 25, 20, - 151, 106, 221, 0, 0, 202, 110, 83, 84, 200, - 204, 0, 0, 0, 102, 154, 0, 183, 215, 0, - 88, 212, 0, 166, 97, 96, 95, 100, 0, 0, - 124, 0, 137, 133, 134, 130, 131, 128, 0, 140, - 139, 138, 136, 135, 132, 141, 129, 0, 0, 0, - 232, 234, 236, 0, 112, 0, 0, 105, 113, 181, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 75, - 0, 29, 0, 0, 69, 0, 0, 0, 0, 0, - 16, 0, 0, 65, 57, 58, 71, 55, 56, 59, - 60, 0, 0, 126, 219, 86, 16, 205, 109, 0, - 153, 214, 87, 0, 0, 0, 117, 123, 0, 0, - 0, 184, 185, 186, 188, 187, 229, 121, 0, 221, - 182, 0, 115, 0, 175, 0, 176, 0, 14, 16, - 28, 82, 16, 31, 0, 0, 70, 0, 0, 72, - 74, 0, 0, 223, 68, 73, 0, 0, 54, 0, - 0, 0, 107, 207, 111, 85, 89, 155, 103, 127, - 0, 120, 162, 0, 116, 122, 0, 118, 177, 178, - 114, 0, 84, 46, 219, 66, 66, 0, 0, 0, - 0, 69, 0, 0, 0, 90, 0, 125, 119, 104, - 0, 16, 19, 0, 0, 0, 18, 61, 61, 0, - 64, 0, 0, 36, 37, 0, 19, 21, 94, 93, - 30, 0, 33, 64, 64, 19, 0, 0, 34, 35, - 0, 44, 66, 64, 91, 0, 0, 47, 39, 40, - 0, 62, 0, 64, 0, 43, 92, 0, 51, 22, - 17, 0, 42, 0, 15, 19, 50, 0, 0, 0, - 61, 41, 52, 63 + 0, 150, 149, 148, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 19, 78, 79, 0, 32, 16, 16, + 16, 16, 16, 16, 0, 16, 16, 38, 0, 47, + 50, 0, 0, 0, 0, 0, 0, 26, 25, 20, + 153, 108, 223, 0, 0, 204, 112, 85, 86, 202, + 206, 0, 0, 0, 104, 156, 0, 185, 217, 0, + 90, 214, 0, 168, 99, 98, 97, 102, 0, 0, + 126, 0, 139, 135, 136, 132, 133, 130, 0, 142, + 141, 140, 138, 137, 134, 143, 131, 0, 0, 0, + 234, 236, 238, 0, 114, 0, 0, 107, 115, 183, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 77, + 0, 29, 0, 0, 71, 0, 0, 0, 0, 0, + 16, 0, 0, 67, 59, 60, 73, 57, 58, 61, + 62, 0, 0, 128, 221, 88, 16, 207, 111, 0, + 155, 216, 89, 0, 0, 0, 119, 125, 0, 0, + 0, 186, 187, 188, 190, 189, 231, 123, 0, 223, + 184, 0, 117, 0, 177, 0, 178, 0, 14, 16, + 28, 84, 16, 31, 0, 0, 72, 0, 0, 74, + 76, 0, 0, 225, 70, 75, 0, 0, 56, 0, + 0, 0, 109, 209, 113, 87, 91, 157, 105, 129, + 0, 122, 164, 0, 118, 124, 0, 120, 179, 180, + 116, 0, 86, 48, 221, 68, 68, 0, 0, 0, + 0, 41, 0, 0, 0, 92, 0, 127, 121, 106, + 0, 16, 19, 0, 0, 0, 18, 63, 63, 0, + 66, 71, 0, 36, 37, 0, 19, 21, 96, 95, + 30, 0, 33, 66, 66, 19, 0, 0, 34, 35, + 0, 46, 0, 66, 93, 0, 0, 49, 39, 40, + 0, 64, 0, 66, 42, 45, 94, 0, 53, 22, + 17, 0, 44, 68, 15, 19, 52, 0, 0, 0, + 63, 0, 54, 65, 0, 43 }; /* YYDEFGOTO[NTERM-NUM]. */ @@ -387,161 +388,162 @@ static const yytype_int16 yydefgoto[] = { -1, 7, 8, 9, 10, 11, 12, 13, 110, 350, 376, 417, 435, 102, 446, 219, 100, 101, 351, 293, - 412, 459, 466, 96, 438, 209, 414, 365, 355, 305, - 358, 367, 361, 290, 197, 123, 194, 143, 228, 316, - 241, 406, 425, 377, 430, 97, 58, 59, 314, 277, - 60, 61, 62, 63, 64, 65, 119, 66, 146, 133, - 67, 362, 68, 69, 70, 71, 72, 73, 74, 75, - 76, 112 + 421, 463, 412, 459, 466, 96, 438, 209, 414, 365, + 355, 305, 358, 367, 361, 290, 197, 123, 194, 143, + 228, 316, 241, 406, 425, 377, 430, 97, 58, 59, + 314, 277, 60, 61, 62, 63, 64, 65, 119, 66, + 146, 133, 67, 362, 68, 69, 70, 71, 72, 73, + 74, 75, 76, 112 }; /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing STATE-NUM. */ -#define YYPACT_NINF -408 +#define YYPACT_NINF -409 static const yytype_int16 yypact[] = { - 714, -408, -408, -408, -408, -408, -408, 5, -408, 2549, - 20, 1201, 1108, -408, -408, -408, 1809, 2549, 2549, 608, - 608, 608, 608, 608, -408, 608, 608, -408, -408, 48, - -67, -408, 2549, -408, -408, -408, 2549, -408, -54, -41, - -26, 1716, 1623, 608, 1716, 1900, 50, 2549, 40, 2549, - 2549, 2549, 2549, 2549, 2549, 2549, 1991, 226, 21, -408, - 11, -408, -408, -408, -408, 2617, -408, -408, -8, 107, - 136, 155, -408, 98, 220, 251, 110, -408, -408, -408, - -408, -408, -408, 50, 77, -408, 19, 26, 37, 41, - 1, 45, 51, 20, 93, -408, 135, 367, 1108, -408, - -408, -408, 447, 542, -408, -2, 614, 614, -408, -408, - -408, -408, -408, -408, -408, -408, -408, 2549, 56, 100, - 2549, 92, 1701, 20, 188, 2617, 124, 2084, 1623, -408, - 1701, 1529, 21, -408, 1450, 2549, -408, -408, 1701, 225, - 3, -408, -408, 2549, 1701, 2177, 168, -408, -408, -408, - 1701, 21, 614, 614, 614, 354, 354, 232, -50, 2549, + 706, -409, -409, -409, -409, -409, -409, 19, -409, 2549, + 2, 1201, 1108, -409, -409, -409, 1809, 2549, 2549, 50, + 50, 50, 50, 50, -409, 50, 50, -409, -409, 52, + -74, -409, 2549, -409, -409, -409, 2549, -409, -67, -54, + -9, 1716, 1623, 50, 1716, 1900, 46, 2549, 40, 2549, + 2549, 2549, 2549, 2549, 2549, 2549, 1991, 274, 20, -409, + 11, -409, -409, -409, -409, 2617, -409, -409, -8, 98, + 107, 220, -409, 61, 229, 263, 92, -409, -409, -409, + -409, -409, -409, 46, 106, -409, 37, 41, 47, 63, + 1, 100, 111, 2, 73, -409, 135, 368, 1108, -409, + -409, -409, 447, 542, -409, 9, 432, 432, -409, -409, + -409, -409, -409, -409, -409, -409, -409, 2549, 130, 134, + 2549, 124, 280, 2, 137, 2617, 141, 2084, 1623, -409, + 280, 1529, 20, -409, 1450, 2549, -409, -409, 280, 184, + 3, -409, -409, 2549, 280, 2177, 170, -409, -409, -409, + 280, 20, 432, 432, 432, 296, 296, 251, -50, 2549, 2549, 2549, 2549, 2549, 2549, 2270, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, 2549, - 2549, -408, -408, -408, 252, 2363, 2549, 2549, 2549, 2549, - 2549, 2549, 2549, -408, 221, -408, 259, -408, -408, -408, - -408, -408, -408, -408, 171, -408, -408, -408, 20, -408, - -408, 2549, 2549, 2549, 2549, 2549, 2549, -408, -408, -408, - -408, -408, 2549, 2549, 9, -408, -408, -408, 211, -408, - -408, 140, 184, 2549, 21, -408, 295, -408, -408, 212, - 284, -408, 2549, 302, 240, 240, -408, 2617, 74, 13, - -408, 291, 341, 1608, 245, 529, 432, 2617, 2572, 289, - 289, 1279, 1420, 1499, 1332, 614, 614, 2549, 2549, 257, - 309, 313, 321, 326, -408, 327, 2456, 217, -408, -408, - 304, 101, 60, 119, 91, 129, 94, 156, 637, -408, - 328, -408, 15, 324, 2549, 2549, 2549, 2549, 339, 1294, - -408, 2549, 2549, -408, 226, -408, 226, 226, 226, 226, - 226, 254, -48, -408, 2549, 334, -408, -408, -408, 433, - -408, -408, -408, 97, 2549, 352, -408, -408, 2549, 160, - 115, -408, -408, -408, -408, -408, -408, -408, 443, 2549, - -408, 353, -408, 360, -408, 362, -408, 363, -408, -408, - -408, 188, -408, -408, 365, 287, 226, 290, 292, 226, - -408, 297, 288, -408, -408, -408, 299, 377, 281, 2549, - 306, 311, -408, -408, -408, -408, 312, -408, -408, -408, - 123, -408, 2662, 407, -408, -408, 317, -408, -408, -408, - -408, 400, 211, -408, 2549, -408, -408, 413, 413, 2549, - 413, 2549, 322, 413, 413, -408, 423, -408, -408, -408, - 359, 414, -408, 421, 413, 413, -408, 23, 23, 344, - 93, 434, 413, -408, -408, 355, -408, -408, -408, -408, - -408, 732, -408, 93, 93, -408, 413, 366, -408, -408, - 413, -408, -408, 93, -408, 827, 38, -408, -408, -408, - 922, -408, 2549, 93, 1387, -408, -408, 446, 402, -408, - -408, 391, -408, 392, -408, -408, -408, 413, 413, 1015, - 23, -408, -408, -408 + 2549, -409, -409, -409, 252, 2363, 2549, 2549, 2549, 2549, + 2549, 2549, 2549, -409, 243, -409, 256, -409, -409, -409, + -409, -409, -409, -409, 172, -409, -409, -409, 2, -409, + -409, 2549, 2549, 2549, 2549, 2549, 2549, -409, -409, -409, + -409, -409, 2549, 2549, 13, -409, -409, -409, 210, -409, + -409, 71, 181, 2549, 20, -409, 275, -409, -409, 158, + 260, -409, 2549, 293, 228, 228, -409, 2617, 99, 60, + -409, 261, 341, 1794, 1608, 527, 217, 2617, 2572, 1280, + 1280, 1420, 1499, 1701, 290, 432, 432, 2549, 2549, 136, + 292, 310, 311, 313, -409, 322, 2456, 208, -409, -409, + 271, 102, 91, 119, 94, 212, 115, 224, 637, -409, + 321, -409, 15, 323, 2549, 2549, 2549, 2549, 345, 1294, + -409, 2549, 2549, -409, 274, -409, 274, 274, 274, 274, + 274, 254, -48, -409, 2549, 336, -409, -409, -409, 417, + -409, -409, -409, 123, 2549, 354, -409, -409, 2549, 257, + 129, -409, -409, -409, -409, -409, -409, -409, 433, 2549, + -409, 355, -409, 357, -409, 358, -409, 372, -409, -409, + -409, 137, -409, -409, 361, 287, 274, 288, 297, 274, + -409, 299, 295, -409, -409, -409, 304, 388, 281, 2549, + 307, 314, -409, -409, -409, -409, 312, -409, -409, -409, + 140, -409, 2662, 410, -409, -409, 320, -409, -409, -409, + -409, 404, 210, -409, 2549, -409, -409, 423, 423, 2549, + 423, -409, 331, 423, 423, -409, 425, -409, -409, -409, + 367, 430, -409, 431, 423, 423, -409, 30, 30, 350, + 73, 2549, 423, -409, -409, 352, -409, -409, -409, -409, + -409, 732, -409, 73, 73, -409, 423, 340, -409, -409, + 423, -409, 435, 73, -409, 827, 38, -409, -409, -409, + 922, -409, 2549, 73, -409, -409, -409, 446, 384, -409, + -409, 373, -409, -409, -409, -409, -409, 423, 1387, 1015, + 30, 399, -409, -409, 423, -409 }; /* YYPGOTO[NTERM-NUM]. */ static const yytype_int16 yypgoto[] = { - -408, -408, -408, -408, -408, -408, -408, -408, -10, -408, - 22, -103, -408, -12, -408, 489, 410, 7, -408, -408, - -408, -408, -408, -291, -407, -105, -377, -408, 122, -18, - -287, 70, -408, -408, 330, 496, -408, 449, 183, 144, - -408, -408, -408, 126, -408, -3, -33, -408, -408, -408, - -408, -408, -408, -408, -408, 79, -408, -408, -408, -110, - -124, -408, -408, 18, 493, 500, -408, -408, -408, -408, - -408, 25 + -409, -409, -409, -409, -409, -409, -409, -409, -10, -409, + 22, -95, -409, -12, -409, 457, 422, 7, -409, -409, + -409, -409, -409, -409, -409, -294, -408, 88, -388, -409, + 103, 0, -287, 55, -409, -409, 330, 497, -409, 451, + 185, 145, -409, -409, -409, 133, -409, -3, -33, -409, + -409, -409, -409, -409, -409, -409, -409, 79, -409, -409, + -409, -110, -124, -409, -409, 18, 500, 501, -409, -409, + -409, -409, -409, 25 }; /* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If positive, shift that token. If negative, reduce the rule which - number is the opposite. If YYTABLE_NINF, syntax error. */ -#define YYTABLE_NINF -236 + number is the opposite. If zero, do what YYDEFACT says. + If YYTABLE_NINF, syntax error. */ +#define YYTABLE_NINF -238 static const yytype_int16 yytable[] = { - 78, 94, 94, 103, 232, 14, 57, 221, 364, 132, - 220, 439, 366, 105, 370, 371, 19, 151, 95, 415, - 163, 313, 164, 236, 352, 326, 159, 160, 161, 77, - 15, 129, 162, 237, 137, 353, 121, 111, 111, 111, - 111, 111, 140, 111, 111, 113, 114, 115, 116, 126, - 117, 118, 243, 158, 373, 19, 20, 21, 457, 120, - 134, 111, 127, 473, 458, 454, 147, 135, 136, 436, - 437, 202, 342, 141, 159, 160, 161, 128, 142, 159, + 78, 94, 94, 103, 232, 364, 57, 221, 415, 132, + 439, 77, 366, 105, 370, 371, 19, 151, 95, 14, + 163, 220, 164, 236, 352, 313, 159, 160, 161, 121, + 15, 129, 162, 237, 137, 353, 126, 111, 111, 111, + 111, 111, 140, 111, 111, 113, 114, 115, 116, 127, + 117, 118, 243, 158, 373, 19, 20, 21, 457, 77, + 134, 111, 473, 120, 458, 19, 147, 135, 136, 141, + -237, 202, 326, 108, 142, 468, 436, 437, 109, 159, 160, 161, 402, 207, 132, 159, 160, 161, 94, 159, - 160, 161, 94, 94, 325, 185, 106, 107, 311, 193, - 196, 162, 234, 344, 203, 218, 346, -235, 204, 379, - 132, 122, 419, 226, 165, 125, 186, 224, 187, 192, - 130, 341, 198, 138, 231, 57, 144, 384, 150, 199, - 152, 153, 154, 155, 156, 407, 159, 160, 161, 343, - 200, 208, 239, 145, 201, -231, 134, -231, 205, 345, - 159, 160, 161, 233, 206, 210, 244, 245, 246, 222, - 248, 249, 251, 364, -233, 461, -233, 159, 160, 161, - 159, 160, 161, 159, 160, 161, 347, 159, 160, 161, - 383, 288, 280, 281, 282, 283, 284, 285, 286, 287, - 312, 159, 160, 161, 225, 159, 160, 161, 303, 159, - 160, 161, 278, 223, 374, 159, 160, 161, 304, 306, - 307, 308, 309, 310, 227, 386, 159, 160, 161, 57, - 294, 295, 296, 297, 298, 299, 229, 301, 302, 188, - 319, 189, 159, 160, 161, 235, 159, 160, 161, 323, - 240, 247, 317, 242, 289, 252, 253, 254, 255, 256, + 160, 161, 94, 94, 128, 185, 106, 107, 311, 193, + 162, 192, 234, 342, 203, 218, 344, 186, 204, 187, + 132, 122, 419, 226, 165, 125, -233, 224, -233, 325, + 130, 208, 341, 138, 231, 57, 144, 346, 150, 196, + 152, 153, 154, 155, 156, 379, 159, 160, 161, 343, + 198, 384, 239, 145, 199, 77, 134, 159, 160, 161, + 200, 19, 407, 233, 331, 210, 244, 245, 246, 108, + 248, 249, 251, 227, 109, 461, 201, 159, 160, 161, + 159, 160, 161, 317, 364, 159, 160, 161, 159, 160, + 161, 288, 280, 281, 282, 283, 284, 285, 286, 287, + 312, 159, 160, 161, 235, 159, 160, 161, 303, 159, + 160, 161, 278, 205, 374, 159, 160, 161, 304, 306, + 307, 308, 309, 310, 206, 386, 159, 160, 161, 57, + 294, 295, 296, 297, 298, 299, 225, 301, 302, -235, + 319, -235, 345, 222, 159, 160, 161, 223, 188, 323, + 189, 247, 240, 229, 347, 252, 253, 254, 255, 256, 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, - 190, 267, 191, 268, 329, 330, 77, 269, 270, 271, - 272, 273, 19, 338, 300, 331, 274, 357, 94, 360, - 108, 132, 292, 315, 413, 109, 318, 111, 159, 160, - 161, 356, 306, 359, 306, 418, 368, 420, 359, 359, - 423, 424, 159, 160, 161, 320, 167, -236, 169, 170, - 322, 433, 434, 324, 321, 441, 363, 275, 161, 443, - 339, 380, 369, 211, 212, 213, 214, 332, 448, 449, - 215, 333, 216, 451, 178, 179, 57, 453, 455, 334, - 180, 181, 182, 183, 335, 336, 184, 354, 462, 349, - 167, 168, 169, 170, 19, 276, 372, 159, 160, 161, - 375, 132, 381, 387, 470, 471, 359, 159, 160, 161, - 388, 391, 389, 390, 393, 175, 176, 177, 178, 179, - 159, 160, 161, -72, 180, 181, 182, 183, 394, 395, - 184, 399, 396, 327, 397, -236, 359, 401, 356, 398, - 431, 400, 167, 168, 169, 170, 340, 382, 403, 211, - 212, 213, 214, 404, 445, 405, 215, 408, 216, 409, - 410, 94, 416, 450, 422, 173, 174, 175, 176, 177, - 178, 179, 426, 427, 428, 94, 180, 181, 182, 183, - 94, 432, 184, 159, 160, 161, 440, -13, 79, 359, - -236, -236, -236, 469, 442, 184, 77, 444, 16, 94, - 17, 18, 19, 20, 21, 22, 23, 80, 464, 452, - 24, 25, 26, 27, 28, 465, 29, 30, 31, 32, + 321, 267, 242, 268, 329, 330, 289, 269, 270, 271, + 272, 273, 190, 338, 191, 300, 274, 383, 94, 292, + 169, 132, 315, 318, 413, 320, 322, 111, 159, 160, + 161, 356, 306, 359, 306, 357, 368, 360, 359, 359, + 159, 160, 161, 418, 324, 420, 161, 179, 423, 424, + 332, 339, 180, 181, 182, 183, 363, 275, 184, 433, + 434, 380, 369, 211, 212, 213, 214, 443, 333, 334, + 215, 335, 216, 159, 160, 161, 57, 159, 160, 161, + 336, 451, 349, 169, 170, 453, 354, 159, 160, 161, + 159, 160, 161, 169, 170, 276, 372, 159, 160, 161, + 19, 132, 375, 327, 381, 387, 359, 388, 389, 178, + 179, 391, 470, 340, 393, 180, 181, 182, 183, 475, + 179, 184, 390, -74, 394, 180, 181, 182, 183, 395, + 396, 184, -238, -238, -238, -238, 359, 184, 399, 397, + 431, 398, 167, 168, 169, 170, 400, 382, 401, 403, + 211, 212, 213, 214, 445, 405, 404, 215, 356, 216, + 408, 94, 409, 450, 410, 173, 174, 175, 176, 177, + 178, 179, 416, 422, 426, 94, 180, 181, 182, 183, + 94, 427, 184, 452, 159, 160, 161, -13, 79, 359, + 428, 432, 440, 469, 444, 454, 77, 465, 16, 94, + 17, 18, 19, 20, 21, 22, 23, 80, 464, 99, + 24, 25, 26, 27, 28, 467, 29, 30, 31, 32, 33, 34, 81, 98, 82, 83, 35, 84, 85, 86, - 87, 88, 89, 467, 468, 169, 90, 91, 92, 93, - 36, 99, 37, 38, 39, 40, 41, 42, 217, 159, - 160, 161, 43, 44, 45, 46, 47, 48, 49, 159, - 160, 161, 179, 421, 463, 291, 50, 180, 181, 182, - 183, 124, 195, 184, 392, 378, 411, 429, 51, 52, - 53, 148, -3, 79, 0, 385, 54, 55, 149, 0, + 87, 88, 89, 159, 160, 161, 90, 91, 92, 93, + 36, 474, 37, 38, 39, 40, 41, 42, 441, 159, + 160, 161, 43, 44, 45, 46, 47, 48, 49, 378, + 217, 448, 449, 471, 442, 291, 50, 180, 181, 182, + 183, 455, 124, 184, 195, 385, 392, 411, 51, 52, + 53, 462, -3, 79, 429, 0, 54, 55, 148, 149, 56, 77, 0, 16, 0, 17, 18, 19, 20, 21, 22, 23, 80, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, 81, 98, 82, 83, 35, 84, 85, 86, 87, 88, 89, 0, 0, 0, 90, 91, 92, 93, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, 0, 0, 43, 44, 45, - 46, 47, 48, 49, 0, 0, 0, 77, 0, 179, - 0, 50, 0, 19, 180, 181, 182, 183, 0, 0, - 184, 108, 0, 51, 52, 53, 109, 0, 79, 0, + 46, 47, 48, 49, 0, 0, 0, 179, 0, 0, + 0, 50, 180, 181, 182, 183, 0, 0, 184, 0, + 0, 0, 0, 51, 52, 53, 0, 0, 79, 0, 0, 54, 55, 0, 0, 56, 77, 348, 16, 0, 17, 18, 19, 20, 21, 22, 23, 80, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, 81, 98, 82, 83, 35, 84, 85, 86, 87, 88, 89, 0, 0, 0, 90, 91, 92, 93, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, - 0, 0, 43, 44, 45, 46, 47, 48, 49, 180, - 181, 182, 183, 0, 0, 184, 50, 1, 2, 3, - 4, 5, 6, 0, 0, 0, 0, 0, 51, 52, + 0, 0, 43, 44, 45, 46, 47, 48, 49, 1, + 2, 3, 4, 5, 6, 0, 50, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 51, 52, 53, 0, 0, 79, 0, 0, 54, 55, 0, 0, 56, 77, 447, 16, 0, 17, 18, 19, 20, 21, 22, 23, 80, 0, 0, 24, 25, 26, 27, 28, @@ -600,43 +602,43 @@ static const yytype_int16 yytable[] = 50, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 51, 52, 53, 79, 0, 0, 0, 0, 54, 55, 0, 0, 56, 16, 0, 17, 18, 19, - 20, 21, 22, 23, -67, 0, 0, 24, 25, 26, + 20, 21, 22, 23, -69, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, 0, 0, 0, 0, 35, 0, 0, 0, 0, 0, 0, - 167, 168, 169, 170, 0, 0, 0, 36, 0, 37, + 0, 167, 168, 169, 170, 0, 0, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, 0, 0, 43, - 44, 45, 46, 47, 48, 49, 176, 177, 178, 179, - 0, 0, 0, 50, 180, 181, 182, 183, 0, 0, - 184, 0, 0, 0, 0, 51, 52, 53, 79, 0, - 0, 0, 0, 54, 55, 169, 170, 56, 16, 0, + 44, 45, 46, 47, 48, 49, 175, 176, 177, 178, + 179, 0, 0, 50, 0, 180, 181, 182, 183, 0, + 0, 184, 0, 0, 0, 51, 52, 53, 79, 0, + 0, 0, 0, 54, 55, 0, 0, 56, 16, 0, 17, 18, 19, 20, 21, 22, 23, 0, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, - 33, 34, 179, 0, 0, 0, 35, 180, 181, 182, - 183, 0, 0, 184, 0, 0, 0, 0, 0, 0, + 33, 34, 0, 0, 0, 0, 35, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, - -169, 0, 43, 44, 45, 46, 47, 48, 49, 186, - 0, 187, -169, 0, 0, 0, 50, 0, 0, 0, - -169, 0, 0, 0, 0, 0, 0, 0, 51, 52, - 53, 167, 168, 169, 170, 0, 54, 55, 0, -67, - 56, 0, -169, -169, -169, -169, 0, 0, 0, -169, - 0, -169, 0, 0, -169, 0, 0, 0, 177, 178, - 179, -169, -169, -169, -169, 180, 181, 182, 183, 0, - 0, 184, 0, 0, 0, 0, -169, -169, -169, -208, - -169, -169, -169, -169, -169, -169, -169, -169, -169, -169, - -169, -208, 0, 0, 0, -169, -169, -169, -169, -208, - 0, -169, -169, 0, 0, 0, 0, 0, 0, 0, + -171, 0, 43, 44, 45, 46, 47, 48, 49, 186, + 0, 187, -171, 0, 0, 0, 50, 0, 0, 0, + -171, 0, 0, 0, 0, 0, 0, 0, 51, 52, + 53, 167, 168, 169, 170, 0, 54, 55, 0, -69, + 56, 0, -171, -171, -171, -171, 0, 0, 0, -171, + 0, -171, 0, 0, -171, 0, 0, 176, 177, 178, + 179, -171, -171, -171, -171, 180, 181, 182, 183, 0, + 0, 184, 0, 0, 0, 0, -171, -171, -171, -210, + -171, -171, -171, -171, -171, -171, -171, -171, -171, -171, + -171, -210, 0, 0, 0, -171, -171, -171, -171, -210, + 0, -171, -171, 0, 0, 0, 0, 0, 0, 0, 167, 168, 169, 170, 0, 0, 0, 0, 0, 0, - 0, -208, -208, -208, -208, 0, 0, 0, -208, 0, - -208, 0, 0, -208, 0, 0, 0, 0, 178, 179, - -208, -208, -208, -208, 180, 181, 182, 183, 0, 0, - 184, 0, 0, 0, 0, -208, -208, -208, 0, -208, - -208, -208, -208, -208, -208, -208, -208, -208, -208, -208, - 0, 0, 0, 0, -208, -208, -208, -208, 0, 0, - -208, -208, 77, 0, 16, 0, 17, 18, 19, 20, + 0, -210, -210, -210, -210, 0, 0, 0, -210, 0, + -210, 0, 0, -210, 0, 0, 0, 177, 178, 179, + -210, -210, -210, -210, 180, 181, 182, 183, 0, 0, + 184, 0, 0, 0, 0, -210, -210, -210, 0, -210, + -210, -210, -210, -210, -210, -210, -210, -210, -210, -210, + 0, 0, 0, 0, -210, -210, -210, -210, 0, 0, + -210, -210, 77, 0, 16, 0, 17, 18, 19, 20, 21, 22, 23, 0, 0, 0, 131, 25, 26, 27, 28, 109, 29, 30, 31, 32, 33, 34, 0, 0, - 0, 0, 35, 0, 0, 0, 0, 0, 0, -236, - 0, 169, 170, 0, 0, 0, 36, 0, 37, 38, + 0, 0, 35, 0, 0, 0, 0, 0, 0, 167, + -238, 169, 170, 0, 0, 0, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, 0, 0, 43, 44, 45, 46, 47, 48, 49, 0, 0, 178, 179, 0, 0, 0, 50, 180, 181, 182, 183, 0, 0, 184, @@ -645,7 +647,7 @@ static const yytype_int16 yytable[] = 18, 19, 20, 21, 22, 23, 0, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, 0, 0, 0, 0, 35, 0, 0, 0, 0, - 0, 0, 0, 0, 169, 170, 0, 0, 0, 36, + 0, 0, 167, 168, 169, 170, 0, 0, 0, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, 0, 0, 43, 44, 45, 46, 47, 48, 49, 0, 0, 178, 179, 0, 0, 0, 50, 180, 181, 182, 183, @@ -654,11 +656,11 @@ static const yytype_int16 yytable[] = 16, 104, 17, 18, 19, 20, 21, 22, 23, 0, 0, 0, 24, 25, 26, 27, 28, 0, 29, 30, 31, 32, 33, 34, 0, 0, 0, 0, 35, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, -238, 0, 169, 170, 0, 0, 0, 36, 0, 37, 38, 39, 40, 41, 42, 0, 0, 0, 0, 43, 44, 45, 46, 47, 48, - 49, 0, 0, 0, 0, 0, 0, 0, 50, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 49, 0, 0, 178, 179, 0, 0, 0, 50, 180, + 181, 182, 183, 0, 0, 184, 0, 0, 0, 0, 51, 52, 53, 0, 0, 0, 0, 0, 54, 55, 0, 16, 56, 17, 18, 19, 20, 21, 22, 23, 139, 0, 0, 24, 25, 26, 27, 28, 0, 29, @@ -748,87 +750,81 @@ static const yytype_int16 yytable[] = 183, 0, 0, 184 }; -#define yypact_value_is_default(Yystate) \ - (!!((Yystate) == (-408))) - -#define yytable_value_is_error(Yytable_value) \ - (!!((Yytable_value) == (-236))) - static const yytype_int16 yycheck[] = { - 10, 11, 12, 15, 128, 0, 9, 117, 299, 42, - 12, 418, 299, 16, 301, 302, 15, 50, 11, 396, - 9, 12, 11, 20, 9, 12, 76, 77, 78, 9, + 10, 11, 12, 15, 128, 299, 9, 117, 396, 42, + 418, 9, 299, 16, 301, 302, 15, 50, 11, 0, + 9, 12, 11, 20, 9, 12, 76, 77, 78, 103, 8, 41, 80, 143, 44, 20, 103, 19, 20, 21, 22, 23, 45, 25, 26, 20, 21, 22, 23, 103, - 25, 26, 102, 56, 102, 15, 16, 17, 20, 11, - 42, 43, 103, 470, 26, 442, 48, 42, 43, 46, - 47, 70, 12, 23, 76, 77, 78, 103, 28, 76, + 25, 26, 102, 56, 102, 15, 16, 17, 20, 9, + 42, 43, 470, 11, 26, 15, 48, 42, 43, 23, + 9, 70, 12, 23, 28, 463, 46, 47, 28, 76, 77, 78, 369, 93, 117, 76, 77, 78, 98, 76, - 77, 78, 102, 103, 20, 103, 17, 18, 222, 77, - 23, 80, 135, 12, 103, 98, 12, 9, 90, 12, - 143, 32, 399, 123, 103, 36, 9, 120, 11, 9, - 41, 20, 103, 44, 127, 128, 47, 12, 49, 103, + 77, 78, 102, 103, 103, 103, 17, 18, 222, 77, + 80, 9, 135, 12, 103, 98, 12, 9, 90, 11, + 143, 32, 399, 123, 103, 36, 9, 120, 11, 20, + 41, 48, 20, 44, 127, 128, 47, 12, 49, 23, 51, 52, 53, 54, 55, 12, 76, 77, 78, 20, - 103, 48, 145, 103, 103, 9, 128, 11, 103, 20, - 76, 77, 78, 128, 103, 20, 159, 160, 161, 103, - 163, 164, 165, 454, 9, 452, 11, 76, 77, 78, - 76, 77, 78, 76, 77, 78, 20, 76, 77, 78, - 20, 193, 185, 186, 187, 188, 189, 190, 191, 192, - 223, 76, 77, 78, 102, 76, 77, 78, 208, 76, + 103, 12, 145, 103, 103, 9, 128, 76, 77, 78, + 103, 15, 12, 128, 18, 20, 159, 160, 161, 23, + 163, 164, 165, 26, 28, 452, 103, 76, 77, 78, + 76, 77, 78, 102, 468, 76, 77, 78, 76, 77, + 78, 193, 185, 186, 187, 188, 189, 190, 191, 192, + 223, 76, 77, 78, 10, 76, 77, 78, 208, 76, 77, 78, 184, 103, 314, 76, 77, 78, 211, 212, - 213, 214, 215, 216, 26, 339, 76, 77, 78, 222, + 213, 214, 215, 216, 103, 339, 76, 77, 78, 222, 198, 199, 200, 201, 202, 203, 102, 205, 206, 9, - 233, 11, 76, 77, 78, 10, 76, 77, 78, 242, - 72, 162, 102, 11, 23, 166, 167, 168, 169, 170, + 233, 11, 20, 103, 76, 77, 78, 103, 9, 242, + 11, 162, 72, 102, 20, 166, 167, 168, 169, 170, 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, - 9, 9, 11, 11, 267, 268, 9, 15, 16, 17, - 18, 19, 15, 276, 103, 18, 24, 295, 288, 297, - 23, 314, 23, 72, 394, 28, 102, 269, 76, 77, - 78, 294, 295, 296, 297, 398, 299, 400, 301, 302, - 403, 404, 76, 77, 78, 10, 61, 62, 63, 64, - 26, 414, 415, 11, 102, 420, 298, 65, 78, 422, - 103, 324, 300, 42, 43, 44, 45, 18, 433, 434, - 49, 18, 51, 436, 89, 90, 339, 440, 443, 18, - 95, 96, 97, 98, 18, 18, 101, 23, 453, 21, - 61, 62, 63, 64, 15, 103, 102, 76, 77, 78, - 26, 394, 10, 10, 467, 468, 369, 76, 77, 78, - 10, 349, 10, 10, 352, 86, 87, 88, 89, 90, - 76, 77, 78, 102, 95, 96, 97, 98, 23, 102, - 101, 103, 102, 102, 102, 54, 399, 20, 401, 102, - 412, 102, 61, 62, 63, 64, 102, 328, 102, 42, - 43, 44, 45, 102, 426, 103, 49, 10, 51, 102, - 20, 431, 9, 435, 102, 84, 85, 86, 87, 88, - 89, 90, 9, 74, 20, 445, 95, 96, 97, 98, - 450, 20, 101, 76, 77, 78, 102, 0, 1, 452, - 96, 97, 98, 465, 20, 101, 9, 102, 11, 469, - 13, 14, 15, 16, 17, 18, 19, 20, 22, 103, - 23, 24, 25, 26, 27, 73, 29, 30, 31, 32, + 102, 9, 11, 11, 267, 268, 23, 15, 16, 17, + 18, 19, 9, 276, 11, 103, 24, 20, 288, 23, + 63, 314, 72, 102, 394, 10, 26, 269, 76, 77, + 78, 294, 295, 296, 297, 295, 299, 297, 301, 302, + 76, 77, 78, 398, 11, 400, 78, 90, 403, 404, + 18, 103, 95, 96, 97, 98, 298, 65, 101, 414, + 415, 324, 300, 42, 43, 44, 45, 422, 18, 18, + 49, 18, 51, 76, 77, 78, 339, 76, 77, 78, + 18, 436, 21, 63, 64, 440, 23, 76, 77, 78, + 76, 77, 78, 63, 64, 103, 102, 76, 77, 78, + 15, 394, 26, 102, 10, 10, 369, 10, 10, 89, + 90, 349, 467, 102, 352, 95, 96, 97, 98, 474, + 90, 101, 10, 102, 23, 95, 96, 97, 98, 102, + 102, 101, 96, 97, 98, 54, 399, 101, 103, 102, + 412, 102, 61, 62, 63, 64, 102, 328, 20, 102, + 42, 43, 44, 45, 426, 103, 102, 49, 421, 51, + 10, 431, 102, 435, 20, 84, 85, 86, 87, 88, + 89, 90, 9, 102, 9, 445, 95, 96, 97, 98, + 450, 74, 101, 103, 76, 77, 78, 0, 1, 452, + 20, 20, 102, 465, 102, 20, 9, 73, 11, 469, + 13, 14, 15, 16, 17, 18, 19, 20, 22, 12, + 23, 24, 25, 26, 27, 102, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, - 43, 44, 45, 102, 102, 63, 49, 50, 51, 52, - 53, 12, 55, 56, 57, 58, 59, 60, 98, 76, - 77, 78, 65, 66, 67, 68, 69, 70, 71, 76, - 77, 78, 90, 401, 454, 195, 79, 95, 96, 97, - 98, 35, 83, 101, 351, 102, 392, 411, 91, 92, - 93, 48, 0, 1, -1, 102, 99, 100, 48, -1, + 43, 44, 45, 76, 77, 78, 49, 50, 51, 52, + 53, 102, 55, 56, 57, 58, 59, 60, 420, 76, + 77, 78, 65, 66, 67, 68, 69, 70, 71, 102, + 98, 433, 434, 468, 421, 195, 79, 95, 96, 97, + 98, 443, 35, 101, 83, 102, 351, 392, 91, 92, + 93, 453, 0, 1, 411, -1, 99, 100, 48, 48, 103, 9, -1, 11, -1, 13, 14, 15, 16, 17, 18, 19, 20, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, -1, -1, -1, 49, 50, 51, 52, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, -1, -1, 65, 66, 67, - 68, 69, 70, 71, -1, -1, -1, 9, -1, 90, - -1, 79, -1, 15, 95, 96, 97, 98, -1, -1, - 101, 23, -1, 91, 92, 93, 28, -1, 1, -1, + 68, 69, 70, 71, -1, -1, -1, 90, -1, -1, + -1, 79, 95, 96, 97, 98, -1, -1, 101, -1, + -1, -1, -1, 91, 92, 93, -1, -1, 1, -1, -1, 99, 100, -1, -1, 103, 9, 10, 11, -1, 13, 14, 15, 16, 17, 18, 19, 20, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, -1, -1, -1, 49, 50, 51, 52, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, - -1, -1, 65, 66, 67, 68, 69, 70, 71, 95, - 96, 97, 98, -1, -1, 101, 79, 3, 4, 5, - 6, 7, 8, -1, -1, -1, -1, -1, 91, 92, + -1, -1, 65, 66, 67, 68, 69, 70, 71, 3, + 4, 5, 6, 7, 8, -1, 79, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, 91, 92, 93, -1, -1, 1, -1, -1, 99, 100, -1, -1, 103, 9, 10, 11, -1, 13, 14, 15, 16, 17, 18, 19, 20, -1, -1, 23, 24, 25, 26, 27, @@ -890,23 +886,23 @@ static const yytype_int16 yycheck[] = 16, 17, 18, 19, 20, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, 33, 34, -1, -1, -1, -1, 39, -1, -1, -1, -1, -1, -1, - 61, 62, 63, 64, -1, -1, -1, 53, -1, 55, + -1, 61, 62, 63, 64, -1, -1, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, -1, -1, 65, - 66, 67, 68, 69, 70, 71, 87, 88, 89, 90, - -1, -1, -1, 79, 95, 96, 97, 98, -1, -1, - 101, -1, -1, -1, -1, 91, 92, 93, 1, -1, - -1, -1, -1, 99, 100, 63, 64, 103, 11, -1, + 66, 67, 68, 69, 70, 71, 86, 87, 88, 89, + 90, -1, -1, 79, -1, 95, 96, 97, 98, -1, + -1, 101, -1, -1, -1, 91, 92, 93, 1, -1, + -1, -1, -1, 99, 100, -1, -1, 103, 11, -1, 13, 14, 15, 16, 17, 18, 19, -1, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, - 33, 34, 90, -1, -1, -1, 39, 95, 96, 97, - 98, -1, -1, 101, -1, -1, -1, -1, -1, -1, + 33, 34, -1, -1, -1, -1, 39, -1, -1, -1, + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, 0, -1, 65, 66, 67, 68, 69, 70, 71, 9, -1, 11, 12, -1, -1, -1, 79, -1, -1, -1, 20, -1, -1, -1, -1, -1, -1, -1, 91, 92, 93, 61, 62, 63, 64, -1, 99, 100, -1, 102, 103, -1, 42, 43, 44, 45, -1, -1, -1, 49, - -1, 51, -1, -1, 54, -1, -1, -1, 88, 89, + -1, 51, -1, -1, 54, -1, -1, 87, 88, 89, 90, 61, 62, 63, 64, 95, 96, 97, 98, -1, -1, 101, -1, -1, -1, -1, 76, 77, 78, 0, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, @@ -914,7 +910,7 @@ static const yytype_int16 yycheck[] = -1, 101, 102, -1, -1, -1, -1, -1, -1, -1, 61, 62, 63, 64, -1, -1, -1, -1, -1, -1, -1, 42, 43, 44, 45, -1, -1, -1, 49, -1, - 51, -1, -1, 54, -1, -1, -1, -1, 89, 90, + 51, -1, -1, 54, -1, -1, -1, 88, 89, 90, 61, 62, 63, 64, 95, 96, 97, 98, -1, -1, 101, -1, -1, -1, -1, 76, 77, 78, -1, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, @@ -923,7 +919,7 @@ static const yytype_int16 yycheck[] = 17, 18, 19, -1, -1, -1, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, -1, -1, -1, -1, 39, -1, -1, -1, -1, -1, -1, 61, - -1, 63, 64, -1, -1, -1, 53, -1, 55, 56, + 62, 63, 64, -1, -1, -1, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, -1, -1, 65, 66, 67, 68, 69, 70, 71, -1, -1, 89, 90, -1, -1, -1, 79, 95, 96, 97, 98, -1, -1, 101, @@ -932,7 +928,7 @@ static const yytype_int16 yycheck[] = 14, 15, 16, 17, 18, 19, -1, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, 33, 34, -1, -1, -1, -1, 39, -1, -1, -1, -1, - -1, -1, -1, -1, 63, 64, -1, -1, -1, 53, + -1, -1, 61, 62, 63, 64, -1, -1, -1, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, -1, -1, 65, 66, 67, 68, 69, 70, 71, -1, -1, 89, 90, -1, -1, -1, 79, 95, 96, 97, 98, @@ -941,11 +937,11 @@ static const yytype_int16 yycheck[] = 11, 12, 13, 14, 15, 16, 17, 18, 19, -1, -1, -1, 23, 24, 25, 26, 27, -1, 29, 30, 31, 32, 33, 34, -1, -1, -1, -1, 39, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + -1, -1, -1, -1, -1, 61, -1, 63, 64, -1, -1, -1, 53, -1, 55, 56, 57, 58, 59, 60, -1, -1, -1, -1, 65, 66, 67, 68, 69, 70, - 71, -1, -1, -1, -1, -1, -1, -1, 79, -1, - -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, + 71, -1, -1, 89, 90, -1, -1, -1, 79, 95, + 96, 97, 98, -1, -1, 101, -1, -1, -1, -1, 91, 92, 93, -1, -1, -1, -1, -1, 99, 100, -1, 11, 103, 13, 14, 15, 16, 17, 18, 19, 20, -1, -1, 23, 24, 25, 26, 27, -1, 29, @@ -1044,49 +1040,49 @@ static const yytype_uint8 yystos[] = 16, 17, 18, 19, 23, 24, 25, 26, 27, 29, 30, 31, 32, 33, 34, 39, 53, 55, 56, 57, 58, 59, 60, 65, 66, 67, 68, 69, 70, 71, - 79, 91, 92, 93, 99, 100, 103, 149, 150, 151, - 154, 155, 156, 157, 158, 159, 161, 164, 166, 167, - 168, 169, 170, 171, 172, 173, 174, 9, 112, 1, + 79, 91, 92, 93, 99, 100, 103, 151, 152, 153, + 156, 157, 158, 159, 160, 161, 163, 166, 168, 169, + 170, 171, 172, 173, 174, 175, 176, 9, 112, 1, 20, 35, 37, 38, 40, 41, 42, 43, 44, 45, - 49, 50, 51, 52, 112, 121, 127, 149, 36, 119, - 120, 121, 117, 117, 12, 149, 159, 159, 23, 28, - 112, 167, 175, 175, 175, 175, 175, 175, 175, 160, - 11, 103, 159, 139, 139, 159, 103, 103, 103, 112, - 159, 23, 150, 163, 167, 175, 175, 112, 159, 20, - 149, 23, 28, 141, 159, 103, 162, 167, 168, 169, - 159, 150, 159, 159, 159, 159, 159, 102, 149, 76, + 49, 50, 51, 52, 112, 121, 129, 151, 36, 119, + 120, 121, 117, 117, 12, 151, 161, 161, 23, 28, + 112, 169, 177, 177, 177, 177, 177, 177, 177, 162, + 11, 103, 161, 141, 141, 161, 103, 103, 103, 112, + 161, 23, 152, 165, 169, 177, 177, 112, 161, 20, + 151, 23, 28, 143, 161, 103, 164, 169, 170, 171, + 161, 152, 161, 161, 161, 161, 161, 102, 151, 76, 77, 78, 80, 9, 11, 103, 54, 61, 62, 63, 64, 81, 82, 84, 85, 86, 87, 88, 89, 90, 95, 96, 97, 98, 101, 103, 9, 11, 9, 11, - 9, 11, 9, 114, 140, 141, 23, 138, 103, 103, - 103, 103, 70, 103, 167, 103, 103, 112, 48, 129, + 9, 11, 9, 114, 142, 143, 23, 140, 103, 103, + 103, 103, 70, 103, 169, 103, 103, 112, 48, 131, 20, 42, 43, 44, 45, 49, 51, 120, 121, 119, - 12, 163, 103, 103, 149, 102, 112, 26, 142, 102, - 102, 149, 164, 175, 150, 10, 20, 163, 102, 149, - 72, 144, 11, 102, 149, 149, 149, 159, 149, 149, - 102, 149, 159, 159, 159, 159, 159, 159, 159, 159, - 159, 159, 159, 159, 159, 159, 159, 9, 11, 15, - 16, 17, 18, 19, 24, 65, 103, 153, 167, 102, - 149, 149, 149, 149, 149, 149, 149, 149, 117, 23, - 137, 138, 23, 123, 114, 114, 114, 114, 114, 114, - 103, 114, 114, 112, 149, 133, 149, 149, 149, 149, - 149, 164, 150, 12, 152, 72, 143, 102, 102, 149, - 10, 102, 26, 149, 11, 20, 12, 102, 83, 149, - 149, 18, 18, 18, 18, 18, 18, 102, 149, 103, + 12, 165, 103, 103, 151, 102, 112, 26, 144, 102, + 102, 151, 166, 177, 152, 10, 20, 165, 102, 151, + 72, 146, 11, 102, 151, 151, 151, 161, 151, 151, + 102, 151, 161, 161, 161, 161, 161, 161, 161, 161, + 161, 161, 161, 161, 161, 161, 161, 9, 11, 15, + 16, 17, 18, 19, 24, 65, 103, 155, 169, 102, + 151, 151, 151, 151, 151, 151, 151, 151, 117, 23, + 139, 140, 23, 123, 114, 114, 114, 114, 114, 114, + 103, 114, 114, 112, 151, 135, 151, 151, 151, 151, + 151, 166, 152, 12, 154, 72, 145, 102, 102, 151, + 10, 102, 26, 151, 11, 20, 12, 102, 83, 151, + 151, 18, 18, 18, 18, 18, 18, 102, 151, 103, 102, 20, 12, 20, 12, 20, 12, 20, 10, 21, - 113, 122, 9, 20, 23, 132, 149, 133, 134, 149, - 133, 136, 165, 167, 127, 131, 134, 135, 149, 114, - 134, 134, 102, 102, 163, 26, 114, 147, 102, 12, - 149, 10, 159, 20, 12, 102, 164, 10, 10, 10, - 10, 114, 142, 114, 23, 102, 102, 102, 102, 103, - 102, 20, 134, 102, 102, 103, 145, 12, 10, 102, - 20, 143, 124, 163, 130, 130, 9, 115, 115, 134, - 115, 132, 102, 115, 115, 146, 9, 74, 20, 147, - 148, 117, 20, 115, 115, 116, 46, 47, 128, 128, - 102, 129, 20, 115, 102, 117, 118, 10, 129, 129, - 117, 115, 103, 115, 130, 129, 10, 20, 26, 125, - 10, 134, 129, 135, 22, 73, 126, 102, 102, 117, - 115, 115, 74, 128 + 113, 122, 9, 20, 23, 134, 151, 135, 136, 151, + 135, 138, 167, 169, 129, 133, 136, 137, 151, 114, + 136, 136, 102, 102, 165, 26, 114, 149, 102, 12, + 151, 10, 161, 20, 12, 102, 166, 10, 10, 10, + 10, 114, 144, 114, 23, 102, 102, 102, 102, 103, + 102, 20, 136, 102, 102, 103, 147, 12, 10, 102, + 20, 145, 126, 165, 132, 132, 9, 115, 115, 136, + 115, 124, 102, 115, 115, 148, 9, 74, 20, 149, + 150, 117, 20, 115, 115, 116, 46, 47, 130, 130, + 102, 131, 134, 115, 102, 117, 118, 10, 131, 131, + 117, 115, 103, 115, 20, 131, 10, 20, 26, 127, + 10, 136, 131, 125, 22, 73, 128, 102, 132, 117, + 115, 137, 74, 130, 102, 115 }; typedef enum { @@ -1110,21 +1106,21 @@ static const toketypes yy_type_tab[] = toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, - toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, toketype_opval, + toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, + toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, - toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_ival, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_ival, + toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, + toketype_opval, toketype_opval, toketype_opval, toketype_ival, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, - toketype_opval, toketype_opval, toketype_opval, toketype_opval + toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval, toketype_opval }; /* Generated from: - * 7e6c275bbd1dbc800c205a8a8b0cd785e4859f94976ee7372149598471f16f81 perly.y + * 39b6174c4729deec2a6ee4698d7dcd6496acb0a8f063daf726d1f853d4dcb54e perly.y * d1d4df7b8e30ac9dede664af9179e6e5e7ddc7f2ad9c4eff9e2e5b32c9e16a6e regen_perly.pl * ex: set ro: */ diff --git a/perly.y b/perly.y index de90b2a..77773fd 100644 --- a/perly.y +++ b/perly.y @@ -112,7 +112,7 @@ /* Top-level choice of what kind of thing yyparse was called to parse */ grammar : GRAMPROG { - PL_parser->expect = XSTATE; + parser->expect = XSTATE; } remember stmtseq { @@ -177,16 +177,16 @@ grammar : GRAMPROG /* An ordinary block */ block : '{' remember stmtseq '}' - { if (PL_parser->copline > (line_t)$1) - PL_parser->copline = (line_t)$1; + { if (parser->copline > (line_t)$1) + parser->copline = (line_t)$1; $$ = block_end($2, $3); } ; /* format body */ formblock: '=' remember ';' FORMRBRACK formstmtseq ';' '.' - { if (PL_parser->copline > (line_t)$1) - PL_parser->copline = (line_t)$1; + { if (parser->copline > (line_t)$1) + parser->copline = (line_t)$1; $$ = block_end($2, $5); } ; @@ -196,8 +196,8 @@ remember: /* NULL */ /* start a full lexical scope */ ; mblock : '{' mremember stmtseq '}' - { if (PL_parser->copline > (line_t)$1) - PL_parser->copline = (line_t)$1; + { if (parser->copline > (line_t)$1) + parser->copline = (line_t)$1; $$ = block_end($2, $3); } ; @@ -279,8 +279,8 @@ barestmt: PLUGSTMT CvOUTSIDE(PL_compcv) ))[$2->op_targ])) CvCLONE_on(PL_compcv); - PL_parser->in_my = 0; - PL_parser->in_my_stash = NULL; + parser->in_my = 0; + parser->in_my_stash = NULL; } proto subattrlist optsubbody { @@ -311,13 +311,13 @@ barestmt: PLUGSTMT { $$ = block_end($3, newCONDOP(0, $4, op_scope($6), $7)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | UNLESS '(' remember miexpr ')' mblock else { $$ = block_end($3, newCONDOP(0, $4, op_scope($6), $7)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | GIVEN '(' remember mexpr ')' mblock { @@ -328,7 +328,7 @@ barestmt: PLUGSTMT || PAD_COMPNAME_FLAGS_isOUR(offset) ? 0 : offset)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | WHEN '(' remember mexpr ')' mblock { $$ = block_end($3, newWHENOP($4, op_scope($6))); } @@ -339,21 +339,25 @@ barestmt: PLUGSTMT $$ = block_end($3, newWHILEOP(0, 1, (LOOP*)(OP*)NULL, $4, $7, $8, $6)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | UNTIL '(' remember iexpr ')' mintro mblock cont { $$ = block_end($3, newWHILEOP(0, 1, (LOOP*)(OP*)NULL, $4, $7, $8, $6)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } - | FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')' + | FOR '(' remember mnexpr ';' + { parser->expect = XTERM; } + texpr ';' + { parser->expect = XTERM; } + mintro mnexpr ')' mblock { OP *initop = $4; OP *forop = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, - scalar($6), $11, $9, $8); + scalar($7), $13, $11, $10); if (initop) { forop = op_prepend_elem(OP_LINESEQ, initop, op_append_elem(OP_LINESEQ, @@ -361,24 +365,24 @@ barestmt: PLUGSTMT forop)); } $$ = block_end($3, forop); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | FOR MY remember my_scalar '(' mexpr ')' mblock cont { $$ = block_end($3, newFOROP(0, $4, $6, $8, $9)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | FOR scalar '(' remember mexpr ')' mblock cont { $$ = block_end($4, newFOROP(0, op_lvalue($2, OP_ENTERLOOP), $5, $7, $8)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | FOR '(' remember mexpr ')' mblock cont { $$ = block_end($3, newFOROP(0, (OP*)NULL, $4, $6, $7)); - PL_parser->copline = (line_t)$1; + parser->copline = (line_t)$1; } | block cont { @@ -398,19 +402,17 @@ barestmt: PLUGSTMT /* a block is a loop that happens once */ $$ = newWHILEOP(0, 1, (LOOP*)(OP*)NULL, (OP*)NULL, block_end($5, $7), (OP*)NULL, 0); - if (PL_parser->copline > (line_t)$4) - PL_parser->copline = (line_t)$4; + if (parser->copline > (line_t)$4) + parser->copline = (line_t)$4; } | sideff ';' { - PL_parser->expect = XSTATE; $$ = $1; } | ';' { - PL_parser->expect = XSTATE; $$ = (OP*)NULL; - PL_parser->copline = NOLINE; + parser->copline = NOLINE; } ; @@ -424,9 +426,9 @@ formline: THING formarg else { list = $1; } - if (PL_parser->copline == NOLINE) - PL_parser->copline = CopLINE(PL_curcop)-1; - else PL_parser->copline--; + if (parser->copline == NOLINE) + parser->copline = CopLINE(PL_curcop)-1; + else parser->copline--; $$ = newSTATEOP(0, NULL, convert(OP_FORMLINE, 0, list)); } @@ -453,7 +455,7 @@ sideff : error { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1); } | expr FOR expr { $$ = newFOROP(0, (OP*)NULL, $3, $1, (OP*)NULL); - PL_parser->copline = (line_t)$2; } + parser->copline = (line_t)$2; } | expr WHEN expr { $$ = newWHENOP($3, op_scope($1)); } ; @@ -467,7 +469,7 @@ else : /* NULL */ $$ = op_scope($2); } | ELSIF '(' mexpr ')' mblock else - { PL_parser->copline = (line_t)$1; + { parser->copline = (line_t)$1; $$ = newCONDOP(0, newSTATEOP(OPf_SPECIAL,NULL,$3), op_scope($5), $6); @@ -583,15 +585,15 @@ subsignature: /* NULL */ { $$ = (OP*)NULL; } { $$ = op_append_list(OP_LINESEQ, $2, newSTATEOP(0, NULL, sawparens(newNULLLIST()))); - PL_parser->expect = XBLOCK; + parser->expect = XBLOCK; } ; /* Subroutine body - block with optional signature */ realsubbody: remember subsignature '{' stmtseq '}' { - if (PL_parser->copline > (line_t)$3) - PL_parser->copline = (line_t)$3; + if (parser->copline > (line_t)$3) + parser->copline = (line_t)$3; $$ = block_end($1, op_append_list(OP_LINESEQ, $2, $4)); } @@ -599,9 +601,7 @@ realsubbody: remember subsignature '{' stmtseq '}' /* Optional subroutine body, for named subroutine declaration */ optsubbody: realsubbody { $$ = $1; } - | ';' { $$ = (OP*)NULL; - PL_parser->expect = XSTATE; - } + | ';' { $$ = (OP*)NULL; } ; /* Ordinary expressions; logical combinations */ @@ -680,9 +680,7 @@ method : METHOD subscripted: gelem '{' expr ';' '}' /* *main::{something} */ /* In this and all the hash accessors, ';' is * provided by the tokeniser */ - { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); - PL_parser->expect = XOPERATOR; - } + { $$ = newBINOP(OP_GELEM, 0, $1, scalar($3)); } | scalar '[' expr ']' /* $array[$element] */ { $$ = newBINOP(OP_AELEM, 0, oopsAV($1), scalar($3)); } @@ -698,20 +696,15 @@ subscripted: gelem '{' expr ';' '}' /* *main::{something} */ } | scalar '{' expr ';' '}' /* $foo{bar();} */ { $$ = newBINOP(OP_HELEM, 0, oopsHV($1), jmaybe($3)); - PL_parser->expect = XOPERATOR; } | term ARROW '{' expr ';' '}' /* somehref->{bar();} */ { $$ = newBINOP(OP_HELEM, 0, ref(newHVREF($1),OP_RV2HV), - jmaybe($4)); - PL_parser->expect = XOPERATOR; - } + jmaybe($4)); } | subscripted '{' expr ';' '}' /* $foo->[bar]->{baz;} */ { $$ = newBINOP(OP_HELEM, 0, ref(newHVREF($1),OP_RV2HV), - jmaybe($3)); - PL_parser->expect = XOPERATOR; - } + jmaybe($3)); } | term ARROW '(' ')' /* $subref->() */ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED, newCVREF(0, scalar($1))); } @@ -886,7 +879,6 @@ term : termbinop if ($$ && $1) $$->op_private |= $1->op_private & OPpSLICEWARNING; - PL_parser->expect = XOPERATOR; } | kvslice '{' expr ';' '}' /* %hash{@keys} */ { $$ = op_prepend_elem(OP_KVHSLICE, @@ -897,7 +889,6 @@ term : termbinop if ($$ && $1) $$->op_private |= $1->op_private & OPpSLICEWARNING; - PL_parser->expect = XOPERATOR; } | THING %prec '(' { $$ = $1; } @@ -1024,7 +1015,7 @@ optexpr: /* NULL */ /* A little bit of trickery to make "for my $foo (@bar)" actually be lexical */ my_scalar: scalar - { PL_parser->in_my = 0; $$ = my($1); } + { parser->in_my = 0; $$ = my($1); } ; amper : '&' indirob diff --git a/plan9/config.plan9 b/plan9/config.plan9 index 0ca8f85..2549388 100644 --- a/plan9/config.plan9 +++ b/plan9/config.plan9 @@ -3373,8 +3373,8 @@ * This symbol contains the ~name expanded version of PRIVLIB, to be used * in programs that are not prepared to deal with ~ expansion at run-time. */ -#define PRIVLIB "/sys/lib/perl/5.21.3" /**/ -#define PRIVLIB_EXP "/sys/lib/perl/5.21.3" /**/ +#define PRIVLIB "/sys/lib/perl/5.21.4" /**/ +#define PRIVLIB_EXP "/sys/lib/perl/5.21.4" /**/ /* PTRSIZE: * This symbol contains the size of a pointer, so that the C preprocessor @@ -3501,9 +3501,9 @@ * removed. The elements in inc_version_list (inc_version_list.U) can * be tacked onto this variable to generate a list of directories to search. */ -#define SITELIB "/sys/lib/perl/5.21.3/site_perl" /**/ -#define SITELIB_EXP "/sys/lib/perl/5.21.3/site_perl" /**/ -#define SITELIB_STEM "/sys/lib/perl/5.21.3/site_perl" /**/ +#define SITELIB "/sys/lib/perl/5.21.4/site_perl" /**/ +#define SITELIB_EXP "/sys/lib/perl/5.21.4/site_perl" /**/ +#define SITELIB_STEM "/sys/lib/perl/5.21.4/site_perl" /**/ /* Size_t_size: * This symbol holds the size of a Size_t in bytes. diff --git a/plan9/config_sh.sample b/plan9/config_sh.sample index bbe15af..67cc84f 100644 --- a/plan9/config_sh.sample +++ b/plan9/config_sh.sample @@ -32,12 +32,12 @@ alignbytes='4' ansi2knr='' aphostname='/bin/uname -n' api_revision='5' -api_subversion='3' +api_subversion='4' api_version='21' -api_versionstring='5.21.3' +api_versionstring='5.21.4' ar='ar' -archlib='/sys/lib/perl5/5.21.3/386' -archlibexp='/sys/lib/perl5/5.21.3/386' +archlib='/sys/lib/perl5/5.21.4/386' +archlibexp='/sys/lib/perl5/5.21.4/386' archname64='' archname='386' archobjs='' @@ -106,6 +106,7 @@ d_SCNfldbl='define' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='define' d_archlib='define' @@ -191,6 +192,7 @@ d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='undef' d_fds_bits='undef' +d_fegetround='undef' d_fgetpos='define' d_finite='undef' d_finitel='undef' @@ -199,10 +201,13 @@ d_flock='undef' d_flockproto='undef' d_fork='define' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='define' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -294,9 +299,13 @@ d_ipv6_mreq_source='undef' d_isascii='undef' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='undef' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='define' @@ -519,6 +528,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' @@ -648,6 +658,7 @@ i_dirent='define' i_dlfcn='undef' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -676,6 +687,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='define' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -683,6 +695,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -730,17 +743,17 @@ inc_version_list=' ' inc_version_list_init='0' incpath='' inews='' -installarchlib='/sys/lib/perl/5.21.3/386' +installarchlib='/sys/lib/perl/5.21.4/386' installbin='/usr/bin' installman1dir='/sys/man/1pub' installman3dir='/sys/man/2pub' installprefix='/usr' installprefixexp='/usr' -installprivlib='/sys/lib/perl/5.21.3' +installprivlib='/sys/lib/perl/5.21.4' installscript='/usr/bin' -installsitearch='/sys/lib/perl/5.21.3/site_perl/386' +installsitearch='/sys/lib/perl/5.21.4/site_perl/386' installsitebin='/usr/bin' -installsitelib='/sys/lib/perl/5.21.3/site_perl' +installsitelib='/sys/lib/perl/5.21.4/site_perl' installstyle='lib/perl5' installusrbinperl='undef' installvendorarch='' @@ -861,8 +874,8 @@ pmake='' pr='' prefix='/usr' prefixexp='/usr' -privlib='/sys/lib/perl/5.21.3' -privlibexp='/sys/lib/perl/5.21.3' +privlib='/sys/lib/perl/5.21.4' +privlibexp='/sys/lib/perl/5.21.4' procselfexe='' prototype='define' ptrsize='4' @@ -927,13 +940,13 @@ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 sig_num_init='0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 0' sig_size='50' signal_t='void' -sitearch='/sys/lib/perl/5.21.3/site_perl/386' +sitearch='/sys/lib/perl/5.21.4/site_perl/386' sitearchexp='/sys/lib/perl/site_perl/386' sitebin='/usr/bin' sitebinexp='/usr/bin' -sitelib='/sys/lib/perl/5.21.3/site_perl' -sitelib_stem='/sys/lib/perl/5.21.3/site_perl' -sitelibexp='/sys/lib/perl/5.21.3/site_perl' +sitelib='/sys/lib/perl/5.21.4/site_perl' +sitelib_stem='/sys/lib/perl/5.21.4/site_perl' +sitelibexp='/sys/lib/perl/5.21.4/site_perl' siteprefix='/usr' siteprefixexp='/usr' sizesize='4' @@ -966,7 +979,7 @@ stdio_stream_array='' strerror_r_proto='0' strings='/sys/include/ape/string.h' submit='' -subversion='3' +subversion='4' sysman='/sys/man/1pub' tail='' tar='' @@ -1021,6 +1034,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='define' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='false' @@ -1047,8 +1061,8 @@ vendorlib_stem='' vendorlibexp='' vendorprefix='' vendorprefixexp='' -version='5.21.3' -version_patchlevel_string='version 21 subversion 3' +version='5.21.4' +version_patchlevel_string='version 21 subversion 4' versiononly='undef' vi='' xlibpth='' @@ -1062,9 +1076,9 @@ config_args='' config_argc=0 PERL_REVISION=5 PERL_VERSION=21 -PERL_SUBVERSION=3 +PERL_SUBVERSION=4 PERL_API_REVISION=5 PERL_API_VERSION=21 -PERL_API_SUBVERSION=3 +PERL_API_SUBVERSION=4 PERL_PATCHLEVEL= PERL_CONFIG_SH=true diff --git a/pod/.gitignore b/pod/.gitignore index 63b25c4..48857fe 100644 --- a/pod/.gitignore +++ b/pod/.gitignore @@ -53,7 +53,7 @@ /roffitall # generated -/perl5213delta.pod +/perl5214delta.pod /perlapi.pod /perlintern.pod *.html diff --git a/pod/perl.pod b/pod/perl.pod index 5599bc2..111bd52 100644 --- a/pod/perl.pod +++ b/pod/perl.pod @@ -179,10 +179,12 @@ aux a2p c2ph h2ph h2xs perlbug pl2pm pod2html pod2man s2p splain xsubpp perlhist Perl history records perldelta Perl changes since previous version + perl5213delta Perl changes in version 5.21.3 perl5212delta Perl changes in version 5.21.2 perl5211delta Perl changes in version 5.21.1 perl5210delta Perl changes in version 5.21.0 perl5200delta Perl changes in version 5.20.0 + perl5201delta Perl changes in version 5.20.1 perl5182delta Perl changes in version 5.18.2 perl5181delta Perl changes in version 5.18.1 perl5180delta Perl changes in version 5.18.0 diff --git a/pod/perl5201delta.pod b/pod/perl5201delta.pod new file mode 100644 index 0000000..9352801 --- /dev/null +++ b/pod/perl5201delta.pod @@ -0,0 +1,410 @@ +=encoding utf8 + +=head1 NAME + +perl5201delta - what is new for perl v5.20.1 + +=head1 DESCRIPTION + +This document describes differences between the 5.20.0 release and the 5.20.1 +release. + +If you are upgrading from an earlier release such as 5.18.0, first read +L, which describes differences between 5.18.0 and 5.20.0. + +=head1 Incompatible Changes + +There are no changes intentionally incompatible with 5.20.0. If any exist, +they are bugs, and we request that you submit a report. See L +below. + +=head1 Performance Enhancements + +=over 4 + +=item * + +An optimization to avoid problems with COW and deliberately overallocated PVs +has been disabled because it interfered with another, more important, +optimization, causing a slowdown on some platforms. +L<[perl #121975]|https://rt.perl.org/Ticket/Display.html?id=121975> + +=item * + +Returning a string from a lexical variable could be slow in some cases. This +has now been fixed. +L<[perl #121977]|https://rt.perl.org/Ticket/Display.html?id=121977> + +=back + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 0.20 to 0.22. + +The list of Perl versions covered has been updated and some flaws in the +parsing have been fixed. + +=item * + +L has been upgraded from version 5.70 to 5.71. + +Illegal POD syntax in the documentation has been corrected. + +=item * + +L has been upgraded from version 0.280216 to 0.280217. + +Android builds now link to both B<-lperl> and C<$Config::Config{perllibs}>. + +=item * + +L has been upgraded from version 2.29 to 2.30. + +The documentation now notes that C will not overwrite read-only files. + +=item * + +L has been upgraded from version 3.11 to 5.020001. + +The list of Perl versions covered has been updated. + +=item * + +The PathTools module collection has been upgraded from version 3.47 to 3.48. + +Fallbacks are now in place when cross-compiling for Android and +C<$Config::Config{sh}> is not yet defined. +L<[perl #121963]|https://rt.perl.org/Ticket/Display.html?id=121963> + +=item * + +L has been upgraded from version 0.14 to 0.15. + +A minor portability improvement has been made to the XS implementation. + +=item * + +L has been upgraded from version 0.57 to 0.58. + +The documentation includes many clarifications and fixes. + +=item * + +L has been upgraded from version 1.13 to 1.13_01. + +The documentation has some minor formatting improvements. + +=item * + +L has been upgraded from version 0.9908 to 0.9909. + +External libraries and Perl may have different ideas of what the locale is. +This is problematic when parsing version strings if the locale's numeric +separator has been changed. Version parsing has been patched to ensure it +handles the locales correctly. +L<[perl #121930]|https://rt.perl.org/Ticket/Display.html?id=121930> + +=back + +=head1 Documentation + +=head2 Changes to Existing Documentation + +=head3 L + +=over 4 + +=item * + +C - Emphasize that this returns the highest index in the array, not the +size of the array. +L<[perl #120386]|https://rt.perl.org/Ticket/Display.html?id=120386> + +=item * + +Note that C doesn't do set magic. + +=item * + +C - Fix documentation to mention the use of C instead of +C. +L<[perl #121869]|https://rt.perl.org/Ticket/Display.html?id=121869> + +=item * + +Clarify where C may be embedded or is required to terminate a string. + +=back + +=head3 L + +=over 4 + +=item * + +Clarify the meaning of C<-B> and C<-T>. + +=item * + +C<-l> now notes that it will return false if symlinks aren't supported by the +file system. +L<[perl #121523]|https://rt.perl.org/Ticket/Display.html?id=121523> + +=item * + +Note that C, C and C may produce different orderings for +tied hashes compared to other perl hashes. +L<[perl #121404]|https://rt.perl.org/Ticket/Display.html?id=121404> + +=item * + +Note that C and C may fall back to the shell on Win32. +Only C and C indirect object syntax +will reliably avoid using the shell. This has also been noted in L. +L<[perl #122046]|https://rt.perl.org/Ticket/Display.html?id=122046> + +=item * + +Clarify the meaning of C. +L<[perl #122132]|https://rt.perl.org/Ticket/Display.html?id=122132> + +=back + +=head3 L + +=over 4 + +=item * + +Explain various ways of modifying an existing SV's buffer. +L<[perl #116925]|https://rt.perl.org/Ticket/Display.html?id=116925> + +=back + +=head3 L + +=over 4 + +=item * + +We now have a code of conduct for the I<< p5p >> mailing list, as documented in +L<< perlpolicy/STANDARDS OF CONDUCT >>. + +=back + +=head3 L + +=over 4 + +=item * + +The C modifier has been clarified to note that comments cannot be continued +onto the next line by escaping them. + +=back + +=head3 L + +=over 4 + +=item * + +Mention the use of empty conditionals in C/C loops for infinite +loops. + +=back + +=head3 L + +=over 4 + +=item * + +Added a discussion of locale issues in XS code. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +L%sE|perldiag/"Variable length lookbehind not implemented in regex m/%s/"> + +Information about Unicode behaviour has been added. + +=back + +=head1 Configuration and Compilation + +=over 4 + +=item * + +Building Perl no longer writes to the source tree when configured with +F's B<-Dmksymlinks> option. +L<[perl #121585]|https://rt.perl.org/Ticket/Display.html?id=121585> + +=back + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item Android + +Build support has been improved for cross-compiling in general and for Android +in particular. + +=item OpenBSD + +Corrected architectures and version numbers used in configuration hints when +building Perl. + +=item Solaris + +B options have been cleaned up, hints look for B as well as +B, and support for native C has been added. + +=item VMS + +An old bug in feature checking, mainly affecting pre-7.3 systems, has been +fixed. + +=item Windows + +C<%I64d> is now being used instead of C<%lld> for MinGW. + +=back + +=head1 Internal Changes + +=over 4 + +=item * + +Added L. +Changing the program's locale should be avoided by XS code. Nevertheless, +certain non-Perl libraries called from XS, such as C do so. When this +happens, Perl needs to be told that the locale has changed. Use this function +to do so, before returning to Perl. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +A bug has been fixed where zero-length assertions and code blocks inside of a +regex could cause C to see an incorrect value. +L<[perl #122460]|https://rt.perl.org/Ticket/Display.html?id=122460> + +=item * + +Using C on tainted utf8 strings could issue bogus "Malformed UTF-8 +character (unexpected end of string)" warnings. This has now been fixed. +L<[perl #122148]|https://rt.perl.org/Ticket/Display.html?id=122148> + +=item * + +C and friends should now work properly on more Android builds. + +Due to an oversight, the value specified through B<-Dtargetsh> to F +would end up being ignored by some of the build process. This caused perls +cross-compiled for Android to end up with defective versions of C, +C and backticks: the commands would end up looking for F instead +of F, and so would fail for the vast majority of devices, +leaving C<$!> as C. + +=item * + +Many issues have been detected by L and +fixed. + +=back + +=head1 Acknowledgements + +Perl 5.20.1 represents approximately 4 months of development since Perl 5.20.0 +and contains approximately 12,000 lines of changes across 170 files from 36 +authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 2,600 lines of changes to 110 .pm, .t, .c and .h files. + +Perl continues to flourish into its third decade thanks to a vibrant community +of users and developers. The following people are known to have contributed +the improvements that became Perl 5.20.1: + +Aaron Crane, Abigail, Alberto Simões, Alexandr Ciornii, Alexandre (Midnite) +Jousset, Andrew Fresh, Andy Dougherty, Brian Fraser, Chris 'BinGOs' Williams, +Craig A. Berry, Daniel Dragan, David Golden, David Mitchell, H.Merijn Brand, +James E Keenan, Jan Dubois, Jarkko Hietaniemi, John Peacock, kafka, Karen +Etheridge, Karl Williamson, Lukas Mai, Matthew Horsfall, Michael Bunk, Peter +Martini, Rafael Garcia-Suarez, Reini Urban, Ricardo Signes, Shirakata Kentaro, +Smylers, Steve Hay, Thomas Sibley, Todd Rinaldo, Tony Cook, Vladimir Marek, +Yves Orton. + +The list above is almost certainly incomplete as it is automatically generated +from version control history. In particular, it does not include the names of +the (very much appreciated) contributors who reported issues to the Perl bug +tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please see +the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles recently +posted to the comp.lang.perl.misc newsgroup and the perl bug database at +https://rt.perl.org/ . There may also be information at http://www.perl.org/ , +the Perl Home Page. + +If you believe you have an unreported bug, please run the L program +included with your release. Be sure to trim your bug down to a tiny but +sufficient test case. Your bug report, along with the output of C, +will be sent off to perlbug@perl.org to be analysed by the Perl porting team. + +If the bug you are reporting has security implications, which make it +inappropriate to send to a publicly archived mailing list, then please send it +to perl5-security-report@perl.org. This points to a closed subscription +unarchived mailing list, which includes all the core committers, who will be +able to help assess the impact of issues, figure out a resolution, and help +co-ordinate the release of patches to mitigate or fix the problem across all +platforms on which Perl is supported. Please only use this address for +security issues in the Perl core, not for modules independently distributed on +CPAN. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perl5213delta.pod b/pod/perl5213delta.pod new file mode 100644 index 0000000..58b86a2 --- /dev/null +++ b/pod/perl5213delta.pod @@ -0,0 +1,422 @@ +=encoding utf8 + +=head1 NAME + +perl5213delta - what is new for perl v5.21.3 + +=head1 DESCRIPTION + +This document describes differences between the 5.21.2 release and the 5.21.3 +release. + +If you are upgrading from an earlier release such as 5.21.1, first read +L, which describes differences between 5.21.1 and 5.21.2. + +=head1 Core Enhancements + +=head2 C is no longer fatal + +In 5.21.1, C was made fatal. This has been relaxed +to not die if the argument is assigning to an array. + +=head2 Floating point parsing has been improved + +Parsing and printing of floating point values has been improved. + +As a completely new feature, hexadecimal floating point literals +(like 0x1.23p-4) are now supported, and they can be output with +C. + +=head1 Security + +=head2 The L module could allow outside packages to be replaced + +Critical bugfix: outside packages could be replaced. L has +been patched to 2.38 to address this. + +=head1 Incompatible Changes + +=head2 S> is now a fatal error + +Importing functions from C has been deprecated since v5.12, and +is now a fatal error. S> without any arguments is still +allowed. + +=head1 Modules and Pragmata + +=head2 Updated Modules and Pragmata + +=over 4 + +=item * + +L has been upgraded from version 1.19 to 1.21. + +=item * + +L has been upgraded from version 0.20 to 0.22. + +=item * + +L has been upgraded from version 2.141520 to 2.142060. + +=item * + +L has been upgraded from version 2.125 to 2.126. + +=item * + +L was moved from F to F. + +=item * + +L has been upgraded from version 0.280216 to 0.280217. + +=item * + +L was moved from F to F. + +=item * + +L has been upgraded from version 1.64 to 1.65. +It was also moved from F to F. + +=item * + +L has been upgraded from version 0.043 to 0.047. + +=item * + +L has been upgraded from version 1.17 to 1.18. + +=item * + +L has been upgraded from version 5.021002 to 5.021003. + +=item * + +L has been upgraded from version 1.27 to 1.28. + +=item * + +L has been upgraded from version 1.45 to 1.46. + +=item * + +L has been upgraded from version 5.0150044 to 5.0150045. + +=item * + +L has been upgraded from version 1.41 to 1.42. + +=item * + +L has been upgraded from version 2.37 to 2.38. + +=item * + +L has been upgraded from version 2.014 to 2.015. + +=item * + +L has been upgraded from version 1.18 to 1.19 + +=item * + +L has been upgraded from version 1.11 to 1.12. + +=back + +=head1 Documentation + +=head2 Changes to Existing Documentation + +=head3 L + +=over 4 + +=item * + +Added reference to L. + +=back + +=head3 L + +=over 4 + +=item * + +Details on C level symbols and libperl.t added. + +=back + +=head3 L + +=over 4 + +=item * + +Recommended replacements for tmpfile, atoi, strtol, and strtoul added. + +=back + +=head3 L + +=over 4 + +=item * + +ASCII v. EBCDIC clarifications added. + +=back + +=head3 L + +=over 4 + +=item * + +Comments added on algorithmic complexity and tied hashes. + +=back + +=head3 L + +=over 4 + +=item * + +Updated documentation on environment and shell interaction in VMS. + +=back + +=head1 Diagnostics + +The following additions or changes have been made to diagnostic output, +including warnings and fatal error messages. For the complete list of +diagnostic messages, see L. + +=head2 New Diagnostics + +=head3 New Errors + +=over 4 + +=item * + +L + +(F) Something went horribly bad in hexadecimal float handling. + +=item * + +L + +(F) You have configured Perl to use long doubles but +the internals of the long double format are unknown, +therefore the hexadecimal float output is impossible. + +=back + +=head3 New Warnings + +=over 4 + +=item * + +L + +(W overflow) The hexadecimal floating point has larger exponent +than the floating point supports. + +=item * + +L + +(W overflow) The hexadecimal floating point has smaller exponent +than the floating point supports. + +=item * + +L + +(W overflow) The hexadecimal floating point literal had more bits in +the mantissa (the part between the 0x and the exponent, also known as +the fraction or the significand) than the floating point supports. + +=item * + +L + +(W overflow) The hexadecimal floating point had internally more +digits than could be output. This can be caused by unsupported +long double formats, or by 64-bit integers not being available +(needed to retrieve the digits under some configurations). + +=back + +=head2 Changes to Existing Diagnostics + +=over 4 + +=item * + +C with no argument or undef used to warn about a Null filename; now +it dies with C. + +=back + +=head1 Configuration and Compilation + +=over 4 + +=item * + +MurmurHash64A and MurmurHash64B can now be configured as the internal hash +function. + +=back + +=head1 Platform Support + +=head2 Platform-Specific Notes + +=over 4 + +=item Android + +Build support has been improved for cross-compiling in general and for +Android in particular. + +=item Solaris + +C options have been cleaned up, hints look for C +as well as C, and support for native C has been added. + +=item VMS + +C, C, and C detection has been added to +C, environment handling has had some minor changes, and +a fix for legacy feature checking status. + +=item Windows + +C<%I64d> is now being used instead of C<%lld> for MinGW. + +=back + +=head1 Internal Changes + +=over 4 + +=item * + +Added L. +Changing the program's locale should be avoided by XS code. Nevertheless, +certain non-Perl libraries called from XS, such as C do so. When this +happens, Perl needs to be told that the locale has changed. Use this function +to do so, before returning to Perl. + +=item * + +Added L as a safer replacement for atoi and strtol. + +=back + +=head1 Selected Bug Fixes + +=over 4 + +=item * + +Failing to compile C in an eval could leave a spurious +C subroutine definition, which would produce a "Subroutine +BEGIN redefined" warning on the next use of C, or other C +block. [perl #122107] + +=item * + +C syntax now correctly parses the arguments if they +begin with an opening brace. [perl #46947] + +=item * + +External libraries and Perl may have different ideas of what the locale is. +This is problematic when parsing version strings if the locale's numeric +separator has been changed. Version parsing has been patched to ensure +it handles the locales correctly. [perl #121930] + +=item * + +A bug has been fixed where zero-length assertions and code blocks inside of a +regex could cause C to see an incorrect value. [perl #122460] + +=back + +=head1 Acknowledgements + +Perl 5.21.3 represents approximately 4 weeks of development since Perl 5.21.2 +and contains approximately 21,000 lines of changes across 250 files from 25 +authors. + +Excluding auto-generated files, documentation and release tools, there were +approximately 18,000 lines of changes to 160 .pm, .t, .c and .h files. + +Perl continues to flourish into its third decade thanks to a vibrant community +of users and developers. The following people are known to have contributed the +improvements that became Perl 5.21.3: + +Aaron Crane, Abigail, Alberto Simões, Andy Dougherty, Brian Fraser, Chad +Granum, Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari Mannsåker, +Daniel Dragan, David Mitchell, Father Chrysostomos, H.Merijn Brand, James E +Keenan, Jan Dubois, Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Lukas +Mai, Peter Martini, Rafael Garcia-Suarez, syber, Tony Cook, Vladimir Marek, +Yves Orton. + +The list above is almost certainly incomplete as it is automatically generated +from version control history. In particular, it does not include the names of +the (very much appreciated) contributors who reported issues to the Perl bug +tracker. + +Many of the changes included in this version originated in the CPAN modules +included in Perl's core. We're grateful to the entire CPAN community for +helping Perl to flourish. + +For a more complete list of all of Perl's historical contributors, please see +the F file in the Perl source distribution. + +=head1 Reporting Bugs + +If you find what you think is a bug, you might check the articles recently +posted to the comp.lang.perl.misc newsgroup and the perl bug database at +https://rt.perl.org/ . There may also be information at +http://www.perl.org/ , the Perl Home Page. + +If you believe you have an unreported bug, please run the L program +included with your release. Be sure to trim your bug down to a tiny but +sufficient test case. Your bug report, along with the output of C, +will be sent off to perlbug@perl.org to be analysed by the Perl porting team. + +If the bug you are reporting has security implications, which make it +inappropriate to send to a publicly archived mailing list, then please send it +to perl5-security-report@perl.org. This points to a closed subscription +unarchived mailing list, which includes all the core committers, who will be +able to help assess the impact of issues, figure out a resolution, and help +co-ordinate the release of patches to mitigate or fix the problem across all +platforms on which Perl is supported. Please only use this address for +security issues in the Perl core, not for modules independently distributed on +CPAN. + +=head1 SEE ALSO + +The F file for an explanation of how to view exhaustive details on +what changed. + +The F file for how to build Perl. + +The F file for general stuff. + +The F and F files for copyright information. + +=cut diff --git a/pod/perldata.pod b/pod/perldata.pod index 52921ca..c490b63 100644 --- a/pod/perldata.pod +++ b/pod/perldata.pod @@ -432,7 +432,10 @@ but it must be followed by C

, an optional sign, and a power of two. The format is useful for accurately presenting floating point values, avoiding conversions to or from decimal floating point, and therefore avoiding possible loss in precision. Notice that while most current -platforms use the 64-bit IEEE 754 floating point, not all do. +platforms use the 64-bit IEEE 754 floating point, not all do. Another +potential source of (low-order) differences are the floating point +rounding modes, which can differ between CPUs, operating systems, +and compilers, and which Perl doesn't control. You can also embed newlines directly in your strings, i.e., they can end on a different line than they begin. This is nice, but if you forget diff --git a/pod/perldebguts.pod b/pod/perldebguts.pod index 0554b96..54644d7 100644 --- a/pod/perldebguts.pod +++ b/pod/perldebguts.pod @@ -525,7 +525,7 @@ C<(??{ code })>. =item C If the pattern may match only at a handful of places, with C -being C, C, or C. See the table below. +being C, C, or C. See the table below. =back @@ -559,15 +559,19 @@ will be lost. END no End of program. SUCCEED no Return from a subroutine, basically. - # Anchors: + # Line Start Anchors: + SBOL no Match "" at beginning of line: /^/, /\A/ + MBOL no Same, assuming multiline: /^/m - BOL no Match "" at beginning of line. - MBOL no Same, assuming multiline. - SBOL no Same, assuming singleline. - EOS no Match "" at end of string. - EOL no Match "" at end of line. - MEOL no Same, assuming multiline. - SEOL no Same, assuming singleline. + # Line End Anchors: + SEOL no Match "" at end of line: /$/ + MEOL no Same, assuming multiline: /$/m + EOS no Match "" at end of string: /\z/ + + # Match Start Anchors: + GPOS no Matches where last m//g left off. + + # Word Boundary Opcodes: BOUND no Match "" at any word boundary using native charset rules for non-utf8 BOUNDL no Match "" at any locale word boundary @@ -582,16 +586,15 @@ will be lost. Unicode rules NBOUNDA no Match "" at any word non-boundary using ASCII rules - GPOS no Matches where last m//g left off. # [Special] alternatives: - REG_ANY no Match any one character (except newline). SANY no Match any one character. CANY no Match any one byte. ANYOF sv Match character in (or not in) this class, single char match only + # POSIX Character Classes: POSIXD none Some [[:class:]] under /d; the FLAGS field gives which one POSIXL none Some [[:class:]] under /l; the FLAGS field @@ -700,17 +703,17 @@ will be lost. unicode rules for non-utf8, no mixing ASCII, non-ASCII + # Support for long RE + LONGJMP off 1 1 Jump far away. + BRANCHJ off 1 1 BRANCH with long offset. + + # Special Case Regops IFMATCH off 1 2 Succeeds if the following matches. UNLESSM off 1 2 Fails if the following matches. SUSPEND off 1 1 "Independent" sub-RE. IFTHEN off 1 1 Switch, should be preceded by switcher. GROUPP num 1 Whether the group matched. - # Support for long RE - - LONGJMP off 1 1 Jump far away. - BRANCHJ off 1 1 BRANCH with long offset. - # The heavy worker EVAL evl 1 Execute some Perl code. diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 8ed52b7..c92f4f3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -2,192 +2,364 @@ =head1 NAME -perldelta - what is new for perl v5.21.3 +perldelta - what is new for perl v5.21.4 =head1 DESCRIPTION -This document describes differences between the 5.21.2 release and the 5.21.3 +This document describes differences between the 5.21.3 release and the 5.21.4 release. -If you are upgrading from an earlier release such as 5.21.1, first read -L, which describes differences between 5.21.1 and 5.21.2. +If you are upgrading from an earlier release such as 5.21.2, first read +L, which describes differences between 5.21.2 and 5.21.3. =head1 Core Enhancements -=head2 C is no longer fatal +=head2 Infinity and NaN (not-a-number) handling improved -In 5.21.1, C was made fatal. This has been relaxed -to not die if the argument is assigning to an array. +Floating point values are able to hold the special values infinity (also +-infinity), and NaN (not-a-number). Now we more robustly recognize and +propagate the value in computations, and on output normalize them to C and +C. -=head2 Floating point parsing has been improved +See also the L enhancements. -Parsing and printing of floating point values has been improved. +=head1 Incompatible Changes -As a completely new feature, hexadecimal floating point literals -(like 0x1.23p-4) are now supported, and they can be output with -C. +=head2 Changes to the C<*> prototype -=head1 Security +The C<*> character in a subroutine's prototype used to allow barewords to take +precedence over most, but not all subroutines. It was never consistent and +exhibited buggy behaviour. -=head2 The L module could allow outside packages to be replaced +Now it has been changed, so subroutines always take precedence over barewords, +which brings it into conformity with similarly prototyped built-in functions: -Critical bugfix: outside packages could be replaced. L has -been patched to 2.38 to address this. + sub splat($) { ... } + sub foo { ... } + splat(foo); # now always splat(foo()) + splat(bar); # still splat('bar') as before + close(foo); # close(foo()) + close(bar); # close('bar') -=head1 Incompatible Changes +=head1 Performance Enhancements + +=over 4 + +=item * -=head2 S> is now a fatal error +Subroutines with an empty prototype and bodies containing just C are now +eligible for inlining. +L<[perl #122728]|https://rt.perl.org/Ticket/Display.html?id=122728> -Importing functions from C has been deprecated since v5.12, and -is now a fatal error. S> without any arguments is still -allowed. +=item * + +Subroutines in packages no longer need to carry typeglobs around with them. +Declaring a subroutine will now put a simple sub reference in the stash if +possible, saving memory. The typeglobs still notionally exist, so accessing +them will cause the subroutine reference to be upgraded to a typeglob. This +optimization does not currently apply to XSUBs or exported subroutines, and +method calls will undo it, since they cache things in typeglobs. +L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441> + +=back =head1 Modules and Pragmata +=head2 New Modules and Pragmata + +=over 4 + +=item * + +L provides detailed information about the flags used in the +C field of perl opcodes. + +=back + =head2 Updated Modules and Pragmata =over 4 =item * -L has been upgraded from version 1.19 to 1.21. +L has been upgraded from version 2.00 to 2.02. + +Tests can now be run in parallel. + +=item * + +L has been upgraded from version 0.96 to 0.97. + +Internal changes to account for the fact that subroutines in packages no longer +need to carry typeglobs around with them (see under L). =item * -L has been upgraded from version 0.20 to 0.22. +L has been upgraded from version 0.22 to 0.23. + +The usage of C in the XS has been corrected. +L<[perl #122701]|https://rt.perl.org/Ticket/Display.html?id=122701> =item * -L has been upgraded from version 2.141520 to 2.142060. +L has been upgraded from version 1.50 to 1.51. + +It provides a new C function, based on the existing +C<< B::GV->SAFENAME >>, that converts "\cOPEN" to "^OPEN". =item * -L has been upgraded from version 2.125 to 2.126. +L has been upgraded from version 0.992 to 0.993. + +Internal changes to account for the fact that the defines and labels for the +flags in the C field of OPs are now auto-generated (see under +L). =item * -L was moved from F to F. +L has been upgraded from version 1.27 to 1.28. + +It now deparses C)> and typed lexical (C) correctly. =item * -L has been upgraded from version 0.280216 to 0.280217. +L has been upgraded from version 0.37 to 0.38. + +An C rather than an C is now used to see if we can find +Math::BigInt::Lite. =item * -L was moved from F to F. +L has been upgraded from version 1.31 to 1.32. + +It now accepts fully-qualified constant names, allowing constants to be defined +in packages other than the caller. =item * -L has been upgraded from version 1.64 to 1.65. -It was also moved from F to F. +L has been upgraded from version 2.126 to 2.128. + +Works around limitations in version::vpp detecting v-string magic and adds +support for forthcoming L bootstrap F for +Perls older than 5.10.0. =item * -L has been upgraded from version 0.043 to 0.047. +L has been upgraded from version 2.152 to 2.154. + +Fixes CVE-2014-4330 by adding a configuration variable/option to limit +recursion when dumping deep data structures. =item * -L has been upgraded from version 1.17 to 1.18. +L has been upgraded from version 0.008 to 0.010. + +Hardcodes features for Perls older than 5.15.7. =item * -L has been upgraded from version 5.021002 to 5.021003. +L has been upgraded from version 0.280217 to 0.280219. + +Fixes a regression on Android. +L<[perl #122675]|https://rt.perl.org/Ticket/Display.html?id=122675> =item * -L has been upgraded from version 1.27 to 1.28. +L has been upgraded from version 1.68 to 2.04. + +No changes to installed files other than version bumps. =item * -L has been upgraded from version 1.45 to 1.46. +L has been upgraded from version 1.65 to 1.68. + +Fixes a bug with C's handling of quoted filenames and improves +C to follow symlinks. +L<[perl #122415]|https://rt.perl.org/Ticket/Display.html?id=122415> =item * -L has been upgraded from version 5.0150044 to 5.0150045. +L has been upgraded from version 1.27 to 1.28. + +C and C will now warn if passed inappropriate or +misspelled options. =item * -L has been upgraded from version 1.41 to 1.42. +L has been upgraded from version 1.10 to 1.11. + +Corrects a typo in the documentation. =item * -L has been upgraded from version 2.37 to 2.38. +L has been upgraded from version 0.047 to 0.049. + +C is now fork-safe and thread-safe. =item * -L has been upgraded from version 2.014 to 2.015. +L has been upgraded from version 1.33 to 1.34. + +The XS implementation has been fixed for the sake of older Perls. =item * -L has been upgraded from version 1.18 to 1.19 +L has been upgraded from version 0.31 to 0.32. + +Implements Timeout for C. +L<[cpan #92075]|https://rt.cpan.org/Ticket/Display.html?id=92075> =item * -L has been upgraded from version 1.11 to 1.12. +L has been upgraded from version 3.31 to 3.32. -=back +New codes have been added. -=head1 Documentation +=item * -=head2 Changes to Existing Documentation +L has been upgraded from version 1.9996 to 1.9997. -=head3 L +The documentation now gives test examples using L rather than +L. -=over 4 +=item * + +L has been upgraded from version 5.021003 to 5.20140920. + +Updated to cover the latest releases of Perl. =item * -Added reference to L. +L has been upgraded from version 1.22 to 1.23. + +A redundant C check has been removed. + +=item * + +PathTools has been upgraded from version 3.49 to 3.50. + +A warning from the B compiler is now avoided when building the XS. + +=item * + +L has been upgraded from version 3.23 to 3.24. + +Filehandles opened for reading or writing now have C<:encoding(UTF-8)> set. +L<[cpan #98019]|https://rt.cpan.org/Ticket/Display.html?id=98019> + +=item * + +L has been upgraded from version 1.42 to 1.43. + +The C99 math functions and constants (for example acosh, isinf, isnan, round, +trunc; M_E, M_SQRT2, M_PI) have been added. + +=item * + +Scalar-List-Utils has been upgraded from version 1.39 to 1.41. + +A new module, L, has been added, containing functions related to +CODE refs, including C (inspired by Sub::Identity) and C +(copied and renamed from Sub::Name). + +The use of C in C has also been fixed. +L<[cpan #63211]|https://rt.cpan.org/Ticket/Display.html?id=63211> + +=item * + +L has been upgraded from version 1.14 to 1.15. + +Faster checks are now made first in some if-statements. + +=item * + +L has been upgraded from version 3.32 to 3.33. + +Various documentation fixes. + +=item * + +L has been upgraded from version 1.001003 to 1.001006. + +Various documentation fixes. + +=item * + +L has been upgraded from version 1.95 to 1.96. + +No changes to installed files other than version bumps. + +=item * + +L has been upgraded from version 1.27 to 1.29. + +When pretty printing negative Time::Seconds, the "minus" is no longer lost. + +=item * + +L has been upgraded from version 0.9908 to 0.9909. + +Numerous changes. See the F file in the CPAN distribution for +details. =back -=head3 L +=head1 Documentation + +=head2 Changes to Existing Documentation + +=head3 L =over 4 =item * -Details on C level symbols and libperl.t added. +Calling C or C on array values is now described as "strongly +discouraged" rather than "deprecated". =back -=head3 L +=head3 L =over 4 =item * -Recommended replacements for tmpfile, atoi, strtol, and strtoul added. +The conditions for marking an experimental feature as non-experimental are now +set out. =back -=head3 L +=head3 L =over 4 =item * -ASCII v. EBCDIC clarifications added. +The documentation of Bracketed Character Classes has been expanded to cover the +improvements in C (see under L). =back -=head3 L +=head3 L =over 4 =item * -Comments added on algorithmic complexity and tied hashes. +An ambiguity in the documentation of the Ellipsis statement has been corrected. +L<[perl #122661]|https://rt.perl.org/Ticket/Display.html?id=122661> =back -=head3 L +=head3 L =over 4 =item * -Updated documentation on environment and shell interaction in VMS. +Added a discussion of locale issues in XS code. =back @@ -199,188 +371,367 @@ diagnostic messages, see L. =head2 New Diagnostics -=head3 New Errors +=head3 New Warnings =over 4 =item * -L +L -(F) Something went horribly bad in hexadecimal float handling. +(W pack) You tried converting an infinity or not-a-number to an unsigned +character, which makes no sense. Perl behaved as if you tried to pack 0xFF. =item * -L +L -(F) You have configured Perl to use long doubles but -the internals of the long double format are unknown, -therefore the hexadecimal float output is impossible. +(W pack) You tried converting an infinity or not-a-number to a signed +character, which makes no sense. Perl behaved as if you tried to pack 0xFF. + +=item * + +L + +(W utf8) You passed an invalid number (like an infinity or not-a-number) to +C. Those are not valid character numbers, so it returned the Unicode +replacement character (U+FFFD). =back -=head3 New Warnings +=head2 Changes to Existing Diagnostics =over 4 =item * -L +L -(W overflow) The hexadecimal floating point has larger exponent -than the floating point supports. +This message has had '(did you forget to declare "my %s"?)' appended to it, to +make it more helpful to new Perl programmers. +L<[perl #121638]|https://rt.perl.org/Ticket/Display.html?id=121638> =item * -L +L<\N{} in character class restricted to one character in regex; marked by S<<-- HERE> in mE%sE|perldiag/"\N{} in inverted character class or as a range end-point is restricted to one character in regex; marked by S<<-- HERE> in m/%s/"> + +This message has had 'character class' changed to 'inverted character class or +as a range end-point is' to reflect improvements in C +(see under L). + +=item * + +L + +This message has had ': %f' appended to it, to show what the offending floating +point number is. + +=back + +=head2 Diagnostic Removals -(W overflow) The hexadecimal floating point has smaller exponent -than the floating point supports. +=over 4 =item * -L +"Constant is not a FOO reference" -(W overflow) The hexadecimal floating point literal had more bits in -the mantissa (the part between the 0x and the exponent, also known as -the fraction or the significand) than the floating point supports. +Compile-time checking of constant dereferencing (e.g., C<< my_constant->() >>) +has been removed, since it was not taking overloading into account. +L<[perl #69456]|https://rt.perl.org/Ticket/Display.html?id=69456> +L<[perl #122607]|https://rt.perl.org/Ticket/Display.html?id=122607> =item * -L +"Ambiguous use of -foo resolved as -&foo()" -(W overflow) The hexadecimal floating point had internally more -digits than could be output. This can be caused by unsupported -long double formats, or by 64-bit integers not being available -(needed to retrieve the digits under some configurations). +There is actually no ambiguity here, and this impedes the use of negated +constants; e.g., C<-Inf>. =back -=head2 Changes to Existing Diagnostics +=head1 Configuration and Compilation =over 4 =item * -C with no argument or undef used to warn about a Null filename; now -it dies with C. +For long doubles (to get more precision and range for floating point numbers) +one can now use the GCC quadmath library which implements the quadruple +precision floating point numbers in x86 and ia64 platforms. See F for +details. =back -=head1 Configuration and Compilation +=head1 Testing =over 4 =item * -MurmurHash64A and MurmurHash64B can now be configured as the internal hash -function. +A new test script, F, has been added to test if Inf and NaN are +working correctly. See L. -=back +=item * + +A new test script, F, has been added to test that the fix for +L is working. -=head1 Platform Support +=back -=head2 Platform-Specific Notes +=head1 Internal Changes =over 4 -=item Android +=item * + +C no longer does anything and has been moved to F. + +=item * + +C is a new API function that can be passed a CV or GV. It returns an +SV containing the name of the subroutine for use in diagnostics. +L<[perl #116735]|https://rt.perl.org/Ticket/Display.html?id=116735> +L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441> + +=item * -Build support has been improved for cross-compiling in general and for -Android in particular. +C is a new API function that works like +C, except that it allows the caller to specify whether the +call checker requires a full GV for reporting the subroutine's name, or whether +it could be passed a CV instead. Whatever value is passed will be acceptable +to C. C guarantees there will be a GV, but it +may have to create one on the fly, which is inefficient. +L<[perl #116735]|https://rt.perl.org/Ticket/Display.html?id=116735> -=item Solaris +=item * -C options have been cleaned up, hints look for C -as well as C, and support for native C has been added. +C (which is not part of the API) is now a more complex macro, which may +call a function and reify a GV. For those cases where is has been used as a +boolean, C has been added, which will return true for CVs that +notionally have GVs, but without reifying the GV. C also returns a GV +now for lexical subs. +L<[perl #120441]|https://rt.perl.org/Ticket/Display.html?id=120441> -=item VMS +=item * -C, C, and C detection has been added to -C, environment handling has had some minor changes, and -a fix for legacy feature checking status. +Added L. Changing the program's locale should be avoided +by XS code. Nevertheless, certain non-Perl libraries called from XS, such as +C do so. When this happens, Perl needs to be told that the locale has +changed. Use this function to do so, before returning to Perl. -=item Windows +=item * -C<%I64d> is now being used instead of C<%lld> for MinGW. +The defines and labels for the flags in the C field of OPs are now +auto-generated from data in F. The noticeable effect of this +is that some of the flag output of C might differ slightly, and the +flag output of C may differ considerably (they both use the same set +of labels now). Also in debugging builds, there is a new assert in +C that checks that the op doesn't have any unrecognized flags set in +C. =back -=head1 Internal Changes +=head1 Selected Bug Fixes =over 4 =item * -Added L. -Changing the program's locale should be avoided by XS code. Nevertheless, -certain non-Perl libraries called from XS, such as C do so. When this -happens, Perl needs to be told that the locale has changed. Use this function -to do so, before returning to Perl. +Constant dereferencing now works correctly for typeglob constants. Previously +the glob was stringified and its name looked up. Now the glob itself is used. +L<[perl #69456]|https://rt.perl.org/Ticket/Display.html?id=69456> =item * -Added L as a safer replacement for atoi and strtol. +When parsing a funny character ($ @ % &) followed by braces, the parser no +longer tries to guess whether it is a block or a hash constructor (causing a +syntax error when it guesses the latter), since it can only be a block. -=back +=item * -=head1 Selected Bug Fixes +C now frees the referent immediately, instead of hanging on +to it until the next statement. +L<[perl #122556]|https://rt.perl.org/Ticket/Display.html?id=122556> -=over 4 +=item * + +Various cases where the name of a sub is used (autoload, overloading, error +messages) used to crash for lexical subs, but have been fixed. + +=item * + +Bareword lookup now tries to avoid vivifying packages if it turns out the +bareword is not going to be a subroutine name. + +=item * + +Compilation of anonymous constants (e.g., C) no longer deletes +any subroutine named C<__ANON__> in the current package. Not only was +C<*__ANON__{CODE}> cleared, but there was a memory leak, too. This bug goes +back to Perl 5.8.0. + +=item * + +Stub declarations like C and C no longer wipe out constants +of the same name declared by C. This bug was introduced in Perl +5.10.0. + +=item * + +Under some conditions a warning raised in compilation of regular expression +patterns could be displayed multiple times. This is now fixed. + +=item * + +C now works properly in many instances. Some names +known to C<\N{...}> refer to a sequence of multiple characters, instead of the +usual single character. Bracketed character classes generally only match +single characters, but now special handling has been added so that they can +match named sequences, but not if the class is inverted or the sequence is +specified as the beginning or end of a range. In these cases, the only +behavior change from before is a slight rewording of the fatal error message +given when this class is part of a C construct. When the C<[...]> +stands alone, the same non-fatal warning as before is raised, and only the +first character in the sequence is used, again just as before. + +=item * + +Tainted constants evaluated at compile time no longer cause unrelated +statements to become tainted. +L<[perl #122669]|https://rt.perl.org/Ticket/Display.html?id=122669> + +=item * + +C, which vivifies a handle with a name like "main::_GEN_0", was +not giving the handle the right reference count, so a double free could happen. + +=item * + +When deciding that a bareword was a method name, the parser would get confused +if an "our" sub with the same name existed, and look up the method in the +package of the "our" sub, instead of the package of the invocant. + +=item * + +The parser no longer gets confused by C<\U=> within a double-quoted string. It +used to produce a syntax error, but now compiles it correctly. +L<[perl #80368]|https://rt.perl.org/Ticket/Display.html?id=80368> + +=item * + +It has always been the intention for the C<-B> and C<-T> file test operators to +treat UTF-8 encoded files as text. (L has +been updated to say this.) Previously, it was possible for some files to be +considered UTF-8 that actually weren't valid UTF-8. This is now fixed. The +operators now work on EBCDIC platforms as well. + +=item * + +Under some conditions warning messages raised during regular expression pattern +compilation were being output more than once. This has now been fixed. + +=item * + +A regression has been fixed that was introduced in Perl 5.20.0 (fixed in Perl +5.20.1 as well as here) in which a UTF-8 encoded regular expression pattern +that contains a single ASCII lowercase letter does not match its uppercase +counterpart. +L<[perl #122655]|https://rt.perl.org/Ticket/Display.html?id=122655> + +=item * + +Constant folding could incorrectly suppress warnings if lexical warnings (C or C) were not in effect and C<$^W> were false at +compile time and true at run time. + +=item * + +Loading UTF8 tables during a regular expression match could cause assertion +failures under debugging builds if the previous match used the very same +regular expression. +L<[perl #122747]|https://rt.perl.org/Ticket/Display.html?id=122747> + +=item * + +Thread cloning used to work incorrectly for lexical subs, possibly causing +crashes or double frees on exit. + +=item * + +Since Perl 5.14.0, deleting C<$SomePackage::{__ANON__}> and then undefining an +anonymous subroutine could corrupt things internally, resulting in +L crashing or L giving nonsensical data. This has been +fixed. + +=item * + +C<(caller $n)[3]> now reports names of lexical subs, instead of treating them +as "(unknown)". + +=item * + +C now supports lexical subs for the comparison routine. =item * -Failing to compile C in an eval could leave a spurious -C subroutine definition, which would produce a "Subroutine -BEGIN redefined" warning on the next use of C, or other C -block. [perl #122107] +Aliasing (e.g., via C<*x = *y>) could confuse list assignments that mention the +two names for the same variable on either side, causing wrong values to be +assigned. +L<[perl #15667]|https://rt.perl.org/Ticket/Display.html?id=15667> =item * -C syntax now correctly parses the arguments if they -begin with an opening brace. [perl #46947] +Long here-doc terminators could cause a bad read on short lines of input. This +has been fixed. It is doubtful that any crash could have occurred. This bug +goes back to when here-docs were introduced in Perl 3.000 twenty-five years +ago. =item * -External libraries and Perl may have different ideas of what the locale is. -This is problematic when parsing version strings if the locale's numeric -separator has been changed. Version parsing has been patched to ensure -it handles the locales correctly. [perl #121930] +An optimization in C to treat C like C had the +unfortunate side-effect of also treating C like C, which +it should not. This has been fixed. (Note, however, that C does +not behave like C, which is also considered to be a bug and will be +fixed in a future version.) +L<[perl #122761]|https://rt.perl.org/Ticket/Display.html?id=122761> =item * -A bug has been fixed where zero-length assertions and code blocks inside of a -regex could cause C to see an incorrect value. [perl #122460] +The little-known C syntax (see L and L) +could get confused in the scope of C if C were a constant +whose value contained Latin-1 characters. =back =head1 Acknowledgements -Perl 5.21.3 represents approximately 4 weeks of development since Perl 5.21.2 -and contains approximately 21,000 lines of changes across 250 files from 25 +Perl 5.21.4 represents approximately 4 weeks of development since Perl 5.21.3 +and contains approximately 29,000 lines of changes across 520 files from 30 authors. Excluding auto-generated files, documentation and release tools, there were -approximately 18,000 lines of changes to 160 .pm, .t, .c and .h files. +approximately 15,000 lines of changes to 390 .pm, .t, .c and .h files. Perl continues to flourish into its third decade thanks to a vibrant community -of users and developers. The following people are known to have contributed the -improvements that became Perl 5.21.3: +of users and developers. The following people are known to have contributed +the improvements that became Perl 5.21.4: -Aaron Crane, Abigail, Alberto Simões, Andy Dougherty, Brian Fraser, Chad -Granum, Chris 'BinGOs' Williams, Craig A. Berry, Dagfinn Ilmari MannsÃ¥ker, -Daniel Dragan, David Mitchell, Father Chrysostomos, H.Merijn Brand, James E -Keenan, Jan Dubois, Jarkko Hietaniemi, Karen Etheridge, Karl Williamson, Lukas -Mai, Peter Martini, Rafael Garcia-Suarez, syber, Tony Cook, Vladimir Marek, -Yves Orton. +Alberto Simões, Alexandre (Midnite) Jousset, Andy Dougherty, Anthony Heading, +Brian Fraser, Chris 'BinGOs' Williams, Craig A. Berry, Daniel Dragan, David +Mitchell, Doug Bell, Father Chrysostomos, George Greer, H.Merijn Brand, James E +Keenan, Jarkko Hietaniemi, Jerry D. Hedden, Karen Etheridge, Karl Williamson, +Olivier Mengué, Peter Martini, Reini Urban, Ricardo Signes, Steffen Müller, +Steve Hay, Sullivan Beck, syber, Tadeusz Sośnierz, Tony Cook, Yves Orton, +Ævar Arnfjörð Bjarmason. The list above is almost certainly incomplete as it is automatically generated -from version control history. In particular, it does not include the names of +from version control history. In particular, it does not include the names of the (very much appreciated) contributors who reported issues to the Perl bug tracker. Many of the changes included in this version originated in the CPAN modules -included in Perl's core. We're grateful to the entire CPAN community for +included in Perl's core. We're grateful to the entire CPAN community for helping Perl to flourish. For a more complete list of all of Perl's historical contributors, please see diff --git a/pod/perldiag.pod b/pod/perldiag.pod index ddcc0b9..80a197c 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -957,6 +957,13 @@ unable to locate this library. See L. functioning as a class, but that package doesn't define that particular method, nor does any of its base classes. See L. +=item Can't locate object method "%s" via package "%s" (perhaps you forgot +to load "%s"?) + +(F) You called a method on a class that did not exist, and the method +could not be found in UNIVERSAL. This often means that a method +requires a package that has not been loaded. + =item Can't locate package %s for @%s::ISA (W syntax) The @ISA array contained the name of another package that @@ -1328,6 +1335,18 @@ Note that ASCII characters that don't map to control characters are discouraged, and will generate the warning (when enabled) L. +=item Character in 'C' format overflow in pack + +(W pack) You tried converting an infinity or not-a-number to an +unsigned character, which makes no sense. Perl behaved as if you +tried to pack 0xFF. + +=item Character in 'c' format overflow in pack + +(W pack) You tried converting an infinity or not-a-number to a +signed character, which makes no sense. Perl behaved as if you +tried to pack 0xFF. + =item Character in 'C' format wrapped in pack (W pack) You said @@ -1435,9 +1454,10 @@ underlying byte is stored as a character, with utf8::encode(). =item "\c%c" is more clearly written simply as "%s" (W syntax) The C<\cI> construct is intended to be a way to specify -non-printable characters. You used it for a printable one, which is better -written as simply itself, perhaps preceded by a backslash for non-word -characters. +non-printable characters. You used it for a printable one, which +is better written as simply itself, perhaps preceded by a backslash +for non-word characters. Doing it the way you did is not portable +between ASCII and EBCDIC platforms. =item Cloning substitution context is unimplemented @@ -2091,7 +2111,8 @@ is experimental, so its behavior may change or even be removed in any future release of perl. See the explanation under L. -=item Global symbol "%s" requires explicit package name +=item Global symbol "%s" requires explicit package name (did you forget to +declare "my %s"?) (F) You've said "use strict" or "use strict vars", which indicates that all variables must either be lexically scoped (using "my" or "state"), @@ -2181,12 +2202,12 @@ Further error messages would likely be uninformative. =item Hexadecimal float: exponent overflow -(W overflow) The hexadecimal floating point has larger exponent +(W overflow) The hexadecimal floating point has a larger exponent than the floating point supports. =item Hexadecimal float: exponent underflow -(W overflow) The hexadecimal floating point has smaller exponent +(W overflow) The hexadecimal floating point has a smaller exponent than the floating point supports. =item Hexadecimal float: internal error @@ -2209,7 +2230,7 @@ long double formats, or by 64-bit integers not being available =item Hexadecimal float: unsupported long double format (F) You have configured Perl to use long doubles but -the internals of the long double format are unknown, +the internals of the long double format are unknown; therefore the hexadecimal float output is impossible. =item Hexadecimal number > 0xffffffff non-portable @@ -2228,7 +2249,7 @@ of Perl are likely to eliminate these arbitrary limitations. =item Ignoring zero length \N{} in character class in regex; marked by S<<-- HERE> in m/%s/ -(W regexp) Named Unicode character escapes C<(\N{...})> may return a +(W regexp) Named Unicode character escapes (C<\N{...}>) may return a zero-length sequence. When such an escape is used in a character class its behaviour is not well defined. Check that the correct escape has been used, and the correct charname handler is in scope. @@ -2590,9 +2611,15 @@ a module that is a MRO plugin. See L and L. =item Invalid negative number (%s) in chr (W utf8) You passed a negative number to C. Negative numbers are -not valid characters numbers, so it return the Unicode replacement +not valid character numbers, so it returns the Unicode replacement character (U+FFFD). +=item Invalid number (%f) in chr + +(W utf8) You passed an invalid number (like an infinity or +not-a-number) to C. Those are not valid character numbers, +so it return the Unicode replacement character (U+FFFD). + =item invalid option -D%c, use -D'' to see choices (S debugging) Perl was called with invalid debugger flags. Call perl @@ -3343,15 +3370,23 @@ bracketed character class, for the same reason that C<.> in a character class loses its specialness: it matches almost everything, which is probably not what you want. -=item \N{} in character class restricted to one character in regex; marked +=item \N{} in inverted character class or as a range end-point is restricted to one character in regex; marked by S<<-- HERE> in m/%s/ -(F) Named Unicode character escapes C<(\N{...})> may return a -multi-character sequence. Such an escape may not be used in -a character class, because character classes always match one -character of input. Check that the correct escape has been used, -and the correct charname handler is in scope. The S<<-- HERE> shows -whereabouts in the regular expression the problem was discovered. +(F) Named Unicode character escapes (C<\N{...}>) may return a +multi-character sequence. Even though a character class is +supposed to match just one character of input, perl will match the +whole thing correctly, except when the class is inverted (C<[^...]>), +or the escape is the beginning or final end point of a range. The +mathematically logical behavior for what matches when inverting +is very different from what people expect, so we have decided to +forbid it. Similarly unclear is what should be generated when the +C<\N{...}> is used as one of the end points of the range, such as in + + [\x{41}-\N{ARABIC SEQUENCE YEH WITH HAMZA ABOVE WITH AE}] + +What is meant here is unclear, as the C<\N{...}> escape is a sequence +of code points, so this is made an error. =item \N{NAME} must be resolved by the lexer in regex; marked by S<<-- HERE> in m/%s/ @@ -3983,7 +4018,7 @@ data. (P) While attempting folding constants an exception other than an C failure was caught. -=item panic: frexp +=item panic: frexp: %f (P) The library function frexp() failed, making printf("%f") impossible. @@ -4193,12 +4228,6 @@ the nesting limit is exceeded. command-line switch. (This output goes to STDOUT unless you've redirected it with select().) -=item (perhaps you forgot to load "%s"?) - -(F) This is an educated guess made in conjunction with the message -"Can't locate object method \"%s\" via package \"%s\"". It often means -that a method requires a package that has not been loaded. - =item Perl folding rules are not up-to-date for 0x%X; please use the perlbug utility to report; in regex; marked by S<<-- HERE> in m/%s/ @@ -6488,9 +6517,14 @@ You need to add either braces or blanks to disambiguate. =item Using just the first character returned by \N{} in character class in regex; marked by S<<-- HERE> in m/%s/ -(W regexp) A charnames handler may return a sequence of more than one -character. Currently all but the first one are discarded when used in -a regular expression pattern bracketed character class. +(W regexp) Named Unicode character escapes C<(\N{...})> may return +a multi-character sequence. Even though a character class is +supposed to match just one character of input, perl will match +the whole thing correctly, except when the class is inverted +(C<[^...]>), or the escape is the beginning or final end point of +a range. For these, what should happen isn't clear at all. In +these circumstances, Perl discards all but the first character +of the returned sequence, which is not likely what you want. =item Using !~ with %s doesn't make sense @@ -6754,7 +6788,7 @@ Something Very Wrong. =item Zero length \N{} in regex; marked by S<<-- HERE> in m/%s/ -(F) Named Unicode character escapes C<(\N{...})> may return a zero-length +(F) Named Unicode character escapes (C<\N{...}>) may return a zero-length sequence. Such an escape was used in an extended character class, i.e. C<(?[...])>, which is not permitted. Check that the correct escape has been used, and the correct charnames handler is in scope. The S<<-- HERE> diff --git a/pod/perlfork.pod b/pod/perlfork.pod index 7729444..fed58f3 100644 --- a/pod/perlfork.pod +++ b/pod/perlfork.pod @@ -152,7 +152,7 @@ pseudo-child created by it that is also a pseudo-parent will only exit after their pseudo-children have exited. Starting with Perl 5.14 a parent will not wait() automatically -for any child that has been signalled with C +for any child that has been signalled with C to avoid a deadlock in case the child is blocking on I/O and never receives the signal. diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 40e4965..58f39bc 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -390,7 +390,7 @@ other named unary operator. The operator may be any of: -g File has setgid bit set. -k File has sticky bit set. - -T File is an ASCII text file (heuristic guess). + -T File is an ASCII or UTF-8 text file (heuristic guess). -B File is a "binary" file (opposite of -T). -M Script start time minus file modification time, in days. @@ -449,12 +449,18 @@ filehandle won't cache the results of the file tests when this pragma is in effect. Read the documentation for the C pragma for more information. -The C<-T> and C<-B> switches work as follows. The first block or so of the -file is examined for odd characters such as strange control codes or -characters with the high bit set. If too many strange characters (>30%) -are found, it's a C<-B> file; otherwise it's a C<-T> file. Also, any file -containing a zero byte in the first block is considered a binary file. If C<-T> -or C<-B> is used on a filehandle, the current IO buffer is examined +The C<-T> and C<-B> switches work as follows. The first block or so of +the file is examined to see if it is valid UTF-8 that includes non-ASCII +characters. If, so it's a C<-T> file. Otherwise, that same portion of +the file is examined for odd characters such as strange control codes or +characters with the high bit set. If more than a third of the +characters are strange, it's a C<-B> file; otherwise it's a C<-T> file. +Also, any file containing a zero byte in the examined portion is +considered a binary file. (If executed within the scope of a L|perllocale> which includes C, odd characters are +anything that isn't a printable nor space in the current locale.) If +C<-T> or C<-B> is used on a filehandle, the current IO buffer is +examined rather than the first block. Both C<-T> and C<-B> return true on an empty file, or a file at EOF when testing a filehandle. Because you have to read a file to do the C<-T> test, on most occasions you want to use a C<-f> @@ -738,7 +744,8 @@ Returns the context of the current pure perl subroutine call. In scalar context, returns the caller's package name if there I a caller (that is, if we're in a subroutine or C or C) and the undefined value otherwise. caller never returns XS subs and they are skipped. The next pure -perl sub will appear instead of the XS sub in caller's return values. In list +perl sub will appear instead of the XS +sub in caller's return values. In list context, caller returns # 0 1 2 @@ -756,7 +763,7 @@ to go back before the current one. = caller($i); Here, $subroutine is the function that the caller called (rather than the -function containing the caller). Note that $subroutine may be C<(eval)> if +function containing the caller). Note that $subroutine may be C<(eval)> if the frame is not a subroutine call, but an C. In such a case additional elements $evaltext and C<$is_require> are set: C<$is_require> is true if the frame is created by a @@ -1374,11 +1381,12 @@ straightforward. Although exists() will return false for deleted entries, deleting array elements never changes indices of existing values; use shift() or splice() for that. However, if any deleted elements fall at the end of an array, the array's size shrinks to the position of the highest element that -still tests true for exists(), or to 0 if none do. In other words, an +still tests true for exists(), or to 0 if none do. In other words, an array won't have trailing nonexistent elements after a delete. -B Calling delete on array values is deprecated and likely to -be removed in a future version of Perl. +B Calling C on array values is strongly discouraged. The +notion of deleting or checking the existence of Perl array elements is not +conceptually coherent, and can lead to surprising behavior. Deleting from C<%ENV> modifies the environment. Deleting from a hash tied to a DBM file deletes the entry from the DBM file. Deleting from a C hash @@ -2055,9 +2063,11 @@ corresponding value is undefined. print "True\n" if $hash{$key}; exists may also be called on array elements, but its behavior is much less -obvious and is strongly tied to the use of L on arrays. B -that calling exists on array values is deprecated and likely to be removed in -a future version of Perl. +obvious and is strongly tied to the use of L on arrays. + +B Calling C on array values is strongly discouraged. The +notion of deleting or checking the existence of Perl array elements is not +conceptually coherent, and can lead to surprising behavior. print "Exists\n" if exists $array[$index]; print "Defined\n" if defined $array[$index]; @@ -4501,7 +4511,8 @@ of values, as follows: D A float of long-double precision in native format. (Long doubles are available only if your system supports long double values _and_ if Perl has been compiled to - support those. Raises an exception otherwise.) + support those. Raises an exception otherwise. + Note that there are different long double formats.) p A pointer to a null-terminated string. P A pointer to a structure (fixed-length string). @@ -9279,8 +9290,6 @@ This keyword is documented in L. =item else -=item elseif - =item elsif =item for @@ -9297,6 +9306,15 @@ This keyword is documented in L. These flow-control keywords are documented in L. +=item elseif + +The "else if" keyword is spelled C in Perl. There's no C +or C either. It does parse C, but only to warn you +about not using it. + +See the documentation for flow-control keywords in L. + =back =over diff --git a/pod/perlgit.pod b/pod/perlgit.pod index 2b00774..b851124 100644 --- a/pod/perlgit.pod +++ b/pod/perlgit.pod @@ -326,7 +326,7 @@ output. After you've generated your patch you should sent it to perlbug@perl.org (as discussed L with a normal mail client as an +section|/"Patch workflow">) with a normal mail client as an attachment, along with a description of the patch. You B use git-send-email(1) to send patches generated with diff --git a/pod/perlguts.pod b/pod/perlguts.pod index bcd2672..466f966 100644 --- a/pod/perlguts.pod +++ b/pod/perlguts.pod @@ -2641,6 +2641,9 @@ For example: The IVdf will expand to whatever is the correct format for the IVs. +Note that there are different "long doubles": Perl will use +whatever the compiler has. + If you are printing addresses of pointers, use UVxf combined with PTR2UV(), do not use %lx or %p. diff --git a/pod/perlhist.pod b/pod/perlhist.pod index 230db66..a4a04a1 100644 --- a/pod/perlhist.pod +++ b/pod/perlhist.pod @@ -32,7 +32,8 @@ Leon Brocard, Dave Mitchell, Jesse Vincent, Ricardo Signes, Steve Hay, Matt S Trout, David Golden, Florian Ragwitz, Tatsuhiko Miyagawa, Chris C Williams, Zefram, Ævar Arnfjörð Bjarmason, Stevan Little, Dave Rolsky, Max Maischein, Abigail, Jesse Luehrs, Tony Cook, -Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis and Matthew Horsfall. +Dominic Hargreaves, Aaron Crane, Aristotle Pagaltzis, Matthew Horsfall +and Peter Martini. =head2 PUMPKIN? @@ -530,11 +531,15 @@ the strings?). Ricardo 5.20.0-RC1 2014-May-16 The 5.20 maintenance track Ricardo 5.20.0 2014-May-27 + Steve 5.20.1-RC1 2014-Aug-25 + Steve 5.20.1-RC2 2014-Sep-07 + Steve 5.20.1 2014-Sep-14 Ricardo 5.21.0 2014-May-27 The 5.21 development track Matthew H 5.21.1 2014-Jun-20 Abigail 5.21.2 2014-Jul-20 Peter 5.21.3 2014-Aug-20 + Steve 5.21.4 2014-Sep-20 =head2 SELECTED RELEASE SIZES diff --git a/pod/perllocale.pod b/pod/perllocale.pod index a5d776a..c43ba5e 100644 --- a/pod/perllocale.pod +++ b/pod/perllocale.pod @@ -211,17 +211,7 @@ locale isn't exposed to Perl space. XS modules for all categories but C get the underlying locale, and hence any C library functions they call will use that -underlying locale. - -Perl tries to keep C set to C<"C"> -because too many modules are unable to cope with the decimal point in a -floating point number not being a dot (it's a comma in many locales). -Macros are provided for XS code to temporarily change to use the -underlying locale when necessary; however buggy code that fails to -restore when done can break other XS code (but not Perl code) in this -regard. The API for these macros has not yet been nailed down, but will be -during the course of v5.21. Send email to -L for guidance. +underlying locale. For more discussion, see L. =back @@ -318,7 +308,7 @@ C<$EXTENDED_OS_ERROR>) when used as strings use C. The default behavior is restored with the S> pragma, or upon reaching the end of the block enclosing C. -Note that C and C may be +Note that C calls may be nested, and that what is in effect within an inner scope will revert to the outer scope's rules at the end of the inner scope. diff --git a/pod/perlop.pod b/pod/perlop.pod index f00c134..c36d8ce 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -322,7 +322,8 @@ operand is not enclosed in parentheses, it returns a string consisting of the left operand repeated the number of times specified by the right operand. In list context, if the left operand is enclosed in parentheses or is a list formed by C, it repeats the list. -If the right operand is zero or negative, it returns an empty string +If the right operand is zero or negative (raising a warning on +negative), it returns an empty string or an empty list, depending on the context. X @@ -2587,7 +2588,7 @@ corresponding closing punctuation (that is C<)>, C<]>, C<}>, or C<< > >>). If the starting delimiter is an unpaired character like C or a closing punctuation, the ending delimiter is same as the starting delimiter. Therefore a C terminates a C construct, while a C<]> terminates -C and C constructs. +both C and C constructs. When searching for single-character delimiters, escaped delimiters and C<\\> are skipped. For example, while searching for terminating C, @@ -2603,13 +2604,14 @@ safe location). For constructs with three-part delimiters (C, C, and C), the search is repeated once more. -If the first delimiter is not an opening punctuation, three delimiters must -be same such as C and C, in which case the second delimiter +If the first delimiter is not an opening punctuation, the three delimiters must +be the same, such as C and C, +in which case the second delimiter terminates the left part and starts the right part at once. If the left part is delimited by bracketing punctuation (that is C<()>, C<[]>, C<{}>, or C<< <> >>), the right part needs another pair of delimiters such as C and C. In these cases, whitespace -and comments are allowed between both parts, though the comment must follow +and comments are allowed between the two parts, though the comment must follow at least one whitespace character; otherwise a character expected as the start of the comment may be regarded as the starting delimiter of the right part. diff --git a/pod/perlpacktut.pod b/pod/perlpacktut.pod index 608a592..a710f20 100644 --- a/pod/perlpacktut.pod +++ b/pod/perlpacktut.pod @@ -496,14 +496,19 @@ For packing floating point numbers you have the choice between the pack codes C, C, C and C. C and C pack into (or unpack from) single-precision or double-precision representation as it is provided by your system. If your systems supports it, C can be used to pack and -unpack extended-precision floating point values (C), which -can offer even more resolution than C or C. C packs an C, -which is the floating point type used by Perl internally. (There -is no such thing as a network representation for reals, so if you want -to send your real numbers across computer boundaries, you'd better stick -to ASCII representation, unless you're absolutely sure what's on the other -end of the line. For the even more adventuresome, you can use the byte-order -modifiers from the previous section also on floating point codes.) +unpack (C) values, which can offer even more resolution +than C or C. B + +C packs an C, which is the floating point type used by Perl +internally. + +There is no such thing as a network representation for reals, so if +you want to send your real numbers across computer boundaries, you'd +better stick to text representation, possibly using the hexadecimal +float format (avoiding the decimal conversion loss), unless you're +absolutely sure what's on the other end of the line. For the even more +adventuresome, you can use the byte-order modifiers from the previous +section also on floating point codes. diff --git a/pod/perlpolicy.pod b/pod/perlpolicy.pod index 7f7befa..4dbf5ad 100644 --- a/pod/perlpolicy.pod +++ b/pod/perlpolicy.pod @@ -204,6 +204,14 @@ do our best to smooth the transition path for users of experimental features, you should contact the perl5-porters mailinglist if you find an experimental feature useful and want to help shape its future. +Experimental features must be experimental in two stable releases before being +marked non-experimental. Experimental features will only have their +experimental status revoked when they no longer have any design-changing bugs +open against them and when they have remained unchanged in behavior for the +entire length of a development cycle. In other words, a feature present in +v5.20.0 may be marked no longer experimental in v5.22.0 if and only if its +behavior is unchanged throughout all of v5.21. + =item deprecated If something in the Perl core is marked as B, we may remove it diff --git a/pod/perlrecharclass.pod b/pod/perlrecharclass.pod index ba49ba0..5cd0ae7 100644 --- a/pod/perlrecharclass.pod +++ b/pod/perlrecharclass.pod @@ -457,30 +457,59 @@ Examples: ------- -* There is an exception to a bracketed character class matching a -single character only. When the class is to match caselessly under C -matching rules, and a character that is explicitly mentioned inside the -class matches a +* There are two exceptions to a bracketed character class matching a +single character only. Each requires special handling by Perl to make +things work: + +=over + +=item * + +When the class is to match caselessly under C matching rules, and a +character that is explicitly mentioned inside the class matches a multiple-character sequence caselessly under Unicode rules, the class -(when not L) will also match that sequence. For -example, Unicode says that the letter C -should match the sequence C under C rules. Thus, +will also match that sequence. For example, Unicode says that the +letter C should match the sequence C +under C rules. Thus, 'ss' =~ /\A\N{LATIN SMALL LETTER SHARP S}\z/i # Matches 'ss' =~ /\A[aeioust\N{LATIN SMALL LETTER SHARP S}]\z/i # Matches -For this to happen, the character must be explicitly specified, and not -be part of a multi-character range (not even as one of its endpoints). -(L will be explained shortly.) Therefore, +For this to happen, the class must not be inverted (see L) +and the character must be explicitly specified, and not be part of a +multi-character range (not even as one of its endpoints). (L will be explained shortly.) Therefore, 'ss' =~ /\A[\0-\x{ff}]\z/i # Doesn't match 'ss' =~ /\A[\0-\N{LATIN SMALL LETTER SHARP S}]\z/i # No match - 'ss' =~ /\A[\xDF-\xDF]\z/i # Matches on ASCII platforms, since \XDF - # is LATIN SMALL LETTER SHARP S, and the - # range is just a single element + 'ss' =~ /\A[\xDF-\xDF]\z/i # Matches on ASCII platforms, since + # \XDF is LATIN SMALL LETTER SHARP S, + # and the range is just a single + # element Note that it isn't a good idea to specify these types of ranges anyway. +=item * + +Some names known to C<\N{...}> refer to a sequence of multiple characters, +instead of the usual single character. When one of these is included in +the class, the entire sequence is matched. For example, + + "\N{TAMIL LETTER KA}\N{TAMIL VOWEL SIGN AU}" + =~ / ^ [\N{TAMIL SYLLABLE KAU}] $ /x; + +matches, because C<\N{TAMIL SYLLABLE KAU}> is a named sequence +consisting of the two characters matched against. Like the other +instance where a bracketed class can match multi characters, and for +similar reasons, the class must not be inverted, and the named sequence +may not appear in a range, even one where it is both endpoints. If +these happen, it is a fatal error if the character class is within an +extended L|/Extended Bracketed Character Classes> +class; and only the first code point is used (with +a C-type warning raised) otherwise. + +=back + =head3 Special Characters Inside a Bracketed Character Class Most characters that are meta characters in regular expressions (that @@ -597,9 +626,10 @@ the caret as one of the characters to match, either escape the caret or else don't list it first. In inverted bracketed character classes, Perl ignores the Unicode rules -that normally say that certain characters should match a sequence of -multiple characters under caseless C matching. Following those -rules could lead to highly confusing situations: +that normally say that named sequence, and certain characters should +match a sequence of multiple characters use under caseless C +matching. Following those rules could lead to highly confusing +situations: "ss" =~ /^[^\xDF]+$/ui; # Matches! @@ -608,7 +638,7 @@ what C<\xDF> matches under C. C<"s"> isn't C<\xDF>, but Unicode says that C<"ss"> is what C<\xDF> matches under C. So which one "wins"? Do you fail the match because the string has C or accept it because it has an C followed by another C? Perl has chosen the -latter. +latter. (See note in L above.) Examples: @@ -772,9 +802,9 @@ Unicode considers symbols. =item [6] -C<\p{SpacePerl}> and C<\p{Space}> match identically starting with Perl +C<\p{XPerlSpace}> and C<\p{Space}> match identically starting with Perl v5.18. In earlier versions, these differ only in that in non-locale -matching, C<\p{SpacePerl}> does not match the vertical tab, C<\cK>. +matching, C<\p{XPerlSpace}> does not match the vertical tab, C<\cK>. Same for the two ASCII-only range forms. =back @@ -1046,16 +1076,6 @@ Cd> rules for the entire regular expression containing it. =back -The Cx> processing within this class is an extended form. -Besides the characters that are considered white space in normal C -processing, there are 5 others, recommended by the Unicode standard: - - U+0085 NEXT LINE - U+200E LEFT-TO-RIGHT MARK - U+200F RIGHT-TO-LEFT MARK - U+2028 LINE SEPARATOR - U+2029 PARAGRAPH SEPARATOR - Note that skipping white space applies only to the interior of this construct. There must not be any space between any of the characters that form the initial C<(?[>. Nor may there be space between the diff --git a/pod/perlsec.pod b/pod/perlsec.pod index b6474e6..75ce3fd 100644 --- a/pod/perlsec.pod +++ b/pod/perlsec.pod @@ -28,9 +28,9 @@ Perl automatically enables a set of special security checks, called I, when it detects its program running with differing real and effective user or group IDs. The setuid bit in Unix permissions is mode 04000, the setgid bit mode 02000; either or both may be set. You can also enable taint -mode explicitly by using the B<-T> command line flag. This flag is +mode explicitly by using the B<-T> command line flag. This flag is I suggested for server programs and any program run on behalf of -someone else, such as a CGI script. Once taint mode is on, it's on for +someone else, such as a CGI script. Once taint mode is on, it's on for the remainder of your script. While in this mode, Perl takes special precautions called I) is in effect, the "." directory is removed from C<@INC>, and the environment variables C and C -are ignored by Perl. You can still adjust C<@INC> from outside the +are ignored by Perl. You can still adjust C<@INC> from outside the program by using the C<-I> command line option as explained in -L. The two environment variables are ignored because +L. The two environment variables are ignored because they are obscured, and a user running a program could be unaware that they are set, whereas the C<-I> option is clearly visible and therefore permitted. @@ -247,7 +247,7 @@ the C pragma, e.g.: perl -Mlib=/foo program The benefit of using C<-Mlib=/foo> over C<-I/foo>, is that the former -will automagically remove any duplicated directories, while the later +will automagically remove any duplicated directories, while the latter will not. Note that if a tainted string is added to C<@INC>, the following @@ -271,7 +271,7 @@ your PATH, it makes sure you set the PATH. The PATH isn't the only environment variable which can cause problems. Because some shells may use the variables IFS, CDPATH, ENV, and BASH_ENV, Perl checks that those are either empty or untainted when -starting subprocesses. You may wish to add something like this to your +starting subprocesses. You may wish to add something like this to your setid and taint-checking scripts. delete @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer @@ -280,7 +280,8 @@ It's also possible to get into trouble with other operations that don't care whether they use tainted values. Make judicious use of the file tests in dealing with any user-supplied filenames. When possible, do opens and such B properly dropping any special user (or group!) -privileges. Perl doesn't prevent you from opening tainted filenames for reading, +privileges. Perl doesn't prevent you from +opening tainted filenames for reading, so be careful what you print out. The tainting mechanism is intended to prevent stupid mistakes, not to remove the need for thought. @@ -353,7 +354,7 @@ are trapped and namespace access is carefully controlled. Safe should not be considered bullet-proof, though: it will not prevent the foreign code to set up infinite loops, allocate gigabytes of memory, or even abusing perl bugs to make the host interpreter crash or behave in -unpredictable ways. In any case it's better avoided completely if you're +unpredictable ways. In any case it's better avoided completely if you're really concerned about security. =head2 Security Bugs @@ -458,17 +459,17 @@ I (DoS) attacks. Hash Algorithm - Hash algorithms like the one used in Perl are well known to be vulnerable to collision attacks on their hash function. Such attacks involve constructing a set of keys which collide into -the same bucket producing inefficient behavior. Such attacks often +the same bucket producing inefficient behavior. Such attacks often depend on discovering the seed of the hash function used to map the -keys to buckets. That seed is then used to brute-force a key set which -can be used to mount a denial of service attack. In Perl 5.8.1 changes +keys to buckets. That seed is then used to brute-force a key set which +can be used to mount a denial of service attack. In Perl 5.8.1 changes were introduced to harden Perl to such attacks, and then later in Perl 5.18.0 these features were enhanced and additional protections added. At the time of this writing, Perl 5.18.0 is considered to be well-hardened against algorithmic complexity attacks on its hash -implementation. This is largely owed to the following measures +implementation. This is largely owed to the following measures mitigate attacks: =over 4 @@ -476,9 +477,9 @@ mitigate attacks: =item Hash Seed Randomization In order to make it impossible to know what seed to generate an attack -key set for, this seed is randomly initialized at process start. This +key set for, this seed is randomly initialized at process start. This may be overridden by using the PERL_HASH_SEED environment variable, see -L. This environment variable controls how +L. This environment variable controls how items are actually stored, not how they are presented via C, C and C. @@ -489,14 +490,15 @@ C, and C return items in a per-hash randomized order. Modifying a hash by insertion will change the iteration order of that hash. This behavior can be overridden by using C from L or by using the PERL_PERTURB_KEYS environment variable, -see L. Note that this feature controls the +see L. Note that this feature controls the "visible" order of the keys, and not the actual order they are stored in. =item Bucket Order Perturbance When items collide into a given hash bucket the order they are stored in -the chain is no longer predictable in Perl 5.18. This has the intention -to make it harder to observe a collisions. This behavior can be overridden by using +the chain is no longer predictable in Perl 5.18. This +has the intention to make it harder to observe a +collision. This behavior can be overridden by using the PERL_PERTURB_KEYS environment variable, see L. =item New Default Hash Function @@ -508,16 +510,16 @@ it harder to infer the hash seed. The source code includes multiple hash algorithms to choose from. While we believe that the default perl hash is robust to attack, we have included the -hash function Siphash as a fall-back option. At the time of release of +hash function Siphash as a fall-back option. At the time of release of Perl 5.18.0 Siphash is believed to be of cryptographic strength. This is not the default as it is much slower than the default hash. =back Without compiling a special Perl, there is no way to get the exact same -behavior of any versions prior to Perl 5.18.0. The closest one can get +behavior of any versions prior to Perl 5.18.0. The closest one can get is by setting PERL_PERTURB_KEYS to 0 and setting the PERL_HASH_SEED -to a known value. We do not advise those settings for production use +to a known value. We do not advise those settings for production use due to the above security considerations. B, and diff --git a/pod/perlsub.pod b/pod/perlsub.pod index aeced63..3146037 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -89,8 +89,8 @@ aggregates (arrays and hashes), these will be flattened together into one large indistinguishable list. If no C is found and if the last statement is an expression, its -value is returned. If the last statement is a loop control structure -like a C or a C, the returned value is unspecified. The +value is returned. If the last statement is a loop control structure +like a C or a C, the returned value is unspecified. The empty sub returns the empty list. X X X @@ -247,7 +247,7 @@ core, as are modules whose names are in all lower case. A subroutine in all capitals is a loosely-held convention meaning it will be called indirectly by the run-time system itself, usually due to a triggered event. Subroutines whose name start with a left parenthesis are also reserved the -same way. The following is a list of some subroutines that currently do +same way. The following is a list of some subroutines that currently do special, pre-defined things. =over @@ -699,7 +699,7 @@ this. X X X X X X There are two ways to build persistent private variables in Perl 5.10. -First, you can simply use the C feature. Or, you can use closures, +First, you can simply use the C feature. Or, you can use closures, if you want to stay compatible with releases older than 5.10. =head3 Persistent variables via state() @@ -924,7 +924,7 @@ X X X It's also worth taking a moment to explain what happens when you Cize a member of a composite type (i.e. an array or hash element). -In this case, the element is Cized I. This means that +In this case, the element is Cized I. This means that when the scope of the C ends, the saved value will be restored to the hash element whose key was named in the C, or the array element whose index was named in the C. If that @@ -967,7 +967,7 @@ X X X X and C constructs to delete a composite type entry for the current block and restore -it when it ends. They return the array/hash value before the localization, +it when it ends. They return the array/hash value before the localization, which means that they are respectively equivalent to do { @@ -986,7 +986,8 @@ and $val } -except that for those the C is scoped to the C block. Slices are +except that for those the C is +scoped to the C block. Slices are also accepted. my %hash = ( @@ -1030,7 +1031,7 @@ To do this, you have to declare the subroutine to return an lvalue. The scalar/list context for the subroutine and for the right-hand side of assignment is determined as if the subroutine call is replaced -by a scalar. For example, consider: +by a scalar. For example, consider: data(2,3) = get_data(3,4); @@ -1045,9 +1046,9 @@ and in: all the subroutines are called in a list context. Lvalue subroutines are convenient, but you have to keep in mind that, -when used with objects, they may violate encapsulation. A normal +when used with objects, they may violate encapsulation. A normal mutator can check the supplied argument before setting the attribute -it is protecting, an lvalue subroutine cannot. If you require any +it is protecting, an lvalue subroutine cannot. If you require any special processing when storing and retrieving the values, consider using the CPAN module Sentinel or something similar. @@ -1445,12 +1446,12 @@ Any backslashed prototype character represents an actual argument that must start with that character (optionally preceded by C, C or C), with the exception of C<$>, which will accept any scalar lvalue expression, such as C<$foo = 7> or -C<< my_function()->[0] >>. The value passed as part of C<@_> will be a +C<< my_function()->[0] >>. The value passed as part of C<@_> will be a reference to the actual argument given in the subroutine call, obtained by applying C<\> to that argument. You can use the C<\[]> backslash group notation to specify more than one -allowed argument type. For example: +allowed argument type. For example: sub myref (\[$@%&*]) @@ -1655,7 +1656,7 @@ the constant folding doesn't reduce them to a single constant: As alluded to earlier you can also declare inlined subs dynamically at BEGIN time if their body consists of a lexically-scoped scalar which -has no other references. Only the first example here will be inlined: +has no other references. Only the first example here will be inlined: BEGIN { my $var = 1; @@ -1711,7 +1712,7 @@ without (with deparse output truncated for clarity): }; If you redefine a subroutine that was eligible for inlining, you'll -get a warning by default. You can use this warning to tell whether or +get a warning by default. You can use this warning to tell whether or not a particular subroutine is considered inlinable, since it's different than the warning for overriding non-inlined subroutines: @@ -1850,7 +1851,7 @@ And, as you'll have noticed from the previous example, if you override C, the C<< <*> >> glob operator is overridden as well. In a similar fashion, overriding the C function also overrides -the equivalent I/O operator C<< >>. Also, overriding +the equivalent I/O operator C<< >>. Also, overriding C also overrides the operators C<``> and C. Finally, some built-ins (e.g. C or C) can't be overridden. diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index cea4d50..2a5ced5 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -788,20 +788,17 @@ syntax error if Perl doesn't guess that the C<{ ... }> is a block. In that case, it doesn't think the C<...> is an ellipsis because it's expecting an expression instead of a statement: - @transformed = map { ... } @input; # syntax error + @transformed = map { ... } @input; # syntax error -You can use a C<;> inside your block to denote that the C<{ ... }> is a -block and not a hash reference constructor. Now the ellipsis works: +Inside your block, you can use a C<;> before the ellipsis to denote that the +C<{ ... }> is a block and not a hash reference constructor. Now the ellipsis +works: - @transformed = map {; ... } @input; # ; disambiguates - - @transformed = map { ...; } @input; # ; disambiguates + @transformed = map {; ... } @input; # ';' disambiguates Note: Some folks colloquially refer to this bit of punctuation as a "yada-yada" or "triple-dot", but its true name -is actually an ellipsis. Perl does not yet -accept the Unicode version, U+2026 HORIZONTAL ELLIPSIS, as an alias for -C<...>, but someday it may. +is actually an ellipsis. =head2 PODs: Embedded Documentation X X diff --git a/pp.c b/pp.c index 5218f7b..2f0c905 100644 --- a/pp.c +++ b/pp.c @@ -249,6 +249,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, const char * const name = CopSTASHPV(PL_curcop); gv = newGVgen_flags(name, HvNAMEUTF8(CopSTASH(PL_curcop)) ? SVf_UTF8 : 0 ); + SvREFCNT_inc_simple_void_NN(gv); } prepare_SV_for_RV(sv); SvRV_set(sv, MUTABLE_SV(gv)); @@ -471,7 +472,9 @@ PP(pp_rv2cv) CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags); if (cv) NOOP; else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) { - cv = MUTABLE_CV(gv); + cv = SvTYPE(SvRV(gv)) == SVt_PVCV + ? MUTABLE_CV(SvRV(gv)) + : MUTABLE_CV(gv); } else cv = MUTABLE_CV(&PL_sv_undef); @@ -570,7 +573,6 @@ S_refto(pTHX_ SV *sv) SvREFCNT_inc_void_NN(sv); } else if (SvPADTMP(sv)) { - assert(!IS_PADGV(sv)); sv = newSVsv(sv); } else { @@ -739,6 +741,9 @@ PP(pp_study) RETPUSHYES; } + +/* also used for: pp_transr() */ + PP(pp_trans) { dSP; dTARG; @@ -932,6 +937,9 @@ S_do_chomp(pTHX_ SV *retval, SV *sv, bool chomping) } } + +/* also used for: pp_schomp() */ + PP(pp_schop) { dSP; dTARGET; @@ -944,6 +952,9 @@ PP(pp_schop) RETURN; } + +/* also used for: pp_chomp() */ + PP(pp_chop) { dSP; dMARK; dTARGET; dORIGMARK; @@ -972,7 +983,8 @@ PP(pp_undef) if (!sv) RETPUSHUNDEF; - SV_CHECK_THINKFIRST_COW_DROP(sv); + if (SvTHINKFIRST(sv)) + sv_force_normal_flags(sv, SV_COW_DROP_PV|SV_IMMEDIATE_UNREF); switch (SvTYPE(sv)) { case SVt_NULL: @@ -997,18 +1009,8 @@ PP(pp_undef) )); /* FALLTHROUGH */ case SVt_PVFM: - { /* let user-undef'd sub keep its identity */ - GV* const gv = CvGV((const CV *)sv); - HEK * const hek = CvNAME_HEK((CV *)sv); - if (hek) share_hek_hek(hek); - cv_undef(MUTABLE_CV(sv)); - if (gv) CvGV_set(MUTABLE_CV(sv), gv); - else if (hek) { - SvANY((CV *)sv)->xcv_gv_u.xcv_hek = hek; - CvNAMED_on(sv); - } - } + cv_undef_flags(MUTABLE_CV(sv), CV_UNDEF_KEEP_NAME); break; case SVt_PVGV: assert(isGV_with_GP(sv)); @@ -1067,6 +1069,9 @@ PP(pp_undef) RETPUSHUNDEF; } + +/* also used for: pp_i_postdec() pp_i_postinc() pp_postdec() */ + PP(pp_postinc) { dSP; dTARGET; @@ -1715,7 +1720,6 @@ PP(pp_repeat) #else if (*SP) { if (mod && SvPADTMP(*SP)) { - assert(!IS_PADGV(*SP)); *SP = sv_mortalcopy(*SP); } SvTEMP_off((*SP)); @@ -2105,6 +2109,9 @@ PP(pp_ncmp) RETURN; } + +/* also used for: pp_sge() pp_sgt() pp_slt() */ + PP(pp_sle) { dSP; @@ -2215,6 +2222,9 @@ PP(pp_bit_and) } } + +/* also used for: pp_bit_xor() */ + PP(pp_bit_or) { dSP; dATARGET; @@ -2681,48 +2691,47 @@ PP(pp_atan2) } } + +/* also used for: pp_cos() pp_exp() pp_log() pp_sqrt() */ + PP(pp_sin) { dSP; dTARGET; - int amg_type = sin_amg; + int amg_type = fallback_amg; const char *neg_report = NULL; - NV (*func)(NV) = Perl_sin; const int op_type = PL_op->op_type; switch (op_type) { - case OP_COS: - amg_type = cos_amg; - func = Perl_cos; - break; - case OP_EXP: - amg_type = exp_amg; - func = Perl_exp; - break; - case OP_LOG: - amg_type = log_amg; - func = Perl_log; - neg_report = "log"; - break; - case OP_SQRT: - amg_type = sqrt_amg; - func = Perl_sqrt; - neg_report = "sqrt"; - break; + case OP_SIN: amg_type = sin_amg; break; + case OP_COS: amg_type = cos_amg; break; + case OP_EXP: amg_type = exp_amg; break; + case OP_LOG: amg_type = log_amg; neg_report = "log"; break; + case OP_SQRT: amg_type = sqrt_amg; neg_report = "sqrt"; break; } + assert(amg_type != fallback_amg); tryAMAGICun_MG(amg_type, 0); { SV * const arg = POPs; const NV value = SvNV_nomg(arg); - if (neg_report) { + NV result = NV_NAN; + if (neg_report) { /* log or sqrt */ if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) { SET_NUMERIC_STANDARD(); /* diag_listed_as: Can't take log of %g */ DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value); } } - XPUSHn(func(value)); + switch (op_type) { + default: + case OP_SIN: result = Perl_sin(value); break; + case OP_COS: result = Perl_cos(value); break; + case OP_EXP: result = Perl_exp(value); break; + case OP_LOG: result = Perl_log(value); break; + case OP_SQRT: result = Perl_sqrt(value); break; + } + XPUSHn(result); RETURN; } } @@ -2892,6 +2901,9 @@ PP(pp_abs) RETURN; } + +/* also used for: pp_hex() */ + PP(pp_oct) { dSP; dTARGET; @@ -2919,11 +2931,11 @@ PP(pp_oct) tmps++, len--; if (*tmps == '0') tmps++, len--; - if (*tmps == 'x' || *tmps == 'X') { + if (isALPHA_FOLD_EQ(*tmps, 'x')) { hex: result_uv = grok_hex (tmps, &len, &flags, &result_nv); } - else if (*tmps == 'b' || *tmps == 'B') + else if (isALPHA_FOLD_EQ(*tmps, 'b')) result_uv = grok_bin (tmps, &len, &flags, &result_nv); else result_uv = grok_oct (tmps, &len, &flags, &result_nv); @@ -3198,6 +3210,9 @@ PP(pp_vec) RETURN; } + +/* also used for: pp_rindex() */ + PP(pp_index) { dSP; dTARGET; @@ -3356,23 +3371,32 @@ PP(pp_chr) SV *top = POPs; SvGETMAGIC(top); - if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ - && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) - || - ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) - && SvNV_nomg(top) < 0.0))) { + if (SvNOK(top) && Perl_isinfnan(SvNV(top))) { + if (ckWARN(WARN_UTF8)) { + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Invalid number (%"NVgf") in chr", SvNV(top)); + } + value = UNICODE_REPLACEMENT; + } + else { + if (!IN_BYTES /* under bytes, chr(-1) eq chr(0xff), etc. */ + && ((SvIOKp(top) && !SvIsUV(top) && SvIV_nomg(top) < 0) + || + ((SvNOKp(top) || (SvOK(top) && !SvIsUV(top))) + && SvNV_nomg(top) < 0.0))) { if (ckWARN(WARN_UTF8)) { if (SvGMAGICAL(top)) { SV *top2 = sv_newmortal(); sv_setsv_nomg(top2, top); top = top2; } - Perl_warner(aTHX_ packWARN(WARN_UTF8), - "Invalid negative number (%"SVf") in chr", SVfARG(top)); - } - value = UNICODE_REPLACEMENT; - } else { - value = SvUV_nomg(top); + Perl_warner(aTHX_ packWARN(WARN_UTF8), + "Invalid negative number (%"SVf") in chr", SVfARG(top)); + } + value = UNICODE_REPLACEMENT; + } else { + value = SvUV_nomg(top); + } } SvUPGRADE(TARG,SVt_PV); @@ -3467,6 +3491,9 @@ PP(pp_crypt) /* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So * most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */ + +/* also used for: pp_lcfirst() */ + PP(pp_ucfirst) { /* Actually is both lcfirst() and ucfirst(). Only the first character @@ -4455,7 +4482,11 @@ PP(pp_kvaslice) RETURN; } + /* Smart dereferencing for keys, values and each */ + +/* also used for: pp_reach() pp_rvalues() */ + PP(pp_rkeys) { dSP; @@ -4518,6 +4549,7 @@ PP(pp_aeach) RETURN; } +/* also used for: pp_avalues()*/ PP(pp_akeys) { dSP; @@ -4959,7 +4991,6 @@ PP(pp_lslice) if (!(*lelem = firstrelem[ix])) *lelem = &PL_sv_undef; else if (mod && SvPADTMP(*lelem)) { - assert(!IS_PADGV(*lelem)); *lelem = firstrelem[ix] = sv_mortalcopy(*lelem); } } @@ -5291,6 +5322,7 @@ PP(pp_push) RETURN; } +/* also used for: pp_pop()*/ PP(pp_shift) { dSP; @@ -5925,6 +5957,9 @@ PP(pp_lock) } +/* used for: pp_padany(), pp_mapstart(), pp_custom(); plus any system ops + * that aren't implemented on a particular platform */ + PP(unimplemented_op) { const Optype op_type = PL_op->op_type; diff --git a/pp.h b/pp.h index a7e936c..d0691f8 100644 --- a/pp.h +++ b/pp.h @@ -379,8 +379,7 @@ Does not use C. See also C, C and C. #define ARGTARG PL_op->op_targ - /* See OPpTARGET_MY: */ -#define MAXARG (PL_op->op_private & 15) +#define MAXARG (PL_op->op_private & OPpARG4_MASK) #define SWITCHSTACK(f,t) \ STMT_START { \ diff --git a/pp_ctl.c b/pp_ctl.c index 5e671ee..7f60cce 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -793,26 +793,14 @@ PP(pp_formline) case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */ arg = *fpc++; -#if defined(USE_LONG_DOUBLE) fmt = (const char *) - ((arg & FORM_NUM_POINT) ? - "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); -#else - fmt = (const char *) - ((arg & FORM_NUM_POINT) ? - "%#0*.*f" : "%0*.*f"); -#endif + ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff); goto ff_dec; case FF_DECIMAL: /* do @##, ^##, where =(precision|flags) */ arg = *fpc++; -#if defined(USE_LONG_DOUBLE) fmt = (const char *) - ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); -#else - fmt = (const char *) - ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f"); -#endif + ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff); ff_dec: /* If the field is marked with ^ and the value is undefined, blank it out. */ @@ -837,11 +825,25 @@ PP(pp_formline) int len; DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(fmt); + int len; + if (!qfmt) + Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt); + len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value); + if (len == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + if (qfmt != fmt) + Safefree(fmt); + } +#else /* we generate fmt ourselves so it is safe */ GCC_DIAG_IGNORE(-Wformat-nonliteral); len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value); - PERL_MY_SNPRINTF_POST_GUARD(len, max); GCC_DIAG_RESTORE; +#endif + PERL_MY_SNPRINTF_POST_GUARD(len, max); RESTORE_LC_NUMERIC(); } t += fieldsize; @@ -939,7 +941,6 @@ PP(pp_grepstart) src = PL_stack_base[*PL_markstack_ptr]; if (SvPADTMP(src)) { - assert(!IS_PADGV(src)); src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); PL_tmps_floor++; } @@ -1092,7 +1093,6 @@ PP(pp_mapwhile) /* set $_ to the new source item */ src = PL_stack_base[PL_markstack_ptr[-1]]; if (SvPADTMP(src)) { - assert(!IS_PADGV(src)); src = sv_mortalcopy(src); } SvTEMP_off(src); @@ -1626,7 +1626,9 @@ Perl_die_unwind(pTHX_ SV *msv) SV *namesv; PERL_CONTEXT *cx; SV **newsp; +#ifdef DEBUGGING COP *oldcop; +#endif JMPENV *restartjmpenv; OP *restartop; @@ -1643,7 +1645,9 @@ Perl_die_unwind(pTHX_ SV *msv) } POPEVAL(cx); namesv = cx->blk_eval.old_namesv; +#ifdef DEBUGGING oldcop = cx->blk_oldcop; +#endif restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; @@ -1653,13 +1657,8 @@ Perl_die_unwind(pTHX_ SV *msv) LEAVE; - /* LEAVE could clobber PL_curcop (see save_re_context()) - * XXX it might be better to find a way to avoid messing with - * PL_curcop in save_re_context() instead, but this is a more - * minimal fix --GSAR */ - PL_curcop = oldcop; - if (optype == OP_REQUIRE) { + assert (PL_curcop == oldcop); (void)hv_store(GvHVn(PL_incgv), SvPVX_const(namesv), SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv), @@ -1819,12 +1818,9 @@ PP(pp_caller) if (!has_arg) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - GV * const cvgv = CvGV(dbcx->blk_sub.cv); /* So is ccstack[dbcxix]. */ - if (cvgv && isGV(cvgv)) { - SV * const sv = newSV(0); - gv_efullname3(sv, cvgv, NULL); - mPUSHs(sv); + if (CvHASGV(dbcx->blk_sub.cv)) { + PUSHs(cv_name(dbcx->blk_sub.cv, 0)); PUSHs(boolSV(CxHASARGS(cx))); } else { @@ -1996,17 +1992,24 @@ PP(pp_dbstate) return NORMAL; } +/* S_leave_common: Common code that many functions in this file use on + scope exit. */ + /* SVs on the stack that have any of the flags passed in are left as is. Other SVs are protected via the mortals stack if lvalue is true, and - copied otherwise. */ + copied otherwise. + + Also, taintedness is cleared. +*/ STATIC SV ** -S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, +S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue) { bool padtmp = 0; - PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; + PERL_ARGS_ASSERT_LEAVE_COMMON; + TAINT_NOT; if (flags & SVs_PADTMP) { flags &= ~SVs_PADTMP; padtmp = 1; @@ -2076,8 +2079,7 @@ PP(pp_leave) gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); - TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, + SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, PL_op->op_private & OPpLVALUE); PL_curpm = newpm; /* Don't pop $1 et al till now */ @@ -2133,29 +2135,30 @@ PP(pp_enteriter) SvGETMAGIC(sv); SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { + NV nv; cx->cx_type &= ~CXTYPEMASK; cx->cx_type |= CXt_LOOP_LAZYIV; /* Make sure that no-one re-orders cop.h and breaks our assumptions */ assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); #ifdef NV_PRESERVES_UV - if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) || - (SvNV_nomg(sv) > (NV)IV_MAX))) + if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) < (NV)IV_MIN) || + (nv > (NV)IV_MAX))) || - (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) || - (SvNV_nomg(right) < (NV)IV_MIN)))) + (SvOK(right) && (((nv = SvNV_nomg(right)) > (NV)IV_MAX) || + (nv < (NV)IV_MIN)))) #else - if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN) + if ((SvOK(sv) && (((nv = SvNV_nomg(sv)) <= (NV)IV_MIN) || - ((SvNV_nomg(sv) > 0) && - ((SvUV_nomg(sv) > (UV)IV_MAX) || - (SvNV_nomg(sv) > (NV)UV_MAX))))) + ((nv > 0) && + ((nv > (NV)UV_MAX) || + (SvUV_nomg(sv) > (UV)IV_MAX))))) || - (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN) + (SvOK(right) && (((nv = SvNV_nomg(right)) <= (NV)IV_MIN) || - ((SvNV_nomg(right) > 0) && - ((SvUV_nomg(right) > (UV)IV_MAX) || - (SvNV_nomg(right) > (NV)UV_MAX)) + ((nv > 0) && + ((nv > (NV)UV_MAX) || + (SvUV_nomg(right) > (UV)IV_MAX)) )))) #endif DIE(aTHX_ "Range iterator outside integer range"); @@ -2239,8 +2242,7 @@ PP(pp_leaveloop) mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; - TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0, + SP = leave_common(newsp, SP, MARK, gimme, 0, PL_op->op_private & OPpLVALUE); PUTBACK; @@ -2741,7 +2743,10 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac return 0; } -PP(pp_goto) /* also pp_dump */ + +/* also used for: pp_dump() */ + +PP(pp_goto) { dVAR; dSP; OP *retop = NULL; @@ -3652,6 +3657,9 @@ S_path_is_searchable(const char *name) return TRUE; } + +/* also used for: pp_dofile() */ + PP(pp_require) { dSP; @@ -4298,8 +4306,7 @@ PP(pp_leaveeval) retop = cx->blk_eval.retop; evalcv = cx->blk_eval.cv; - TAINT_NOT; - SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, + SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp, gimme, SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ @@ -4396,8 +4403,7 @@ PP(pp_leavetry) POPEVAL(cx); PERL_UNUSED_VAR(optype); - TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ @@ -4443,8 +4449,7 @@ PP(pp_leavegiven) POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_GIVEN); - TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* Don't pop $1 et al till now */ @@ -5017,8 +5022,7 @@ PP(pp_leavewhen) POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_WHEN); - TAINT_NOT; - SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, + SP = leave_common(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE); PL_curpm = newpm; /* pop $1 et al */ diff --git a/pp_hot.c b/pp_hot.c index 12a22cb..4f9519d 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -47,6 +47,7 @@ PP(pp_const) PP(pp_nextstate) { PL_curcop = (COP*)PL_op; + PL_sawalias = 0; TAINT_NOT; /* Each statement is presumed innocent */ PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp; FREETMPS; @@ -62,9 +63,14 @@ PP(pp_gvsv) PUSHs(save_scalar(cGVOP_gv)); else PUSHs(GvSVn(cGVOP_gv)); + if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)) + PL_sawalias = TRUE; RETURN; } + +/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */ + PP(pp_null) { return NORMAL; @@ -92,9 +98,15 @@ PP(pp_gv) { dSP; XPUSHs(MUTABLE_SV(cGVOP_gv)); + if (isGV(cGVOP_gv) + && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))) + PL_sawalias = TRUE; RETURN; } + +/* also used for: pp_andassign() */ + PP(pp_and) { PERL_ASYNC_CHECK(); @@ -458,6 +470,9 @@ PP(pp_eq) RETURN; } + +/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */ + PP(pp_preinc) { dSP; @@ -478,6 +493,9 @@ PP(pp_preinc) return NORMAL; } + +/* also used for: pp_orassign() */ + PP(pp_or) { dSP; @@ -491,6 +509,9 @@ PP(pp_or) } } + +/* also used for: pp_dor() pp_dorassign() */ + PP(pp_defined) { dSP; @@ -714,6 +735,9 @@ PP(pp_add) } } + +/* also used for: pp_aelemfast_lex() */ + PP(pp_aelemfast) { dSP; @@ -764,6 +788,8 @@ PP(pp_pushre) /* Oversized hot code. */ +/* also used for: pp_say() */ + PP(pp_print) { dSP; dMARK; dORIGMARK; @@ -858,6 +884,9 @@ PP(pp_print) RETURN; } + +/* also used for: pp_rv2hv() */ + PP(pp_rv2av) { dSP; dTOPss; @@ -1005,7 +1034,7 @@ PP(pp_aassign) * Don't bother if LHS is just an empty hash or array. */ - if ( (PL_op->op_private & OPpASSIGN_COMMON) + if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias) && ( firstlelem != lastlelem || ! ((sv = *firstlelem)) @@ -1917,7 +1946,6 @@ PP(pp_iter) Perl_croak(aTHX_ "Use of freed value in iteration"); } if (SvPADTMP(sv)) { - assert(!IS_PADGV(sv)); sv = newSVsv(sv); } else { @@ -2435,7 +2463,6 @@ PP(pp_grepwhile) src = PL_stack_base[*PL_markstack_ptr]; if (SvPADTMP(src)) { - assert(!IS_PADGV(src)); src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src); PL_tmps_floor++; } @@ -2595,15 +2622,15 @@ PP(pp_entersub) SV* sub_name; /* anonymous or undef'd function leaves us no recourse */ - if (CvANON(cv) || !(gv = CvGV(cv))) { - if (CvNAMED(cv)) - DIE(aTHX_ "Undefined subroutine &%"HEKf" called", - HEKfARG(CvNAME_HEK(cv))); + if (CvLEXICAL(cv) && CvHASGV(cv)) + DIE(aTHX_ "Undefined subroutine &%"SVf" called", + SVfARG(cv_name(cv, NULL))); + if (CvANON(cv) || !CvHASGV(cv)) { DIE(aTHX_ "Undefined subroutine called"); } /* autoloaded stub? */ - if (cv != GvCV(gv)) { + if (cv != GvCV(gv = CvGV(cv))) { cv = GvCV(gv); } /* should call AUTOLOAD now? */ @@ -2697,7 +2724,6 @@ try_autoload: if (*MARK) { if (SvPADTMP(*MARK)) { - assert(!IS_PADGV(*MARK)); *MARK = sv_mortalcopy(*MARK); } SvTEMP_off(*MARK); @@ -2766,7 +2792,6 @@ try_autoload: while (items--) { mark++; if (*mark && SvPADTMP(*mark)) { - assert(!IS_PADGV(*mark)); *mark = sv_mortalcopy(*mark); } } @@ -2804,17 +2829,8 @@ Perl_sub_crush_depth(pTHX_ CV *cv) if (CvANON(cv)) Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { - HEK *const hek = CvNAME_HEK(cv); - SV *tmpstr; - if (hek) { - tmpstr = sv_2mortal(newSVhek(hek)); - } - else { - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, CvGV(cv), NULL); - } Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"", - SVfARG(tmpstr)); + SVfARG(cv_name(cv,NULL))); } } @@ -3000,22 +3016,12 @@ S_method_common(pTHX_ SV* meth, U32* hashp) GV* iogv; STRLEN packlen; const char * const packname = SvPV_nomg_const(sv, packlen); - const bool packname_is_utf8 = !!SvUTF8(sv); - const HE* const he = - (const HE *)hv_common( - PL_stashcache, NULL, packname, packlen, - packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0 - ); - - if (he) { - stash = INT2PTR(HV*,SvIV(HeVAL(he))); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n", - (void*)stash, SVfARG(sv))); - goto fetch; - } + const U32 packname_utf8 = SvUTF8(sv); + stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY); + if (stash) goto fetch; if (!(iogv = gv_fetchpvn_flags( - packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO + packname, packlen, packname_utf8, SVt_PVIO )) || !(ob=MUTABLE_SV(GvIO(iogv)))) { @@ -3027,16 +3033,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SVfARG(meth)); } /* assume it's a package name */ - stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0); - if (!stash) - packsv = sv; - else { - SV* const ref = newSViv(PTR2IV(stash)); - (void)hv_store(PL_stashcache, packname, - packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0); - DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n", - (void*)stash, SVfARG(sv))); - } + stash = gv_stashpvn(packname, packlen, packname_utf8); + if (!stash) packsv = sv; goto fetch; } /* it _is_ a filehandle name -- replace with a reference */ diff --git a/pp_pack.c b/pp_pack.c index 6b14751..d35a5af 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -2540,7 +2540,15 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { IV aiv; fromstr = NEXTFROM; - aiv = SvIV(fromstr); + if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) { + /* 255 is a pretty arbitrary choice, but with + * inf/-inf/nan and 256 bytes there is not much room. */ + aiv = 255; + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'c' format overflow in pack"); + } + else + aiv = SvIV(fromstr); if ((-128 > aiv || aiv > 127)) Perl_ck_warner(aTHX_ packWARN(WARN_PACK), "Character in 'c' format wrapped in pack"); @@ -2555,7 +2563,14 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) while (len-- > 0) { IV aiv; fromstr = NEXTFROM; - aiv = SvIV(fromstr); + if (SvNOK(fromstr) && Perl_isinfnan(SvNV(fromstr))) { + /* See the 'c' case. */ + aiv = 255; + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'C' format overflow in pack"); + } + else + aiv = SvIV(fromstr); if ((0 > aiv || aiv > 0xff)) Perl_ck_warner(aTHX_ packWARN(WARN_PACK), "Character in 'C' format wrapped in pack"); diff --git a/pp_sort.c b/pp_sort.c index f75ecd9..9213621 100644 --- a/pp_sort.c +++ b/pp_sort.c @@ -1604,7 +1604,6 @@ PP(pp_sort) for (i=max; i > 0 ; i--) { if ((*p1 = *p2++)) { /* Weed out nulls. */ if (copytmps && SvPADTMP(*p1)) { - assert(!IS_PADGV(*p1)); *p1 = sv_mortalcopy(*p1); } SvTEMP_off(*p1); diff --git a/pp_sys.c b/pp_sys.c index e01cf48..ac2a87c 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -954,6 +954,9 @@ PP(pp_tie) RETURN; } + +/* also used for: pp_dbmclose() */ + PP(pp_untie) { dSP; @@ -1604,6 +1607,9 @@ PP(pp_sysopen) RETURN; } + +/* also used for: pp_read() and pp_recv() (where supported) */ + PP(pp_sysread) { dSP; dMARK; dORIGMARK; dTARGET; @@ -1860,6 +1866,9 @@ PP(pp_sysread) RETPUSHUNDEF; } + +/* also used for: pp_send() where defined */ + PP(pp_syswrite) { dSP; dMARK; dORIGMARK; dTARGET; @@ -2158,6 +2167,9 @@ PP(pp_tell) RETURN; } + +/* also used for: pp_seek() */ + PP(pp_sysseek) { dSP; @@ -2294,6 +2306,9 @@ PP(pp_truncate) } } + +/* also used for: pp_fcntl() */ + PP(pp_ioctl) { dSP; dTARGET; @@ -2489,6 +2504,8 @@ PP(pp_sockpair) #ifdef HAS_SOCKET +/* also used for: pp_connect() */ + PP(pp_bind) { dSP; @@ -2629,6 +2646,9 @@ nuts: RETPUSHUNDEF; } + +/* also used for: pp_gsockopt() */ + PP(pp_ssockopt) { dSP; @@ -2703,6 +2723,9 @@ nuts2: } + +/* also used for: pp_getsockname() */ + PP(pp_getpeername) { dSP; @@ -2767,6 +2790,8 @@ nuts2: /* Stat calls. */ +/* also used for: pp_lstat() */ + PP(pp_stat) { dSP; @@ -2990,11 +3015,14 @@ S_try_amagic_ftest(pTHX_ char chr) { } +/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() + * pp_ftrwrite() */ + PP(pp_ftrread) { I32 result; /* Not const, because things tweak this below. Not bool, because there's - no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ + no guarantee that OPpFT_ACCESS is <= CHAR_MAX */ #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) I32 use_access = PL_op->op_private & OPpFT_ACCESS; /* Giving some sort of initial value silences compilers. */ @@ -3107,6 +3135,9 @@ PP(pp_ftrread) FT_RETURNNO; } + +/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ + PP(pp_ftis) { I32 result; @@ -3158,6 +3189,11 @@ PP(pp_ftis) } } + +/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned() + * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock() + * pp_ftsuid() pp_ftsvtx() pp_ftzero() */ + PP(pp_ftrowned) { I32 result; @@ -3307,6 +3343,9 @@ PP(pp_fttty) FT_RETURNNO; } + +/* also used for: pp_ftbinary() */ + PP(pp_fttext) { I32 i; @@ -3434,7 +3473,6 @@ PP(pp_fttext) } /* now scan s to look for textiness */ - /* XXX ASCII dependent code */ #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ @@ -3442,43 +3480,53 @@ PP(pp_fttext) --len; #endif + assert(len); + if (! is_ascii_string((U8 *) s, len)) { + const U8 *ep; + + /* Here contains a non-ASCII. See if the entire string is UTF-8. But + * the buffer may end in a partial character, so consider it UTF-8 if + * the first non-UTF8 char is an ending partial */ + if (is_utf8_string_loc((U8 *) s, len, &ep) + || ep + UTF8SKIP(ep) > (U8 *) (s + len)) + { + if (PL_op->op_type == OP_FTTEXT) { + FT_RETURNYES; + } + else { + FT_RETURNNO; + } + } + } + + /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for + * things that wouldn't be in ASCII text or rich ASCII text. Count these + * in 'odd' */ for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ odd += len; break; } -#ifdef EBCDIC - else if (!(isPRINT(*s) || isSPACE(*s))) - odd++; -#else - else if (*s & 128) { #ifdef USE_LOCALE_CTYPE - if (IN_LC_RUNTIME(LC_CTYPE) && isALPHA_LC(*s)) + if (IN_LC_RUNTIME(LC_CTYPE)) { + if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { continue; + } + } + else #endif - /* utf8 characters don't count as odd */ - if (UTF8_IS_START(*s)) { - int ulen = UTF8SKIP(s); - if (ulen < len - i) { - int j; - for (j = 1; j < ulen; j++) { - if (!UTF8_IS_CONTINUATION(s[j])) - goto not_utf8; - } - --ulen; /* loop does extra increment */ - s += ulen; - i += ulen; - continue; - } - } - not_utf8: - odd++; - } - else if (*s < 32 && - *s != '\n' && *s != '\r' && *s != '\b' && - *s != '\t' && *s != '\f' && *s != 27) - odd++; -#endif + if (isPRINT_A(*s) + /* VT occurs so rarely in text, that we consider it odd */ + || (isSPACE_A(*s) && *s != VT_NATIVE) + + /* But there is a fair amount of backspaces and escapes in + * some text */ + || *s == '\b' + || *s == ESC_NATIVE) + { + continue; + } + odd++; } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ @@ -3567,6 +3615,9 @@ PP(pp_chdir) RETURN; } + +/* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */ + PP(pp_chown) { dSP; dMARK; dTARGET; @@ -3615,6 +3666,9 @@ PP(pp_rename) RETURN; } + +/* also used for: pp_symlink() */ + #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { @@ -3657,6 +3711,9 @@ PP(pp_link) RETURN; } #else + +/* also used for: pp_symlink() */ + PP(pp_link) { /* Have neither. */ @@ -4501,6 +4558,9 @@ PP(pp_tms) /* Sun Dec 29 12:00:00 2147483647 */ #define TIME_UPPER_BOUND 67767976233316800.0 + +/* also used for: pp_localtime() */ + PP(pp_gmtime) { dSP; @@ -4561,16 +4621,14 @@ PP(pp_gmtime) if (err == NULL) RETPUSHUNDEF; else { - mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", + mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %"IVdf, dayname[tmbuf.tm_wday], monname[tmbuf.tm_mon], tmbuf.tm_mday, tmbuf.tm_hour, tmbuf.tm_min, tmbuf.tm_sec, - /* XXX newSVpvf()'s %lld type is broken, - * so cheat with a double */ - (double)tmbuf.tm_year + 1900)); + (IV)tmbuf.tm_year + 1900)); } } else { /* list context */ @@ -4630,6 +4688,8 @@ PP(pp_sleep) /* Shared memory. */ /* Merged with some message passing. */ +/* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */ + PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -4662,6 +4722,8 @@ PP(pp_shmwrite) /* Semaphores. */ +/* also used for: pp_msgget() pp_shmget() */ + PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -4677,6 +4739,8 @@ PP(pp_semget) #endif } +/* also used for: pp_msgctl() pp_shmctl() */ + PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -4722,6 +4786,8 @@ S_space_join_names_mortal(pTHX_ char *const *array) /* Get system info. */ +/* also used for: pp_ghbyaddr() pp_ghbyname() */ + PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) @@ -4812,6 +4878,8 @@ PP(pp_ghostent) #endif } +/* also used for: pp_gnbyaddr() pp_gnbyname() */ + PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) @@ -4885,6 +4953,9 @@ PP(pp_gnetent) #endif } + +/* also used for: pp_gpbyname() pp_gpbynumber() */ + PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) @@ -4945,6 +5016,9 @@ PP(pp_gprotoent) #endif } + +/* also used for: pp_gsbyname() pp_gsbyport() */ + PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) @@ -5010,6 +5084,9 @@ PP(pp_gservent) #endif } + +/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ + PP(pp_shostent) { dSP; @@ -5047,6 +5124,10 @@ PP(pp_shostent) RETSETYES; } + +/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() + * pp_eservent() pp_sgrent() pp_spwent() */ + PP(pp_ehostent) { dSP; @@ -5112,6 +5193,9 @@ PP(pp_ehostent) RETPUSHYES; } + +/* also used for: pp_gpwnam() pp_gpwuid() */ + PP(pp_gpwent) { #ifdef HAS_PASSWD @@ -5327,6 +5411,9 @@ PP(pp_gpwent) #endif } + +/* also used for: pp_ggrgid() pp_ggrnam() */ + PP(pp_ggrent) { #ifdef HAS_GROUP diff --git a/proto.h b/proto.h index 19ec194..d6d3a86 100644 --- a/proto.h +++ b/proto.h @@ -811,6 +811,11 @@ PERL_CALLCONV void Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckf #define PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER \ assert(cv); assert(ckfun_p); assert(ckobj_p) +PERL_CALLCONV SV * Perl_cv_name(pTHX_ CV *cv, SV *sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CV_NAME \ + assert(cv) + PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) @@ -818,11 +823,28 @@ PERL_CALLCONV void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfu #define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER \ assert(cv); assert(ckfun); assert(ckobj) +PERL_CALLCONV void Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj, U32 flags) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS \ + assert(cv); assert(ckfun); assert(ckobj) + PERL_CALLCONV void Perl_cv_undef(pTHX_ CV* cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CV_UNDEF \ assert(cv) +PERL_CALLCONV void Perl_cv_undef_flags(pTHX_ CV* cv, U32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CV_UNDEF_FLAGS \ + assert(cv) + +PERL_CALLCONV GV * Perl_cvgv_from_hek(pTHX_ CV* cv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_CVGV_FROM_HEK \ + assert(cv) + PERL_CALLCONV void Perl_cvgv_set(pTHX_ CV* cv, GV* gv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_CVGV_SET \ @@ -1308,6 +1330,12 @@ PERL_CALLCONV UV Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flag #define PERL_ARGS_ASSERT_GROK_HEX \ assert(start); assert(len_p); assert(flags) +PERL_CALLCONV int Perl_grok_infnan(const char** sp, const char *send) + __attribute__nonnull__(1) + __attribute__nonnull__(2); +#define PERL_ARGS_ASSERT_GROK_INFNAN \ + assert(sp); assert(send) + PERL_CALLCONV int Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_GROK_NUMBER \ @@ -2159,6 +2187,7 @@ PERL_CALLCONV bool Perl_is_utf8_xidfirst(pTHX_ const U8 *p) #define PERL_ARGS_ASSERT_IS_UTF8_XIDFIRST \ assert(p) +PERL_CALLCONV bool Perl_isinfnan(NV nv); PERL_CALLCONV OP* Perl_jmaybe(pTHX_ OP *o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_JMAYBE \ @@ -5307,6 +5336,11 @@ PERL_CALLCONV int Perl_my_sprintf(char *buffer, const char *pat, ...) assert(buffer); assert(pat) #endif +#if !defined(USE_QUADMATH) +# if defined(PERL_IN_NUMERIC_C) +STATIC NV S_mulexp10(NV value, I32 exponent); +# endif +#endif #if !defined(WIN32) PERL_CALLCONV bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) __attribute__nonnull__(pTHX_1); @@ -5349,6 +5383,9 @@ STATIC void S_cv_dump(pTHX_ const CV *cv, const char *title) # endif # if defined(PERL_IN_REGCOMP_C) +STATIC const char * S_cntrl_to_mnemonic(const U8 c) + __attribute__pure__; + STATIC void S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV* widecharmap, AV *revcharmap, U32 depth) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_3); @@ -5375,18 +5412,18 @@ STATIC const regnode* S_dumpuntil(pTHX_ const regexp *r, const regnode *start, c #define PERL_ARGS_ASSERT_DUMPUNTIL \ assert(r); assert(start); assert(node); assert(sv) -STATIC void S_put_byte(pTHX_ SV* sv, int c) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_PUT_BYTE \ - assert(sv) - -STATIC bool S_put_latin1_charclass_innards(pTHX_ SV* sv, char* bitmap) +STATIC bool S_put_charclass_bitmap_innards(pTHX_ SV* sv, char* bitmap, SV** bitmap_invlist) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS \ +#define PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS \ assert(sv); assert(bitmap) -STATIC void S_put_range(pTHX_ SV* sv, UV start, UV end) +STATIC void S_put_code_point(pTHX_ SV* sv, UV c) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_PUT_CODE_POINT \ + assert(sv) + +STATIC void S_put_range(pTHX_ SV* sv, UV start, const UV end, const bool allow_literals) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_PUT_RANGE \ assert(sv) @@ -5900,6 +5937,12 @@ STATIC void S_gv_magicalize_isa(pTHX_ GV *gv) #define PERL_ARGS_ASSERT_GV_MAGICALIZE_ISA \ assert(gv) +PERL_STATIC_INLINE HV* S_gv_stashpvn_internal(pTHX_ const char* name, U32 namelen, I32 flags) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_GV_STASHPVN_INTERNAL \ + assert(name) + +PERL_STATIC_INLINE HV* S_gv_stashsvpvn_cached(pTHX_ SV *namesv, const char* name, U32 namelen, I32 flags); STATIC void S_maybe_multimagic_gv(pTHX_ GV *gv, const char *name, const svtype sv_type) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); @@ -6082,9 +6125,6 @@ STATIC AV* S_mro_get_linear_isa_dfs(pTHX_ HV* stash, U32 level) assert(stash) #endif -#if defined(PERL_IN_NUMERIC_C) -STATIC NV S_mulexp10(NV value, I32 exponent); -#endif #if defined(PERL_IN_OP_C) PERL_STATIC_INLINE bool S_aassign_common_vars(pTHX_ OP* o); STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) @@ -6153,11 +6193,6 @@ STATIC void S_forget_pmop(pTHX_ PMOP *const o) assert(o) STATIC OP* S_gen_constant_list(pTHX_ OP* o); -STATIC SV* S_gv_ename(pTHX_ GV *gv) - __attribute__nonnull__(pTHX_1); -#define PERL_ARGS_ASSERT_GV_ENAME \ - assert(gv) - STATIC void S_inplace_aassign(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INPLACE_AASSIGN \ @@ -6239,7 +6274,7 @@ STATIC OP* S_pmtrans(pTHX_ OP* o, OP* expr, OP* repl) #define PERL_ARGS_ASSERT_PMTRANS \ assert(o); assert(expr); assert(repl) -STATIC void S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) +STATIC bool S_process_special_blocks(pTHX_ I32 floor, const char *const fullname, GV *const gv, CV *const cv) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3) __attribute__nonnull__(pTHX_4); @@ -6276,26 +6311,12 @@ STATIC OP* S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) #define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV \ assert(o); assert(name) -STATIC OP* S_too_few_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags) - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV \ - assert(o); assert(namesv) - STATIC OP* S_too_many_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_PV \ assert(o); assert(name) -STATIC OP* S_too_many_arguments_sv(pTHX_ OP *o, SV* namesv, U32 flags) - __attribute__warn_unused_result__ - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); -#define PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV \ - assert(o); assert(namesv) - #endif #if defined(PERL_IN_OP_C) || defined(PERL_IN_SV_C) PERL_CALLCONV void Perl_report_redefined_cv(pTHX_ const SV *name, const CV *old_cv, SV * const *new_const_svp) @@ -6406,13 +6427,6 @@ PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, co #endif #if defined(PERL_IN_PP_CTL_C) -STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2) - __attribute__nonnull__(pTHX_3); -#define PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE \ - assert(newsp); assert(sp); assert(mark) - STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -6467,6 +6481,13 @@ STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT* cxstk, I32 startingblock) STATIC I32 S_dopoptowhen(pTHX_ I32 startingblock) __attribute__warn_unused_result__; +STATIC SV ** S_leave_common(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags, bool lvalue) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_LEAVE_COMMON \ + assert(newsp); assert(sp); assert(mark) + STATIC PMOP* S_make_matcher(pTHX_ REGEXP* re) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); @@ -6713,6 +6734,11 @@ STATIC U32 S_add_data(RExC_state_t* const pRExC_state, const char* const s, cons #define PERL_ARGS_ASSERT_ADD_DATA \ assert(pRExC_state); assert(s) +STATIC AV* S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_ADD_MULTI_MATCH \ + assert(multi_string) + PERL_STATIC_INLINE void S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, regnode *node, I32 *flagp, STRLEN len, UV code_point, bool downgradable) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2) @@ -6754,7 +6780,7 @@ PERL_STATIC_INLINE IV* S_get_invlist_previous_index_addr(SV* invlist) #define PERL_ARGS_ASSERT_GET_INVLIST_PREVIOUS_INDEX_ADDR \ assert(invlist) -STATIC bool S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** nodep, UV *valuep, I32 *flagp, U32 depth, bool in_char_class, const bool strict) +STATIC STRLEN S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** nodep, UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_4); #define PERL_ARGS_ASSERT_GROK_BSLASH_N \ @@ -7080,7 +7106,7 @@ PERL_CALLCONV SV* Perl__new_invlist_C_array(pTHX_ const UV* const list) #endif #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) -PERL_CALLCONV SV* Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **lonly_utf8_locale) +PERL_CALLCONV SV* Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, const struct regnode *node, bool doinit, SV **listsvp, SV **lonly_utf8_locale, SV *exclude_list) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA \ assert(node) @@ -7584,7 +7610,7 @@ STATIC void S_incline(pTHX_ const char *s) #define PERL_ARGS_ASSERT_INCLINE \ assert(s) -STATIC int S_intuit_method(pTHX_ char *s, GV *gv, CV *cv) +STATIC int S_intuit_method(pTHX_ char *s, SV *ioname, CV *cv) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_INTUIT_METHOD \ assert(s) @@ -8044,6 +8070,18 @@ PERL_CALLCONV SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_ assert(vbuf) #endif +#if defined(USE_QUADMATH) +PERL_CALLCONV bool Perl_quadmath_format_needed(const char* format) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED \ + assert(format) + +PERL_CALLCONV const char* Perl_quadmath_format_single(const char* format) + __attribute__nonnull__(1); +#define PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE \ + assert(format) + +#endif #if defined(WIN32) PERL_CALLCONV char* Perl_my_setlocale(pTHX_ int category, const char* locale) __attribute__pure__; diff --git a/regcomp.c b/regcomp.c index 991d2f8..be9c184 100644 --- a/regcomp.c +++ b/regcomp.c @@ -377,24 +377,6 @@ typedef struct scan_data_t { regnode_ssc *start_class; } scan_data_t; -/* The below is perhaps overboard, but this allows us to save a test at the - * expense of a mask. This is because on both EBCDIC and ASCII machines, 'A' - * and 'a' differ by a single bit; the same with the upper and lower case of - * all other ASCII-range alphabetics. On ASCII platforms, they are 32 apart; - * on EBCDIC, they are 64. This uses an exclusive 'or' to find that bit and - * then inverts it to form a mask, with just a single 0, in the bit position - * where the upper- and lowercase differ. XXX There are about 40 other - * instances in the Perl core where this micro-optimization could be used. - * Should decide if maintenance cost is worse, before changing those - * - * Returns a boolean as to whether or not 'v' is either a lowercase or - * uppercase instance of 'c', where 'c' is in [A-Za-z]. If 'c' is a - * compile-time constant, the generated code is better than some optimizing - * compilers figure out, amounting to a mask and test. The results are - * meaningless if 'c' is not one of [A-Za-z] */ -#define isARG2_lower_or_UPPER_ARG1(c, v) \ - (((v) & ~('A' ^ 'a')) == ((c) & ~('A' ^ 'a'))) - /* * Forward declarations for pregcomp()'s friends. */ @@ -588,80 +570,85 @@ static const scan_data_t zero_scan_data = REPORT_LOCATION_ARGS(offset)); \ } STMT_END +/* These have asserts in them because of [perl #122671] Many warnings in + * regcomp.c can occur twice. If they get output in pass1 and later in that + * pass, the pattern has to be converted to UTF-8 and the pass restarted, they + * would get output again. So they should be output in pass2, and these + * asserts make sure new warnings follow that paradigm. */ /* m is not necessarily a "literal string", in this macro */ #define reg_warn_non_literal_string(loc, m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \ m, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNreg(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN_dep(loc, m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), \ m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARNregdep(loc,m) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \ m REPORT_LOCATION, \ REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN2reg_d(loc,m, a1) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ + __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP), \ m REPORT_LOCATION, \ a1, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN2reg(loc, m, a1) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN3(loc, m, a1, a2) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN3reg(loc, m, a1, a2) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN4(loc, m, a1, a2, a3) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, REPORT_LOCATION_ARGS(offset)); \ } STMT_END #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \ const IV offset = loc - RExC_precomp; \ - Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ + __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \ a1, a2, a3, a4, REPORT_LOCATION_ARGS(offset)); \ } STMT_END @@ -818,6 +805,33 @@ DEBUG_OPTIMISE_MORE_r(if(data){ \ PerlIO_printf(Perl_debug_log,"\n"); \ }); +#ifdef DEBUGGING + +/* is c a control character for which we have a mnemonic? */ +#define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c) + +STATIC const char * +S_cntrl_to_mnemonic(const U8 c) +{ + /* Returns the mnemonic string that represents character 'c', if one + * exists; NULL otherwise. The only ones that exist for the purposes of + * this routine are a few control characters */ + + switch (c) { + case '\a': return "\\a"; + case '\b': return "\\b"; + case ESC_NATIVE: return "\\e"; + case '\f': return "\\f"; + case '\n': return "\\n"; + case '\r': return "\\r"; + case '\t': return "\\t"; + } + + return NULL; +} + +#endif + /* Mark that we cannot extend a found fixed substring at this point. Update the longest found anchored substring and the longest found floating substrings if needed. */ @@ -891,7 +905,7 @@ S_ssc_anything(pTHX_ regnode_ssc *ssc) ssc->invlist = sv_2mortal(_new_invlist(2)); /* mortalize so won't leak */ _append_range_to_invlist(ssc->invlist, 0, UV_MAX); - ANYOF_FLAGS(ssc) |= ANYOF_EMPTY_STRING; /* Plus match empty string */ + ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING; /* Plus matches empty */ } STATIC int @@ -909,7 +923,7 @@ S_ssc_is_anything(const regnode_ssc *ssc) assert(is_ANYOF_SYNTHETIC(ssc)); - if (! (ANYOF_FLAGS(ssc) & ANYOF_EMPTY_STRING)) { + if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) { return FALSE; } @@ -948,7 +962,7 @@ S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc) Zero(ssc, 1, regnode_ssc); set_ANYOF_SYNTHETIC(ssc); - ARG_SET(ssc, ANYOF_NONBITMAP_EMPTY); + ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP); ssc_anything(ssc); /* If any portion of the regex is to operate under locale rules, @@ -1018,7 +1032,7 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC; /* Look at the data structure created by S_set_ANYOF_arg() */ - if (n != ANYOF_NONBITMAP_EMPTY) { + if (n != ANYOF_ONLY_HAS_BITMAP) { SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]); AV * const av = MUTABLE_AV(SvRV(rv)); SV **const ary = AvARRAY(av); @@ -1048,15 +1062,16 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, } } - /* An ANYOF node contains a bitmap for the first 256 code points, and an - * inversion list for the others, but if there are code points that should - * match only conditionally on the target string being UTF-8, those are - * placed in the inversion list, and not the bitmap. Since there are - * circumstances under which they could match, they are included in the - * SSC. But if the ANYOF node is to be inverted, we have to exclude them - * here, so that when we invert below, the end result actually does include - * them. (Think about "\xe0" =~ /[^\xc0]/di;). We have to do this here - * before we add the unconditionally matched code points */ + /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS + * code points, and an inversion list for the others, but if there are code + * points that should match only conditionally on the target string being + * UTF-8, those are placed in the inversion list, and not the bitmap. + * Since there are circumstances under which they could match, they are + * included in the SSC. But if the ANYOF node is to be inverted, we have + * to exclude them here, so that when we invert below, the end result + * actually does include them. (Think about "\xe0" =~ /[^\xc0]/di;). We + * have to do this here before we add the unconditionally matched code + * points */ if (ANYOF_FLAGS(node) & ANYOF_INVERT) { _invlist_intersection_complement_2nd(invlist, PL_UpperLatin1, @@ -1064,7 +1079,7 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, } /* Add in the points from the bit map */ - for (i = 0; i < 256; i++) { + for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) { if (ANYOF_BITMAP_TEST(node, i)) { invlist = add_cp_to_invlist(invlist, i); new_node_has_latin1 = TRUE; @@ -1073,13 +1088,13 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, /* If this can match all upper Latin1 code points, have to add them * as well */ - if (ANYOF_FLAGS(node) & ANYOF_NON_UTF8_NON_ASCII_ALL) { + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) { _invlist_union(invlist, PL_UpperLatin1, &invlist); } /* Similarly for these */ - if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) { - invlist = _add_range_to_invlist(invlist, 256, UV_MAX); + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { + _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist); } if (ANYOF_FLAGS(node) & ANYOF_INVERT) { @@ -1112,8 +1127,8 @@ S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state, #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX) /* 'AND' a given class with another one. Can create false positives. 'ssc' - * should not be inverted. 'and_with->flags & ANYOF_POSIXL' should be 0 if - * 'and_with' is a regnode_charclass instead of a regnode_ssc. */ + * should not be inverted. 'and_with->flags & ANYOF_MATCHES_POSIXL' should be + * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */ STATIC void S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, @@ -1204,7 +1219,7 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, /* If either P1 or P2 is empty, the intersection will be also; can skip * the loop */ - if (! (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) { + if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) { ANYOF_POSIXL_ZERO(ssc); } else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { @@ -1263,16 +1278,16 @@ S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, else { ssc->invlist = anded_cp_list; ANYOF_POSIXL_ZERO(ssc); - if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) { + if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc); } } } else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc) - || (ANYOF_FLAGS(and_with) & ANYOF_POSIXL)) + || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) { /* One or the other of P1, P2 is non-empty. */ - if (ANYOF_FLAGS(and_with) & ANYOF_POSIXL) { + if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc); } ssc_union(ssc, anded_cp_list, FALSE); @@ -1334,7 +1349,7 @@ S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc, { /* We ignore P2, leaving P1 going forward */ } /* else Not inverted */ - else if (ANYOF_FLAGS(or_with) & ANYOF_POSIXL) { + else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) { ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc); if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { unsigned int i; @@ -1428,7 +1443,8 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) { /* The inversion list in the SSC is marked mortal; now we need a more * permanent copy, which is stored the same way that is done in a regular - * ANYOF node, with the first 256 code points in a bit map */ + * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit + * map */ SV* invlist = invlist_clone(ssc->invlist); @@ -1437,8 +1453,8 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) assert(is_ANYOF_SYNTHETIC(ssc)); /* The code in this file assumes that all but these flags aren't relevant - * to the SSC, except ANYOF_EMPTY_STRING, which should be cleared by the - * time we reach here */ + * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared + * by the time we reach here */ assert(! (ANYOF_FLAGS(ssc) & ~ANYOF_COMMON_FLAGS)); populate_ANYOF_from_invlist( (regnode *) ssc, &invlist); @@ -1450,7 +1466,7 @@ S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc) ssc->invlist = NULL; if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) { - ANYOF_FLAGS(ssc) |= ANYOF_POSIXL; + ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL; } assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale); @@ -3516,8 +3532,8 @@ S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, } if (len == 2 - && isARG2_lower_or_UPPER_ARG1('s', *s) - && isARG2_lower_or_UPPER_ARG1('s', *(s+1))) + && isALPHA_FOLD_EQ(*s, 's') + && isALPHA_FOLD_EQ(*(s+1), 's')) { /* EXACTF nodes need to know that the minimum length @@ -4251,7 +4267,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, * can't match null string */ if (flags & SCF_DO_STCLASS_AND) { ssc_cp_and(data->start_class, uc); - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ssc_clear_locale(data->start_class); } else if (flags & SCF_DO_STCLASS_OR) { @@ -4259,7 +4275,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; } @@ -4434,7 +4450,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, } } if (flags & SCF_DO_STCLASS_AND) { - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; ANYOF_POSIXL_ZERO(data->start_class); ssc_intersection(data->start_class, EXACTF_invlist, FALSE); } @@ -4443,7 +4459,7 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, ssc_and(pRExC_state, data->start_class, (regnode_charclass *) and_withp); /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; SvREFCNT_dec(EXACTF_invlist); @@ -4562,7 +4578,8 @@ S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, flags &= ~SCF_DO_STCLASS_AND; StructCopy(&this_class, data->start_class, regnode_ssc); flags |= SCF_DO_STCLASS_OR; - ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + |= SSC_MATCHES_EMPTY_STRING; } } else { /* Non-zero len */ if (flags & SCF_DO_STCLASS_OR) { @@ -4858,7 +4875,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", ssc_intersection(data->start_class, PL_XPosix_ptrs[_CC_VERTSPACE], FALSE); ssc_clear_locale(data->start_class); - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + &= ~SSC_MATCHES_EMPTY_STRING; } else if (flags & SCF_DO_STCLASS_OR) { ssc_union(data->start_class, @@ -4868,7 +4886,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", /* See commit msg for * 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + &= ~SSC_MATCHES_EMPTY_STRING; } flags &= ~SCF_DO_STCLASS; } @@ -4895,7 +4914,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", U8 namedclass; /* See commit msg 749e076fceedeb708a624933726e7989f2302f6a */ - ANYOF_FLAGS(data->start_class) &= ~ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) &= ~SSC_MATCHES_EMPTY_STRING; /* Some of the logic below assumes that switching locale on will only add false positives. */ @@ -5136,7 +5155,8 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", * assertions are zero-length, so can match an EMPTY * string */ ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); - ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) + |= SSC_MATCHES_EMPTY_STRING; } } } @@ -5208,7 +5228,7 @@ PerlIO_printf(Perl_debug_log, "LHS=%"UVuf" RHS=%"UVuf"\n", if (f & SCF_DO_STCLASS_AND) { ssc_and(pRExC_state, data->start_class, (regnode_charclass *) &intrnl); - ANYOF_FLAGS(data->start_class) |= ANYOF_EMPTY_STRING; + ANYOF_FLAGS(data->start_class) |= SSC_MATCHES_EMPTY_STRING; } if (data) { if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR)) @@ -5650,9 +5670,9 @@ S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, char **pat_p, STRLEN *plen_p, int num_code_blocks) { U8 *const src = (U8*)*pat_p; - U8 *dst; + U8 *dst, *d; int n=0; - STRLEN s = 0, d = 0; + STRLEN s = 0; bool do_end = 0; GET_RE_DEBUG_FLAGS_DECL; @@ -5660,32 +5680,27 @@ S_pat_upgrade_to_utf8(pTHX_ RExC_state_t * const pRExC_state, "UTF8 mismatch! Converting to utf8 for resizing and compile\n")); Newx(dst, *plen_p * 2 + 1, U8); + d = dst; while (s < *plen_p) { - if (NATIVE_BYTE_IS_INVARIANT(src[s])) - dst[d] = src[s]; - else { - dst[d++] = UTF8_EIGHT_BIT_HI(src[s]); - dst[d] = UTF8_EIGHT_BIT_LO(src[s]); - } + append_utf8_from_native_byte(src[s], &d); if (n < num_code_blocks) { if (!do_end && pRExC_state->code_blocks[n].start == s) { - pRExC_state->code_blocks[n].start = d; - assert(dst[d] == '('); + pRExC_state->code_blocks[n].start = d - dst - 1; + assert(*(d - 1) == '('); do_end = 1; } else if (do_end && pRExC_state->code_blocks[n].end == s) { - pRExC_state->code_blocks[n].end = d; - assert(dst[d] == ')'); + pRExC_state->code_blocks[n].end = d - dst - 1; + assert(*(d - 1) == ')'); do_end = 0; n++; } } s++; - d++; } - dst[d] = '\0'; - *plen_p = d; + *d = '\0'; + *plen_p = d - dst; *pat_p = (char*) dst; SAVEFREEPV(*pat_p); RExC_orig_utf8 = RExC_utf8 = 1; @@ -6039,7 +6054,6 @@ S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state, ENTER; SAVETMPS; - save_re_context(); PUSHSTACKi(PERLSI_REQUIRE); /* G_RE_REPARSING causes the toker to collapse \\ into \ when * parsing qr''; normally only q'' does this. It also alters @@ -6288,6 +6302,13 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, PL_utf8_foldable = _new_invlist_C_array(_Perl_Any_Folds_invlist); PL_HasMultiCharFold = _new_invlist_C_array(_Perl_Folds_To_Multi_Char_invlist); + + /* This is calculated here, because the Perl program that generates the + * static global ones doesn't currently have access to + * NUM_ANYOF_CODE_POINTS */ + PL_InBitmap = _new_invlist(2); + PL_InBitmap = _add_range_to_invlist(PL_InBitmap, 0, + NUM_ANYOF_CODE_POINTS - 1); } #endif @@ -6850,9 +6871,7 @@ reStudy: else if (PL_regkind[OP(first)] == BOL) { r->intflags |= (OP(first) == MBOL ? PREGf_ANCH_MBOL - : (OP(first) == SBOL - ? PREGf_ANCH_SBOL - : PREGf_ANCH_BOL)); + : PREGf_ANCH_SBOL); first = NEXTOPER(first); goto again; } @@ -7005,7 +7024,7 @@ reStudy: if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset) && stclass_flag - && ! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING) + && ! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) && !ssc_is_anything(data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7085,7 +7104,7 @@ reStudy: r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8 = r->float_substr = r->float_utf8 = NULL; - if (! (ANYOF_FLAGS(data.start_class) & ANYOF_EMPTY_STRING) + if (! (ANYOF_FLAGS(data.start_class) & SSC_MATCHES_EMPTY_STRING) && ! ssc_is_anything(data.start_class)) { const U32 n = add_data(pRExC_state, STR_WITH_LEN("f")); @@ -7118,8 +7137,8 @@ reStudy: /* Guard against an embedded (?=) or (?<=) with a longer minlen than the "real" pattern. */ DEBUG_OPTIMISE_r({ - PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%ld\n", - (IV)minlen, (IV)r->minlen, RExC_maxlen); + PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf" maxlen:%"IVdf"\n", + (IV)minlen, (IV)r->minlen, (IV)RExC_maxlen); }); r->minlenret = minlen; if (r->minlen < minlen) @@ -7169,7 +7188,12 @@ reStudy: if (PL_regkind[fop] == NOTHING && nop == END) r->extflags |= RXf_NULL; - else if (PL_regkind[fop] == BOL && nop == END) + else if ((fop == MBOL || (fop == SBOL && !first->flags)) && nop == END) + /* when fop is SBOL first->flags will be true only when it was + * produced by parsing /\A/, and not when parsing /^/. This is + * very important for the split code as there we want to + * treat /^/ as /^/m, but we do not want to treat /\A/ as /^/m. + * See rt #122761 for more details. -- Yves */ r->extflags |= RXf_START_ONLY; else if (fop == PLUS && PL_regkind[nop] == POSIXD && FLAGS(next) == _CC_SPACE @@ -9358,7 +9382,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) /*NOTREACHED*/ case ONCE_PAT_MOD: /* 'o' */ case GLOBAL_PAT_MOD: /* 'g' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + if (PASS2 && ckWARN(WARN_REGEXP)) { const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G; @@ -9378,7 +9402,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) break; case CONTINUE_PAT_MOD: /* 'c' */ - if (SIZE_ONLY && ckWARN(WARN_REGEXP)) { + if (PASS2 && ckWARN(WARN_REGEXP)) { if (! (wastedflags & WASTED_C) ) { wastedflags |= WASTED_GC; /* diag_listed_as: Useless (?-%s) - don't use /%s modifier in regex; marked by <-- HERE in m/%s/ */ @@ -9393,7 +9417,7 @@ S_parse_lparen_question_flags(pTHX_ RExC_state_t *pRExC_state) break; case KEEPCOPY_PAT_MOD: /* 'p' */ if (flagsp == &negflags) { - if (SIZE_ONLY) + if (PASS2) ckWARNreg(RExC_parse + 1,"Useless use of (?-p)"); } else { *flagsp |= RXf_PMf_KEEPCOPY; @@ -10525,7 +10549,6 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) if (max < min) { /* If can't match, warn and optimize to fail unconditionally */ if (SIZE_ONLY) { - ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); /* We can't back off the size because we have to reserve * enough space for all the things we are about to throw @@ -10534,6 +10557,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) RExC_size = PREVOPER(RExC_size) - regarglen[(U8)OPFAIL]; } else { + ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); RExC_emit = orig_emit; } ret = reg_node(pRExC_state, OPFAIL); @@ -10543,7 +10567,7 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) && RExC_parse < RExC_end && (*RExC_parse == '?' || *RExC_parse == '+')) { - if (SIZE_ONLY) { + if (PASS2) { ckWARN2reg(RExC_parse + 1, "Useless use of greediness modifier '%c'", *RExC_parse); @@ -10689,10 +10713,9 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) return(ret); } -STATIC bool +STATIC STRLEN S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, - UV *valuep, I32 *flagp, U32 depth, bool in_char_class, - const bool strict /* Apply stricter parsing rules? */ + UV *valuep, I32 *flagp, U32 depth, SV** substitute_parse ) { @@ -10700,46 +10723,75 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, and needs to handle the rest. RExC_parse is expected to point at the first char following the N at the time of the call. On successful return, RExC_parse has been updated to point to just after the sequence identified - by this routine, and <*flagp> has been updated. - - The \N may be inside (indicated by the boolean ) or outside a - character class. - - \N may begin either a named sequence, or if outside a character class, mean - to match a non-newline. For non single-quoted regexes, the tokenizer has - attempted to decide which, and in the case of a named sequence, converted it + by this routine, <*flagp> has been updated, and the non-NULL input pointers + have been set appropriately. + + The typical case for this is \N{some character name}. This is usually + called while parsing the input, filling in or ready to fill in an EXACTish + node, and the code point for the character should be returned, so that it + can be added to the node, and parsing continued with the next input + character. But it may be that instead of a single character the \N{} + expands to more than one, a named sequence. In this case any following + quantifier applies to the whole sequence, and it is easier, given the code + structure that calls this, to handle it from a different area of the code. + For this reason, the input parameters can be set so that it returns valid + only on one or the other of these cases. + + Another possibility is for the input to be an empty \N{}, which for + backwards compatibility we accept, but generate a NOTHING node which should + later get optimized out. This is handled from the area of code which can + handle a named sequence, so if called with the parameters for the other, it + fails. + + Still another possibility is for the \N to mean [^\n], and not a single + character or explicit sequence at all. This is determined by context. + Again, this is handled from the area of code which can handle a named + sequence, so if called with the parameters for the other, it also fails. + + And the final possibility is for the \N to be called from within a bracketed + character class. In this case the [^\n] meaning makes no sense, and so is + an error. Other anomalous situations are left to the calling code to handle. + + For non-single-quoted regexes, the tokenizer has attempted to decide which + of the above applies, and in the case of a named sequence, has converted it into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...}, where c1... are the characters in the sequence. For single-quoted regexes, the tokenizer passes the \N sequence through unchanged; this code will not attempt to determine this nor expand those, instead raising a syntax error. The net effect is that if the beginning of the passed-in pattern isn't '{U+' or there is no '}', it signals that this \N occurrence means to match a - non-newline. + non-newline. (This mostly was done because of [perl #56444].) - Only the \N{U+...} form should occur in a character class, for the same - reason that '.' inside a character class means to just match a period: it - just doesn't make sense. + The API is somewhat convoluted due to historical and the above reasons. The function raises an error (via vFAIL), and doesn't return for various - syntax errors. Otherwise it returns TRUE and sets or on - success; it returns FALSE otherwise. Returns FALSE, setting *flagp to - RESTART_UTF8 if the sizing scan needs to be restarted. Such a restart is - only possible if node_p is non-NULL. - + syntax errors. For other failures, it returns (STRLEN) -1. For successes, + it returns a count of how many characters were accounted for by it. (This + can be 0 for \N{}; 1 for it meaning [^\n]; and otherwise the number of code + points in the sequence. It sets , , and/or + on success. If is non-null, it means the caller can accept an input sequence - consisting of a just a single code point; <*valuep> is set to that value - if the input is such. - - If is non-null it signifies that the caller can accept any other - legal sequence (i.e., one that isn't just a single code point). <*node_p> - is set as follows: - 1) \N means not-a-NL: points to a newly created REG_ANY node; - 2) \N{}: points to a new NOTHING node; + consisting of a just a single code point; <*valuep> is set to the value + of the only or first code point in the input. + + If is non-null, it means the caller can accept an input + sequence consisting of one or more code points; <*substitute_parse> is a + newly created mortal SV* in this case, containing \x{} escapes representing + those code points. + + Both and can be non-NULL. + + If is non-null, must be NULL. This signifies + that the caller can accept any legal sequence other than a single code + point. To wit, <*node_p> is set as follows: + 1) \N means not-a-NL: points to a newly created REG_ANY node; return is 1 + 2) \N{}: points to a new NOTHING node; return is 0 3) otherwise: points to a new EXACT node containing the resolved - string. - Note that FALSE is returned for single code point sequences if is - null. + string; return is the number of code points in the + string. This will never be 1. + Note that failure is returned for single code point sequences if is + null and is not. */ char * endbrace; /* '}' following the name */ @@ -10748,6 +10800,8 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, stream */ bool has_multiple_chars; /* true if the input stream contains a sequence of more than one character */ + bool in_char_class = substitute_parse != NULL; + STRLEN count = 0; /* Number of characters in this sequence */ GET_RE_DEBUG_FLAGS_DECL; @@ -10756,6 +10810,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, GET_RE_DEBUG_FLAGS; assert(cBOOL(node_p) ^ cBOOL(valuep)); /* Exactly one should be set */ + assert(! (node_p && substitute_parse)); /* At most 1 should be set */ /* The [^\n] meaning of \N ignores spaces and comments under the /x * modifier. The other meaning does not, so use a temporary until we find @@ -10774,7 +10829,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, if (in_char_class) { vFAIL("\\N in a character class must be a named character: \\N{...}"); } - return FALSE; + return (STRLEN) -1; } RExC_parse--; /* Need to back off so nextchar() doesn't skip the current char */ @@ -10783,7 +10838,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, *flagp |= HASWIDTH|SIMPLE; RExC_naughty++; Set_Node_Length(*node_p, 1); /* MJD */ - return TRUE; + return 1; } /* Here, we have decided it should be a named character or sequence */ @@ -10810,28 +10865,14 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, } if (endbrace == RExC_parse) { /* empty: \N{} */ - bool ret = TRUE; if (node_p) { *node_p = reg_node(pRExC_state,NOTHING); } - else if (in_char_class) { - if (SIZE_ONLY && in_char_class) { - if (strict) { - RExC_parse++; /* Position after the "}" */ - vFAIL("Zero length \\N{}"); - } - else { - ckWARNreg(RExC_parse, - "Ignoring zero length \\N{} in character class"); - } - } - ret = FALSE; - } - else { - return FALSE; + else if (! in_char_class) { + return (STRLEN) -1; } nextchar(pRExC_state); - return ret; + return 0; } RExC_uni_semantics = 1; /* Unicode named chars imply Unicode semantics */ @@ -10843,90 +10884,103 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, * point, and is terminated by the brace */ has_multiple_chars = (endchar < endbrace); - if (valuep && (! has_multiple_chars || in_char_class)) { - /* We only pay attention to the first char of - multichar strings being returned in char classes. I kinda wonder - if this makes sense as it does change the behaviour - from earlier versions, OTOH that behaviour was broken - as well. XXX Solution is to recharacterize as - [rest-of-class]|multi1|multi2... */ - + /* We get the first code point if we want it, and either there is only one, + * or we can accept both cases of one and more than one */ + if (valuep && (substitute_parse || ! has_multiple_chars)) { STRLEN length_of_hex = (STRLEN)(endchar - RExC_parse); I32 grok_hex_flags = PERL_SCAN_ALLOW_UNDERSCORES - | PERL_SCAN_DISALLOW_PREFIX - | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0); + | PERL_SCAN_DISALLOW_PREFIX + + /* No errors in the first pass (See [perl + * #122671].) We let the code below find the + * errors when there are multiple chars. */ + | ((SIZE_ONLY || has_multiple_chars) + ? PERL_SCAN_SILENT_ILLDIGIT + : 0); *valuep = grok_hex(RExC_parse, &length_of_hex, &grok_hex_flags, NULL); /* The tokenizer should have guaranteed validity, but it's possible to - * bypass it by using single quoting, so check */ - if (length_of_hex == 0 - || length_of_hex != (STRLEN)(endchar - RExC_parse) ) - { - RExC_parse += length_of_hex; /* Includes all the valid */ - RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */ - ? UTF8SKIP(RExC_parse) - : 1; - /* Guard against malformed utf8 */ - if (RExC_parse >= endchar) { - RExC_parse = endchar; + * bypass it by using single quoting, so check. Don't do the check + * here when there are multiple chars; we do it below anyway. */ + if (! has_multiple_chars) { + if (length_of_hex == 0 + || length_of_hex != (STRLEN)(endchar - RExC_parse) ) + { + RExC_parse += length_of_hex; /* Includes all the valid */ + RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */ + ? UTF8SKIP(RExC_parse) + : 1; + /* Guard against malformed utf8 */ + if (RExC_parse >= endchar) { + RExC_parse = endchar; + } + vFAIL("Invalid hexadecimal number in \\N{U+...}"); } - vFAIL("Invalid hexadecimal number in \\N{U+...}"); - } - if (in_char_class && has_multiple_chars) { - if (strict) { - RExC_parse = endbrace; - vFAIL("\\N{} in character class restricted to one character"); - } - else { - ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class"); - } + RExC_parse = endbrace + 1; + return 1; } - - RExC_parse = endbrace + 1; } - else if (! node_p || ! has_multiple_chars) { - /* Here, the input is legal, but not according to the caller's - * options. We fail without advancing the parse, so that the - * caller can try again */ + /* Here, we should have already handled the case where a single character + * is expected and found. So it is a failure if we aren't expecting + * multiple chars and got them; or didn't get them but wanted them. We + * fail without advancing the parse, so that the caller can try again with + * different acceptance criteria */ + if ((! node_p && ! substitute_parse) || ! has_multiple_chars) { RExC_parse = p; - return FALSE; + return (STRLEN) -1; } - else { + + { /* What is done here is to convert this to a sub-pattern of the form - * (?:\x{char1}\x{char2}...) - * and then call reg recursively. That way, it retains its atomicness, - * while not having to worry about special handling that some code - * points may have. toke.c has converted the original Unicode values - * to native, so that we can just pass on the hex values unchanged. We - * do have to set a flag to keep recoding from happening in the - * recursion */ - - SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP); + * \x{char1}\x{char2}... + * and then either return it in <*substitute_parse> if non-null; or + * call reg recursively to parse it (enclosing in "(?: ... )" ). That + * way, it retains its atomicness, while not having to worry about + * special handling that some code points may have. toke.c has + * converted the original Unicode values to native, so that we can just + * pass on the hex values unchanged. We do have to set a flag to keep + * recoding from happening in the recursion */ + + SV * dummy = NULL; STRLEN len; char *orig_end = RExC_end; I32 flags; + if (substitute_parse) { + *substitute_parse = newSVpvs(""); + } + else { + substitute_parse = &dummy; + *substitute_parse = newSVpvs("?:"); + } + *substitute_parse = sv_2mortal(*substitute_parse); + while (RExC_parse < endbrace) { /* Convert to notation the rest of the code understands */ - sv_catpv(substitute_parse, "\\x{"); - sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse); - sv_catpv(substitute_parse, "}"); + sv_catpv(*substitute_parse, "\\x{"); + sv_catpvn(*substitute_parse, RExC_parse, endchar - RExC_parse); + sv_catpv(*substitute_parse, "}"); /* Point to the beginning of the next character in the sequence. */ RExC_parse = endchar + 1; endchar = RExC_parse + strcspn(RExC_parse, ".}"); + + count++; } - sv_catpv(substitute_parse, ")"); + if (! in_char_class) { + sv_catpv(*substitute_parse, ")"); + } - RExC_parse = SvPV(substitute_parse, len); + RExC_parse = SvPV(*substitute_parse, len); /* Don't allow empty number */ - if (len < 8) { + if (len < (STRLEN) ((substitute_parse) ? 6 : 8)) { + RExC_parse = endbrace; vFAIL("Invalid hexadecimal number in \\N{U+...}"); } RExC_end = RExC_parse + len; @@ -10934,15 +10988,17 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, /* The values are Unicode, and therefore not subject to recoding */ RExC_override_recoding = 1; - if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) { - if (flags & RESTART_UTF8) { - *flagp = RESTART_UTF8; - return FALSE; + if (node_p) { + if (!(*node_p = reg(pRExC_state, 1, &flags, depth+1))) { + if (flags & RESTART_UTF8) { + *flagp = RESTART_UTF8; + return (STRLEN) -1; + } + FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", + (UV) flags); } - FAIL2("panic: reg returned NULL to grok_bslash_N, flags=%#"UVxf"", - (UV) flags); + *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); } - *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED); RExC_parse = endbrace; RExC_end = orig_end; @@ -10951,7 +11007,7 @@ S_grok_bslash_N(pTHX_ RExC_state_t *pRExC_state, regnode** node_p, nextchar(pRExC_state); } - return TRUE; + return count; } @@ -11057,15 +11113,21 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, if (LOC || ! FOLD) { /* /l defers folding until runtime */ *character = (U8) code_point; } - else { /* Here is /i and not /l (toFOLD() is defined on just + else { /* Here is /i and not /l. (toFOLD() is defined on just ASCII, which isn't the same thing as INVARIANT on EBCDIC, but it works there, as the extra invariants fold to themselves) */ *character = toFOLD((U8) code_point); - if (downgradable - && *character == code_point - && ! HAS_NONLATIN1_FOLD_CLOSURE(code_point)) - { + + /* We can downgrade to an EXACT node if this character + * isn't a folding one. Note that this assumes that + * nothing above Latin1 folds to some other invariant than + * one of these alphabetics; otherwise we would also have + * to check: + * && (! HAS_NONLATIN1_FOLD_CLOSURE(code_point) + * || ASCII_FOLD_RESTRICTED)) + */ + if (downgradable && PL_fold[code_point] == code_point) { OP(node) = EXACT; } } @@ -11082,7 +11144,10 @@ S_alloc_maybe_populate_EXACT(pTHX_ RExC_state_t *pRExC_state, ? FOLD_FLAGS_NOMIX_ASCII : 0)); if (downgradable - && folded == code_point + && folded == code_point /* This quickly rules out many + cases, avoiding the + _invlist_contains_cp() overhead + for those. */ && ! _invlist_contains_cp(PL_utf8_foldable, code_point)) { OP(node) = EXACT; @@ -11267,10 +11332,8 @@ tryagain: nextchar(pRExC_state); if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MBOL); - else if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SBOL); else - ret = reg_node(pRExC_state, BOL); + ret = reg_node(pRExC_state, SBOL); Set_Node_Length(ret, 1); /* MJD */ break; case '$': @@ -11279,10 +11342,8 @@ tryagain: RExC_seen_zerolen++; if (RExC_flags & RXf_PMf_MULTILINE) ret = reg_node(pRExC_state, MEOL); - else if (RExC_flags & RXf_PMf_SINGLELINE) - ret = reg_node(pRExC_state, SEOL); else - ret = reg_node(pRExC_state, EOL); + ret = reg_node(pRExC_state, SEOL); Set_Node_Length(ret, 1); /* MJD */ break; case '.': @@ -11371,6 +11432,11 @@ tryagain: case 'A': RExC_seen_zerolen++; ret = reg_node(pRExC_state, SBOL); + /* SBOL is shared with /^/ so we set the flags so we can tell + * /\A/ from /^/ in split. We check ret because first pass we + * have no regop struct to set the flags on. */ + if (PASS2) + ret->flags = 1; *flagp |= SIMPLE; goto finish_meta_pat; case 'G': @@ -11402,7 +11468,7 @@ tryagain: ret = reg_node(pRExC_state, CANY); RExC_seen |= REG_CANY_SEEN; *flagp |= HASWIDTH|SIMPLE; - if (SIZE_ONLY) { + if (PASS2) { ckWARNdep(RExC_parse+1, "\\C is deprecated"); } goto finish_meta_pat; @@ -11431,7 +11497,7 @@ tryagain: ret = reg_node(pRExC_state, op); FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; - if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { + if ((U8) *(RExC_parse + 1) == '{') { /* diag_listed_as: Use "%s" instead of "%s" */ vFAIL("Use \"\\b\\{\" instead of \"\\b{\""); } @@ -11449,7 +11515,7 @@ tryagain: ret = reg_node(pRExC_state, op); FLAGS(ret) = get_regex_charset(RExC_flags); *flagp |= SIMPLE; - if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') { + if ((U8) *(RExC_parse + 1) == '{') { /* diag_listed_as: Use "%s" instead of "%s" */ vFAIL("Use \"\\B\\{\" instead of \"\\B{\""); } @@ -11558,8 +11624,9 @@ tryagain: * special treatment for quantifiers is not needed for such single * character sequences */ ++RExC_parse; - if (! grok_bslash_N(pRExC_state, &ret, NULL, flagp, depth, FALSE, - FALSE /* not strict */ )) { + if ((STRLEN) -1 == grok_bslash_N(pRExC_state, &ret, NULL, flagp, + depth, FALSE)) + { if (*flagp & RESTART_UTF8) return NULL; RExC_parse--; @@ -11860,10 +11927,12 @@ tryagain: * point sequence. Handle those in the switch() above * */ RExC_parse = p + 1; - if (! grok_bslash_N(pRExC_state, NULL, &ender, - flagp, depth, FALSE, - FALSE /* not strict */ )) - { + if ((STRLEN) -1 == grok_bslash_N(pRExC_state, NULL, + &ender, + flagp, + depth, + FALSE + )) { if (*flagp & RESTART_UTF8) FAIL("panic: grok_bslash_N set RESTART_UTF8"); RExC_parse = p = oldp; @@ -11887,11 +11956,11 @@ tryagain: p++; break; case 'e': - ender = ASCII_TO_NATIVE('\033'); + ender = ESC_NATIVE; p++; break; case 'a': - ender = '\a'; + ender = '\a'; p++; break; case 'o': @@ -11902,7 +11971,7 @@ tryagain: bool valid = grok_bslash_o(&p, &result, &error_msg, - TRUE, /* out warnings */ + PASS2, /* out warnings */ FALSE, /* not strict */ TRUE, /* Output warnings for non- @@ -11931,7 +12000,7 @@ tryagain: bool valid = grok_bslash_x(&p, &result, &error_msg, - TRUE, /* out warnings */ + PASS2, /* out warnings */ FALSE, /* not strict */ TRUE, /* Output warnings for non- @@ -11954,7 +12023,7 @@ tryagain: } case 'c': p++; - ender = grok_bslash_c(*p++, SIZE_ONLY); + ender = grok_bslash_c(*p++, PASS2); break; case '8': case '9': /* must be a backreference */ --p; @@ -11993,7 +12062,7 @@ tryagain: REQUIRE_UTF8; } p += numlen; - if (SIZE_ONLY /* like \08, \178 */ + if (PASS2 /* like \08, \178 */ && numlen < 3 && p < RExC_end && isDIGIT(*p) && ckWARN(WARN_REGEXP)) @@ -12010,7 +12079,7 @@ tryagain: if (! RExC_override_recoding) { SV* enc = PL_encoding; ender = reg_recode((const char)(U8)ender, &enc); - if (!enc && SIZE_ONLY) + if (!enc && PASS2) ckWARNreg(p, "Invalid escape in the specified encoding"); REQUIRE_UTF8; } @@ -12127,9 +12196,8 @@ tryagain: && (PL_fold[ender] != PL_fold_latin1[ender] || ender == LATIN_SMALL_LETTER_SHARP_S || (len > 0 - && isARG2_lower_or_UPPER_ARG1('s', ender) - && isARG2_lower_or_UPPER_ARG1('s', - *(s-1))))) + && isALPHA_FOLD_EQ(ender, 's') + && isALPHA_FOLD_EQ(*(s-1), 's')))) { maybe_exactfu = FALSE; } @@ -12313,7 +12381,7 @@ tryagain: * as if it turns into an EXACTFU, it could later get * joined with another 's' that would then wrongly match * the sharp s */ - if (maybe_exactfu && isARG2_lower_or_UPPER_ARG1('s', ender)) + if (maybe_exactfu && isALPHA_FOLD_EQ(ender, 's')) { maybe_exactfu = FALSE; } @@ -12462,22 +12530,24 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) UV high; int i; - if (end == UV_MAX && start <= 256) { - ANYOF_FLAGS(node) |= ANYOF_ABOVE_LATIN1_ALL; + if (end == UV_MAX && start <= NUM_ANYOF_CODE_POINTS) { + ANYOF_FLAGS(node) |= ANYOF_MATCHES_ALL_ABOVE_BITMAP; } - else if (end >= 256) { - ANYOF_FLAGS(node) |= ANYOF_UTF8; + else if (end >= NUM_ANYOF_CODE_POINTS) { + ANYOF_FLAGS(node) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES; } /* Quit if are above what we should change */ - if (start > 255) { + if (start >= NUM_ANYOF_CODE_POINTS) { break; } change_invlist = TRUE; /* Set all the bits in the range, up to the max that we are doing */ - high = (end < 255) ? end : 255; + high = (end < NUM_ANYOF_CODE_POINTS - 1) + ? end + : NUM_ANYOF_CODE_POINTS - 1; for (i = start; i <= (int) high; i++) { if (! ANYOF_BITMAP_TEST(node, i)) { ANYOF_BITMAP_SET(node, i); @@ -12487,13 +12557,13 @@ S_populate_ANYOF_from_invlist(pTHX_ regnode *node, SV** invlist_ptr) invlist_iterfinish(*invlist_ptr); /* Done with loop; remove any code points that are in the bitmap from - * *invlist_ptr; similarly for code points above latin1 if we have a - * flag to match all of them anyways */ + * *invlist_ptr; similarly for code points above the bitmap if we have + * a flag to match all of them anyways */ if (change_invlist) { - _invlist_subtract(*invlist_ptr, PL_Latin1, invlist_ptr); + _invlist_subtract(*invlist_ptr, PL_InBitmap, invlist_ptr); } - if (ANYOF_FLAGS(node) & ANYOF_ABOVE_LATIN1_ALL) { - _invlist_intersection(*invlist_ptr, PL_Latin1, invlist_ptr); + if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) { + _invlist_intersection(*invlist_ptr, PL_InBitmap, invlist_ptr); } /* If have completely emptied it, remove it completely */ @@ -12743,9 +12813,7 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, * upon an unescaped ']' that isn't one ending a regclass. To do both * these things, we need to realize that something preceded by a backslash * is escaped, so we have to keep track of backslashes */ - if (SIZE_ONLY) { - UV depth = 0; /* how many nested (?[...]) constructs */ - + if (PASS2) { Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__REGEX_SETS), "The regex_sets feature is experimental" REPORT_LOCATION, @@ -12753,6 +12821,9 @@ S_handle_regex_sets(pTHX_ RExC_state_t *pRExC_state, SV** return_invlist, UTF8fARG(UTF, RExC_end - RExC_start - (RExC_parse - RExC_precomp), RExC_precomp + (RExC_parse - RExC_precomp))); + } + else { + UV depth = 0; /* how many nested (?[...]) constructs */ while (RExC_parse < RExC_end) { SV* current = NULL; @@ -13253,11 +13324,60 @@ S_add_above_Latin1_folds(pTHX_ RExC_state_t *pRExC_state, const U8 cp, SV** invl default: /* Use deprecated warning to increase the chances of this being * output */ - ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp); + if (PASS2) { + ckWARN2reg_d(RExC_parse, "Perl folding rules are not up-to-date for 0x%02X; please use the perlbug utility to report;", cp); + } break; } } +STATIC AV * +S_add_multi_match(pTHX_ AV* multi_char_matches, SV* multi_string, const STRLEN cp_count) +{ + /* This adds the string scalar to the array + * . is known to have exactly + * code points in it. This is used when constructing a + * bracketed character class and we find something that needs to match more + * than a single character. + * + * is actually an array of arrays. Each top-level + * element is an array that contains all the strings known so far that are + * the same length. And that length (in number of code points) is the same + * as the index of the top-level array. Hence, the [2] element is an + * array, each element thereof is a string containing TWO code points; + * while element [3] is for strings of THREE characters, and so on. Since + * this is for multi-char strings there can never be a [0] nor [1] element. + * + * When we rewrite the character class below, we will do so such that the + * longest strings are written first, so that it prefers the longest + * matching strings first. This is done even if it turns out that any + * quantifier is non-greedy, out of this programmer's (khw) laziness. Tom + * Christiansen has agreed that this is ok. This makes the test for the + * ligature 'ffi' come before the test for 'ff', for example */ + + AV* this_array; + AV** this_array_ptr; + + PERL_ARGS_ASSERT_ADD_MULTI_MATCH; + + if (! multi_char_matches) { + multi_char_matches = newAV(); + } + + if (av_exists(multi_char_matches, cp_count)) { + this_array_ptr = (AV**) av_fetch(multi_char_matches, cp_count, FALSE); + this_array = *this_array_ptr; + } + else { + this_array = newAV(); + av_store(multi_char_matches, cp_count, + (SV*) this_array); + } + av_push(this_array, multi_string); + + return multi_char_matches; +} + /* The names of properties whose definitions are not known at compile time are * stored in this SV, after a constant heading. So if the length has been * changed since initialization, then there is a run-time definition. */ @@ -13289,11 +13409,11 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, * ignored in the recursion by means of a flag: * .) * - * ANYOF nodes contain a bit map for the first 256 characters, with the - * corresponding bit set if that character is in the list. For characters - * above 255, a range list or swash is used. There are extra bits for \w, - * etc. in locale ANYOFs, as what these match is not determinable at - * compile time + * ANYOF nodes contain a bit map for the first NUM_ANYOF_CODE_POINTS + * characters, with the corresponding bit set if that character is in the + * list. For characters above this, a range list or swash is used. There + * are extra bits for \w, etc. in locale ANYOFs, as what these match is not + * determinable at compile time * * Returns NULL, setting *flagp to RESTART_UTF8 if the sizing scan needs * to be restarted. This can only happen if ret_invlist is non-NULL. @@ -13440,7 +13560,6 @@ S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth, if (UCHARAT(RExC_parse) == ']') goto charclassloop; -parseit: while (1) { if (RExC_parse >= stop_ptr) { break; @@ -13480,8 +13599,14 @@ parseit: { namedclass = regpposixcc(pRExC_state, value, strict); } - else if (value == '\\') { - if (UTF) { + else if (value != '\\') { +#ifdef EBCDIC + literal_endpoint++; +#endif + } + else { + /* Is a backslash; get the code point of the char after it */ + if (UTF && ! UTF8_IS_INVARIANT(RExC_parse)) { value = utf8n_to_uvchr((U8*)RExC_parse, RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT); @@ -13514,19 +13639,54 @@ parseit: case 'H': namedclass = ANYOF_NHORIZWS; break; case 'N': /* Handle \N{NAME} in class */ { - /* We only pay attention to the first char of - multichar strings being returned. I kinda wonder - if this makes sense as it does change the behaviour - from earlier versions, OTOH that behaviour was broken - as well. */ - if (! grok_bslash_N(pRExC_state, NULL, &value, flagp, depth, - TRUE, /* => charclass */ - strict)) - { - if (*flagp & RESTART_UTF8) - FAIL("panic: grok_bslash_N set RESTART_UTF8"); - goto parseit; + SV *as_text; + STRLEN cp_count = grok_bslash_N(pRExC_state, NULL, &value, + flagp, depth, &as_text); + if (*flagp & RESTART_UTF8) + FAIL("panic: grok_bslash_N set RESTART_UTF8"); + if (cp_count != 1) { /* The typical case drops through */ + assert(cp_count != (STRLEN) -1); + if (cp_count == 0) { + if (strict) { + RExC_parse++; /* Position after the "}" */ + vFAIL("Zero length \\N{}"); + } + else if (PASS2) { + ckWARNreg(RExC_parse, + "Ignoring zero length \\N{} in character class"); + } + } + else { /* cp_count > 1 */ + if (! RExC_in_multi_char_class) { + if (invert || range || *RExC_parse == '-') { + if (strict) { + RExC_parse--; + vFAIL("\\N{} in inverted character class or as a range end-point is restricted to one character"); + } + else if (PASS2) { + ckWARNreg(RExC_parse, "Using just the first character returned by \\N{} in character class"); + } + } + else { + multi_char_matches + = add_multi_match(multi_char_matches, + as_text, + cp_count); + } + break; /* contains the first code + point. Drop out of the switch to + process it */ + } + } /* End of cp_count != 1 */ + + /* This element should not be processed further in this + * class */ + element_count--; + value = save_value; + prevvalue = save_prevvalue; + continue; /* Back to top of loop to get next char */ } + /* Here, is a single code point, and contains it */ } break; case 'p': @@ -13649,7 +13809,8 @@ parseit: * inappropriately, except that any \p{}, including * this one forces Unicode semantics, which means there * is no */ - ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8; + ANYOF_FLAGS(ret) + |= ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES; } else { @@ -13705,7 +13866,7 @@ parseit: case 't': value = '\t'; break; case 'f': value = '\f'; break; case 'b': value = '\b'; break; - case 'e': value = ASCII_TO_NATIVE('\033');break; + case 'e': value = ESC_NATIVE; break; case 'a': value = '\a'; break; case 'o': RExC_parse--; /* function expects to be pointed at the 'o' */ @@ -13714,8 +13875,8 @@ parseit: bool valid = grok_bslash_o(&RExC_parse, &value, &error_msg, - SIZE_ONLY, /* warnings in pass - 1 only */ + PASS2, /* warnings only in + pass 2 */ strict, silence_non_portable, UTF); @@ -13734,7 +13895,7 @@ parseit: bool valid = grok_bslash_x(&RExC_parse, &value, &error_msg, - TRUE, /* Output warnings */ + PASS2, /* Output warnings */ strict, silence_non_portable, UTF); @@ -13746,7 +13907,7 @@ parseit: goto recode_encoding; break; case 'c': - value = grok_bslash_c(*RExC_parse++, SIZE_ONLY); + value = grok_bslash_c(*RExC_parse++, PASS2); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': @@ -13786,7 +13947,7 @@ parseit: if (strict) { vFAIL("Invalid escape in the specified encoding"); } - else if (SIZE_ONLY) { + else if (PASS2) { ckWARNreg(RExC_parse, "Invalid escape in the specified encoding"); } @@ -13811,10 +13972,6 @@ parseit: break; } /* End of switch on char following backslash */ } /* end of handling backslash escape sequences */ -#ifdef EBCDIC - else - literal_endpoint++; -#endif /* Here, we have the current token in 'value' */ @@ -13872,18 +14029,18 @@ parseit: else { RExC_emit += ANYOF_POSIXL_SKIP - ANYOF_SKIP; } - ANYOF_FLAGS(ret) |= ANYOF_POSIXL; + ANYOF_FLAGS(ret) |= ANYOF_MATCHES_POSIXL; ANYOF_POSIXL_ZERO(ret); } /* Coverity thinks it is possible for this to be negative; both * jhi and khw think it's not, but be safer */ - assert(! (ANYOF_FLAGS(ret) & ANYOF_POSIXL) + assert(! (ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL) || (namedclass + ((namedclass % 2) ? -1 : 1)) >= 0); /* See if it already matches the complement of this POSIX * class */ - if ((ANYOF_FLAGS(ret) & ANYOF_POSIXL) + if ((ANYOF_FLAGS(ret) & ANYOF_MATCHES_POSIXL) && ANYOF_POSIXL_TEST(ret, namedclass + ((namedclass % 2) ? -1 : 1))) @@ -13968,22 +14125,23 @@ parseit: namedclass % 2 != 0, posixes_ptr); } - continue; /* Go get next character */ } } /* end of namedclass \blah */ - /* Here, we have a single value. If 'range' is set, it is the ending - * of a range--check its validity. Later, we will handle each - * individual code point in the range. If 'range' isn't set, this - * could be the beginning of a range, so check for that by looking - * ahead to see if the next real character to be processed is the range - * indicator--the minus sign */ - if (skip_white) { RExC_parse = regpatws(pRExC_state, RExC_parse, FALSE /* means don't recognize comments */ ); } + /* If 'range' is set, 'value' is the ending of a range--check its + * validity. (If value isn't a single code point in the case of a + * range, we should have figured that out above in the code that + * catches false ranges). Later, we will handle each individual code + * point in the range. If 'range' isn't set, this could be the + * beginning of a range, so check for that by looking ahead to see if + * the next real character to be processed is the range indicator--the + * minus sign */ + if (range) { if (prevvalue > value) /* b-a */ { const int w = RExC_parse - rangebegin; @@ -14013,15 +14171,15 @@ parseit: /* a bad range like \w-, [:word:]- ? */ if (namedclass > OOB_NAMEDCLASS) { - if (strict || ckWARN(WARN_REGEXP)) { - const int w = - RExC_parse >= rangebegin ? - RExC_parse - rangebegin : 0; + if (strict || (PASS2 && ckWARN(WARN_REGEXP))) { + const int w = RExC_parse >= rangebegin + ? RExC_parse - rangebegin + : 0; if (strict) { vFAIL4("False [] range \"%*.*s\"", w, w, rangebegin); } - else { + else if (PASS2) { vWARN4(RExC_parse, "False [] range \"%*.*s\"", w, w, rangebegin); @@ -14038,8 +14196,12 @@ parseit: } } - /* Here, is the beginning of the range, if any; or - * if not */ + if (namedclass > OOB_NAMEDCLASS) { + continue; + } + + /* Here, we have a single value, and is the beginning of + * the range, if any; or if not */ /* non-Latin1 code point implies unicode semantics. Must be set in * pass1 so is there for the whole of pass 2 */ @@ -14087,44 +14249,17 @@ parseit: * again. Otherwise add this character to the list of * multi-char folds. */ if (! RExC_in_multi_char_class) { - AV** this_array_ptr; - AV* this_array; STRLEN cp_count = utf8_length(foldbuf, foldbuf + foldlen); SV* multi_fold = sv_2mortal(newSVpvs("")); Perl_sv_catpvf(aTHX_ multi_fold, "\\x{%"UVXf"}", value); + multi_char_matches + = add_multi_match(multi_char_matches, + multi_fold, + cp_count); - if (! multi_char_matches) { - multi_char_matches = newAV(); - } - - /* is actually an array of arrays. - * There will be one or two top-level elements: [2], - * and/or [3]. The [2] element is an array, each - * element thereof is a character which folds to TWO - * characters; [3] is for folds to THREE characters. - * (Unicode guarantees a maximum of 3 characters in any - * fold.) When we rewrite the character class below, - * we will do so such that the longest folds are - * written first, so that it prefers the longest - * matching strings first. This is done even if it - * turns out that any quantifier is non-greedy, out of - * programmer laziness. Tom Christiansen has agreed - * that this is ok. This makes the test for the - * ligature 'ffi' come before the test for 'ff' */ - if (av_exists(multi_char_matches, cp_count)) { - this_array_ptr = (AV**) av_fetch(multi_char_matches, - cp_count, FALSE); - this_array = *this_array_ptr; - } - else { - this_array = newAV(); - av_store(multi_char_matches, cp_count, - (SV*) this_array); - } - av_push(this_array, multi_fold); } /* This element should not be processed further in this @@ -14238,6 +14373,7 @@ parseit: RExC_parse = SvPV(substitute_parse, len); RExC_end = RExC_parse + len; RExC_in_multi_char_class = 1; + RExC_override_recoding = 1; RExC_emit = (regnode *)orig_emit; ret = reg(pRExC_state, 1, ®_flags, depth+1); @@ -14247,6 +14383,7 @@ parseit: RExC_parse = save_parse; RExC_end = save_end; RExC_in_multi_char_class = 0; + RExC_override_recoding = 0; SvREFCNT_dec_NN(multi_char_matches); return ret; } @@ -14605,7 +14742,7 @@ parseit: if (DEPENDS_SEMANTICS) { /* Under /d, everything in the upper half of the Latin1 range * matches these complements */ - ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_NON_ASCII_ALL; + ANYOF_FLAGS(ret) |= ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII; } else if (AT_LEAST_ASCII_RESTRICTED) { /* Under /a and /aa, everything above ASCII matches these @@ -14911,7 +15048,7 @@ parseit: else { cp_list = depends_list; } - ANYOF_FLAGS(ret) |= ANYOF_UTF8; + ANYOF_FLAGS(ret) |= ANYOF_HAS_UTF8_NONBITMAP_MATCHES; } /* If there is a swash and more than one element, we can't use the swash in @@ -14921,6 +15058,10 @@ parseit: swash = NULL; } + /* Note that the optimization of using 'swash' if it is the only thing in + * the class doesn't have us change swash at all, so it can include things + * that are also in the bitmap; otherwise we have purposely deleted that + * duplicate information */ set_ANYOF_arg(pRExC_state, ret, cp_list, (HAS_NONLOCALE_RUNTIME_PROPERTY_DEFINITION) ? listsv : NULL, @@ -14949,7 +15090,7 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, { /* Sets the arg field of an ANYOF-type node 'node', using information about * the node passed-in. If there is nothing outside the node's bitmap, the - * arg is set to ANYOF_NONBITMAP_EMPTY. Otherwise, it sets the argument to + * arg is set to ANYOF_ONLY_HAS_BITMAP. Otherwise, it sets the argument to * the count returned by add_data(), having allocated and stored an array, * av, that that count references, as follows: * av[0] stores the character class description in its textual form. @@ -14975,15 +15116,17 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, if (! cp_list && ! runtime_defns && ! only_utf8_locale_list) { assert(! (ANYOF_FLAGS(node) - & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8))); - ARG_SET(node, ANYOF_NONBITMAP_EMPTY); + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES))); + ARG_SET(node, ANYOF_ONLY_HAS_BITMAP); } else { AV * const av = newAV(); SV *rv; assert(ANYOF_FLAGS(node) - & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD)); + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD)); av_store(av, 0, (runtime_defns) ? SvREFCNT_inc(runtime_defns) : &PL_sv_undef); @@ -15014,6 +15157,135 @@ S_set_ANYOF_arg(pTHX_ RExC_state_t* const pRExC_state, } } +#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) +SV * +Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, + const regnode* node, + bool doinit, + SV** listsvp, + SV** only_utf8_locale_ptr, + SV* exclude_list) + +{ + /* For internal core use only. + * Returns the swash for the input 'node' in the regex 'prog'. + * If is 'true', will attempt to create the swash if not already + * done. + * If is non-null, will return the printable contents of the + * swash. This can be used to get debugging information even before the + * swash exists, by calling this function with 'doinit' set to false, in + * which case the components that will be used to eventually create the + * swash are returned (in a printable form). + * If is not NULL, it is an inversion list of things to + * exclude from what's returned in . + * Tied intimately to how S_set_ANYOF_arg sets up the data structure. Note + * that, in spite of this function's name, the swash it returns may include + * the bitmap data as well */ + + SV *sw = NULL; + SV *si = NULL; /* Input swash initialization string */ + SV* invlist = NULL; + + RXi_GET_DECL(prog,progi); + const struct reg_data * const data = prog ? progi->data : NULL; + + PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA; + + assert(ANYOF_FLAGS(node) + & (ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES|ANYOF_LOC_FOLD)); + + if (data && data->count) { + const U32 n = ARG(node); + + if (data->what[n] == 's') { + SV * const rv = MUTABLE_SV(data->data[n]); + AV * const av = MUTABLE_AV(SvRV(rv)); + SV **const ary = AvARRAY(av); + U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; + + si = *ary; /* ary[0] = the string to initialize the swash with */ + + /* Elements 3 and 4 are either both present or both absent. [3] is + * any inversion list generated at compile time; [4] indicates if + * that inversion list has any user-defined properties in it. */ + if (av_tindex(av) >= 2) { + if (only_utf8_locale_ptr + && ary[2] + && ary[2] != &PL_sv_undef) + { + *only_utf8_locale_ptr = ary[2]; + } + else { + assert(only_utf8_locale_ptr); + *only_utf8_locale_ptr = NULL; + } + + if (av_tindex(av) >= 3) { + invlist = ary[3]; + if (SvUV(ary[4])) { + swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY; + } + } + else { + invlist = NULL; + } + } + + /* Element [1] is reserved for the set-up swash. If already there, + * return it; if not, create it and store it there */ + if (ary[1] && SvROK(ary[1])) { + sw = ary[1]; + } + else if (doinit && ((si && si != &PL_sv_undef) + || (invlist && invlist != &PL_sv_undef))) { + assert(si); + sw = _core_swash_init("utf8", /* the utf8 package */ + "", /* nameless */ + si, + 1, /* binary */ + 0, /* not from tr/// */ + invlist, + &swash_init_flags); + (void)av_store(av, 1, sw); + } + } + } + + /* If requested, return a printable version of what this swash matches */ + if (listsvp) { + SV* matches_string = newSVpvs(""); + + /* The swash should be used, if possible, to get the data, as it + * contains the resolved data. But this function can be called at + * compile-time, before everything gets resolved, in which case we + * return the currently best available information, which is the string + * that will eventually be used to do that resolving, 'si' */ + if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL) + && (si && si != &PL_sv_undef)) + { + sv_catsv(matches_string, si); + } + + /* Add the inversion list to whatever we have. This may have come from + * the swash, or from an input parameter */ + if (invlist) { + if (exclude_list) { + SV* clone = invlist_clone(invlist); + _invlist_subtract(clone, exclude_list, &clone); + sv_catsv(matches_string, _invlist_contents(clone)); + SvREFCNT_dec_NN(clone); + } + else { + sv_catsv(matches_string, _invlist_contents(invlist)); + } + } + *listsvp = matches_string; + } + + return sw; +} +#endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */ /* reg_skipcomment() @@ -15582,8 +15854,6 @@ Perl_regdump(pTHX_ const regexp *r) } if (r->intflags & PREGf_ANCH) { PerlIO_printf(Perl_debug_log, "anchored"); - if (r->intflags & PREGf_ANCH_BOL) - PerlIO_printf(Perl_debug_log, "(BOL)"); if (r->intflags & PREGf_ANCH_MBOL) PerlIO_printf(Perl_debug_log, "(MBOL)"); if (r->intflags & PREGf_ANCH_SBOL) @@ -15723,9 +15993,11 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ ); if ( IS_ANYOF_TRIE(op) || trie->bitmap ) { sv_catpvs(sv, "["); - (void) put_latin1_charclass_innards(sv, IS_ANYOF_TRIE(op) - ? ANYOF_BITMAP(o) - : TRIE_BITMAP(trie)); + (void) put_charclass_bitmap_innards(sv, + (IS_ANYOF_TRIE(op)) + ? ANYOF_BITMAP(o) + : TRIE_BITMAP(trie), + NULL); sv_catpvs(sv, "]"); } @@ -15789,6 +16061,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ else if (k == ANYOF) { const U8 flags = ANYOF_FLAGS(o); int do_sep = 0; + SV* bitmap_invlist; /* Will hold what the bit map contains */ if (flags & ANYOF_LOCALE_FLAGS) @@ -15799,8 +16072,10 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (flags & ANYOF_INVERT) sv_catpvs(sv, "^"); - /* output what the standard cp 0-255 bitmap matches */ - do_sep = put_latin1_charclass_innards(sv, ANYOF_BITMAP(o)); + /* output what the standard cp 0-NUM_ANYOF_CODE_POINTS-1 bitmap matches + * */ + do_sep = put_charclass_bitmap_innards(sv, ANYOF_BITMAP(o), + &bitmap_invlist); /* output any special charclass tests (used entirely under use * locale) * */ @@ -15814,9 +16089,9 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } - if ((flags & (ANYOF_ABOVE_LATIN1_ALL - |ANYOF_UTF8 - |ANYOF_NONBITMAP_NON_UTF8 + if ((flags & (ANYOF_MATCHES_ALL_ABOVE_BITMAP + |ANYOF_HAS_UTF8_NONBITMAP_MATCHES + |ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES |ANYOF_LOC_FOLD))) { if (do_sep) { @@ -15826,22 +16101,25 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ sv_catpvs(sv, "^"); } - if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL) { + if (flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) { sv_catpvs(sv, "{non-utf8-latin1-all}"); } /* output information about the unicode matching */ - if (flags & ANYOF_ABOVE_LATIN1_ALL) - sv_catpvs(sv, "{unicode_all}"); - else if (ARG(o) != ANYOF_NONBITMAP_EMPTY) { + if (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP) + sv_catpvs(sv, "{above_bitmap_all}"); + else if (ARG(o) != ANYOF_ONLY_HAS_BITMAP) { SV *lv; /* Set if there is something outside the bit map. */ bool byte_output = FALSE; /* If something in the bitmap has been output */ SV *only_utf8_locale; - /* Get the stuff that wasn't in the bitmap */ + /* Get the stuff that wasn't in the bitmap. 'bitmap_invlist' + * is used to guarantee that nothing in the bitmap gets + * returned */ (void) _get_regclass_nonbitmap_data(prog, o, FALSE, - &lv, &only_utf8_locale); + &lv, &only_utf8_locale, + bitmap_invlist); if (lv && lv != &PL_sv_undef) { char *s = savesvpv(lv); char * const origs = s; @@ -15852,7 +16130,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ if (*s == '\n') { const char * const t = ++s; - if (flags & ANYOF_NONBITMAP_NON_UTF8) { + if (flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) { sv_catpvs(sv, "{outside bitmap}"); } else { @@ -15904,7 +16182,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ invlist_iterinit(only_utf8_locale); while (invlist_iternext(only_utf8_locale, &start, &end)) { - put_range(sv, start, end); + put_range(sv, start, end, FALSE); max_entries --; if (max_entries < 0) { sv_catpvs(sv, "..."); @@ -15915,6 +16193,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } } } + SvREFCNT_dec(bitmap_invlist); + Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]); } @@ -15935,6 +16215,8 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o, const regmatch_ } else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH)) Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags)); + else if (OP(o) == SBOL) + Perl_sv_catpvf(aTHX_ sv, " /%s/", o->flags ? "\\A" : "^"); #else PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); @@ -16507,202 +16789,299 @@ S_re_croak2(pTHX_ bool utf8, const char* pat1,const char* pat2,...) Perl_croak(aTHX_ "%"UTF8f, UTF8fARG(utf8, l1-1, buf)); } -/* XXX Here's a total kludge. But we need to re-enter for swash routines. */ - -#ifndef PERL_IN_XSUB_RE -void -Perl_save_re_context(pTHX) -{ - /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */ - if (PL_curpm) { - const REGEXP * const rx = PM_GETRE(PL_curpm); - if (rx) { - U32 i; - for (i = 1; i <= RX_NPARENS(rx); i++) { - char digits[TYPE_CHARS(long)]; - const STRLEN len = my_snprintf(digits, sizeof(digits), - "%lu", (long)i); - GV *const *const gvp - = (GV**)hv_fetch(PL_defstash, digits, len, 0); - - if (gvp) { - GV * const gv = *gvp; - if (SvTYPE(gv) == SVt_PVGV && GvSV(gv)) - save_scalar(gv); - } - } - } - } -} -#endif - #ifdef DEBUGGING +/* Certain characters are output as a sequence with the first being a + * backslash. */ +#define isBACKSLASHED_PUNCT(c) \ + ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^') STATIC void -S_put_byte(pTHX_ SV *sv, int c) +S_put_code_point(pTHX_ SV *sv, UV c) { - PERL_ARGS_ASSERT_PUT_BYTE; - - if (!isPRINT(c)) { - switch (c) { - case '\r': Perl_sv_catpvf(aTHX_ sv, "\\r"); break; - case '\n': Perl_sv_catpvf(aTHX_ sv, "\\n"); break; - case '\t': Perl_sv_catpvf(aTHX_ sv, "\\t"); break; - case '\f': Perl_sv_catpvf(aTHX_ sv, "\\f"); break; - case '\a': Perl_sv_catpvf(aTHX_ sv, "\\a"); break; + PERL_ARGS_ASSERT_PUT_CODE_POINT; - default: - Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c); - break; - } + if (c > 255) { + Perl_sv_catpvf(aTHX_ sv, "\\x{%04"UVXf"}", c); } - else { - const char string = c; - if (c == '-' || c == ']' || c == '\\' || c == '^') + else if (isPRINT(c)) { + const char string = (char) c; + if (isBACKSLASHED_PUNCT(c)) sv_catpvs(sv, "\\"); sv_catpvn(sv, &string, 1); } + else { + const char * const mnemonic = cntrl_to_mnemonic((char) c); + if (mnemonic) { + Perl_sv_catpvf(aTHX_ sv, "%s", mnemonic); + } + else { + Perl_sv_catpvf(aTHX_ sv, "\\x{%02X}", (U8) c); + } + } } +#define MAX_PRINT_A MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C + +#ifndef MIN +#define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + STATIC void -S_put_range(pTHX_ SV *sv, UV start, UV end) +S_put_range(pTHX_ SV *sv, UV start, const UV end, const bool allow_literals) { - /* Appends to 'sv' a displayable version of the range of code points from * 'start' to 'end'. It assumes that only ASCII printables are displayable - * as-is (though some of these will be escaped by put_byte()). For the - * time being, this subroutine only works for latin1 (< 256) code points */ + * as-is (though some of these will be escaped by put_code_point()). */ + + const unsigned int min_range_count = 3; assert(start <= end); PERL_ARGS_ASSERT_PUT_RANGE; while (start <= end) { - if (end - start < 3) { /* Individual chars in short ranges */ + UV this_end; + const char * format; + + if (end - start < min_range_count) { + + /* Individual chars in short ranges */ for (; start <= end; start++) { - put_byte(sv, start); + put_code_point(sv, start); } break; } - /* For small ranges that include printable ASCII characters, it's more - * legible to print those characters rather than hex values. For - * larger ranges that include more than printables, it's probably - * clearer to just give the start and end points of the range in hex, - * and that's all we can do if there aren't any printables within the - * range - * - * On ASCII platforms the range of printables is contiguous. If the - * entire range is printable, we print each character as such. If the - * range is partially printable and partially not, it's less likely - * that the individual printables are meaningful, especially if all or - * almost all of them are in the range. But we err on the side of the - * individual printables being meaningful by using the hex only if the - * range contains all but 2 of the printables. - * - * On EBCDIC platforms, the printables are scattered around so that the - * maximum range length containing only them is about 10. Anything - * longer we treat as hex; otherwise we examine the range character by - * character to see */ -#ifdef EBCDIC - if (start < 256 && (((end < 255) ? end : 255) - start <= 10)) -#else - if ((isPRINT_A(start) && isPRINT_A(end)) - || (end >= 0x7F && (isPRINT_A(start) && start > 0x21)) - || ((end < 0x7D && isPRINT_A(end)) && start < 0x20)) -#endif - { - /* If the range beginning isn't an ASCII printable, we find the - * last such in the range, then split the output, so all the - * non-printables are in one subrange; then process the remaining - * portion as usual. If the entire range isn't printables, we - * don't split, but drop down to print as hex */ + /* If permitted by the input options, and there is a possibility that + * this range contains a printable literal, look to see if there is + * one. */ + if (allow_literals && start <= MAX_PRINT_A) { + + /* If the range begin isn't an ASCII printable, effectively split + * the range into two parts: + * 1) the portion before the first such printable, + * 2) the rest + * and output them separately. */ if (! isPRINT_A(start)) { UV temp_end = start + 1; - while (temp_end <= end && ! isPRINT_A(temp_end)) { + + /* There is no point looking beyond the final possible + * printable, in MAX_PRINT_A */ + UV max = MIN(end, MAX_PRINT_A); + + while (temp_end <= max && ! isPRINT_A(temp_end)) { temp_end++; } - if (temp_end <= end) { - put_range(sv, start, temp_end - 1); - start = temp_end; - continue; + + /* Here, temp_end points to one beyond the first printable if + * found, or to one beyond 'max' if not. If none found, make + * sure that we use the entire range */ + if (temp_end > MAX_PRINT_A) { + temp_end = end + 1; } - } - /* If the range beginning is a digit, output a subrange of just the - * digits, then process the remaining portion as usual */ - if (isDIGIT_A(start)) { - put_byte(sv, start); - sv_catpvs(sv, "-"); - while (start <= end && isDIGIT_A(start)) start++; - put_byte(sv, start - 1); + /* Output the first part of the split range, the part that + * doesn't have printables, with no looking for literals + * (otherwise we would infinitely recurse) */ + put_range(sv, start, temp_end - 1, FALSE); + + /* The 2nd part of the range (if any) starts here. */ + start = temp_end; + + /* We continue instead of dropping down because even if the 2nd + * part is non-empty, it could be so short that we want to + * output it specially, as tested for at the top of this loop. + * */ continue; } - /* Similarly for alphabetics. Because in both ASCII and EBCDIC, - * the code points for upper and lower A-Z and a-z aren't - * intermixed, the resulting subrange will consist solely of either - * upper- or lower- alphabetics */ - if (isALPHA_A(start)) { - put_byte(sv, start); - sv_catpvs(sv, "-"); - while (start <= end && isALPHA_A(start)) start++; - put_byte(sv, start - 1); + /* Here, 'start' is a printable ASCII. If it is an alphanumeric, + * output a sub-range of just the digits or letters, then process + * the remaining portion as usual. */ + if (isALPHANUMERIC_A(start)) { + UV mask = (isDIGIT_A(start)) + ? _CC_DIGIT + : isUPPER_A(start) + ? _CC_UPPER + : _CC_LOWER; + UV temp_end = start + 1; + + /* Find the end of the sub-range that includes just the + * characters in the same class as the first character in it */ + while (temp_end <= end && _generic_isCC_A(temp_end, mask)) { + temp_end++; + } + temp_end--; + + /* For short ranges, don't duplicate the code above to output + * them; just call recursively */ + if (temp_end - start < min_range_count) { + put_range(sv, start, temp_end, FALSE); + } + else { /* Output as a range */ + put_code_point(sv, start); + sv_catpvs(sv, "-"); + put_code_point(sv, temp_end); + } + start = temp_end + 1; continue; } - /* We output any remaining printables as individual characters */ + /* We output any other printables as individual characters */ if (isPUNCT_A(start) || isSPACE_A(start)) { - while (start <= end && (isPUNCT_A(start) || isSPACE_A(start))) { - put_byte(sv, start); + while (start <= end && (isPUNCT_A(start) + || isSPACE_A(start))) + { + put_code_point(sv, start); start++; } continue; } + } /* End of looking for literals */ + + /* Here is not to output as a literal. Some control characters have + * mnemonic names. Split off any of those at the beginning and end of + * the range to print mnemonically. It isn't possible for many of + * these to be in a row, so this won't overwhelm with output */ + while (isMNEMONIC_CNTRL(start) && start <= end) { + put_code_point(sv, start); + start++; } + if (start < end && isMNEMONIC_CNTRL(end)) { + + /* Here, the final character in the range has a mnemonic name. + * Work backwards from the end to find the final non-mnemonic */ + UV temp_end = end - 1; + while (isMNEMONIC_CNTRL(temp_end)) { + temp_end--; + } - /* Here is a control or non-ascii. Output the range or subrange as - * hex. */ - Perl_sv_catpvf(aTHX_ sv, "\\x{%02" UVXf "}-\\x{%02" UVXf "}", - start, - (end < 256) ? end : 255); + /* And separately output the range that doesn't have mnemonics */ + put_range(sv, start, temp_end, FALSE); + + /* Then output the mnemonic trailing controls */ + start = temp_end + 1; + while (start <= end) { + put_code_point(sv, start); + start++; + } + break; + } + + /* As a final resort, output the range or subrange as hex. */ + + this_end = (end < NUM_ANYOF_CODE_POINTS) + ? end + : NUM_ANYOF_CODE_POINTS - 1; + format = (this_end < 256) + ? "\\x{%02"UVXf"}-\\x{%02"UVXf"}" + : "\\x{%04"UVXf"}-\\x{%04"UVXf"}"; + Perl_sv_catpvf(aTHX_ sv, format, start, this_end); break; } } STATIC bool -S_put_latin1_charclass_innards(pTHX_ SV *sv, char *bitmap) +S_put_charclass_bitmap_innards(pTHX_ SV *sv, char *bitmap, SV** bitmap_invlist) { /* Appends to 'sv' a displayable version of the innards of the bracketed * character class whose bitmap is 'bitmap'; Returns 'TRUE' if it actually - * output anything */ + * output anything, and bitmap_invlist, if not NULL, will point to an + * inversion list of what is in the bit map */ int i; - bool has_output_anything = FALSE; + UV start, end; + unsigned int punct_count = 0; + SV* invlist = NULL; + SV** invlist_ptr; /* Temporary, in case bitmap_invlist is NULL */ + bool allow_literals = TRUE; + + PERL_ARGS_ASSERT_PUT_CHARCLASS_BITMAP_INNARDS; + + invlist_ptr = (bitmap_invlist) ? bitmap_invlist : &invlist; + + /* Worst case is exactly every-other code point is in the list */ + *invlist_ptr = _new_invlist(NUM_ANYOF_CODE_POINTS / 2); + + /* Convert the bit map to an inversion list, keeping track of how many + * ASCII puncts are set, including an extra amount for the backslashed + * ones. */ + for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) { + if (BITMAP_TEST(bitmap, i)) { + *invlist_ptr = add_cp_to_invlist(*invlist_ptr, i); + if (isPUNCT_A(i)) { + punct_count++; + if isBACKSLASHED_PUNCT(i) { + punct_count++; + } + } + } + } - PERL_ARGS_ASSERT_PUT_LATIN1_CHARCLASS_INNARDS; + /* Nothing to output */ + if (_invlist_len(*invlist_ptr) == 0) { + SvREFCNT_dec(invlist); + return FALSE; + } - for (i = 0; i < 256; i++) { - if (BITMAP_TEST((U8 *) bitmap,i)) { + /* Generally, it is more readable if printable characters are output as + * literals, but if a range (nearly) spans all of them, it's best to output + * it as a single range. This code will use a single range if all but 2 + * printables are in it */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { - /* The character at index i should be output. Find the next - * character that should NOT be output */ - int j; - for (j = i + 1; j < 256; j++) { - if (! BITMAP_TEST((U8 *) bitmap, j)) { - break; - } - } + /* If range starts beyond final printable, it doesn't have any in it */ + if (start > MAX_PRINT_A) { + break; + } - /* Everything between them is a single range that should be output - * */ - put_range(sv, i, j - 1); - has_output_anything = TRUE; - i = j; + /* In both ASCII and EBCDIC, a SPACE is the lowest printable. To span + * all but two, the range must start and end no later than 2 from + * either end */ + if (start < ' ' + 2 && end > MAX_PRINT_A - 2) { + if (end > MAX_PRINT_A) { + end = MAX_PRINT_A; + } + if (start < ' ') { + start = ' '; + } + if (end - start >= MAX_PRINT_A - ' ' - 2) { + allow_literals = FALSE; + } + break; } } + invlist_iterfinish(*invlist_ptr); + + /* The legibility of the output depends mostly on how many punctuation + * characters are output. There are 32 possible ASCII ones, and some have + * an additional backslash, bringing it to currently 36, so if any more + * than 18 are to be output, we can instead output it as its complement, + * yielding fewer puncts, and making it more legible. But give some weight + * to the fact that outputting it as a complement is less legible than a + * straight output, so don't complement unless we are somewhat over the 18 + * mark */ + if (allow_literals && punct_count > 22) { + sv_catpvs(sv, "^"); + + /* Add everything remaining to the list, so when we invert it just + * below, it will be excluded */ + _invlist_union_complement_2nd(*invlist_ptr, PL_InBitmap, invlist_ptr); + _invlist_invert(*invlist_ptr); + } + + /* Here we have figured things out. Output each range */ + invlist_iterinit(*invlist_ptr); + while (invlist_iternext(*invlist_ptr, &start, &end)) { + if (start >= NUM_ANYOF_CODE_POINTS) { + break; + } + put_range(sv, start, end, allow_literals); + } + invlist_iterfinish(*invlist_ptr); - return has_output_anything; + return TRUE; } #define CLEAR_OPTSTART \ @@ -16853,7 +17232,7 @@ S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node, } else if (PL_regkind[(U8)op] == ANYOF) { /* arglen 1 + class block */ - node += 1 + ((ANYOF_FLAGS(node) & ANYOF_POSIXL) + node += 1 + ((ANYOF_FLAGS(node) & ANYOF_MATCHES_POSIXL) ? ANYOF_POSIXL_SKIP : ANYOF_SKIP); node = NEXTOPER(node); diff --git a/regcomp.h b/regcomp.h index 3bb1a53..d4d3a29 100644 --- a/regcomp.h +++ b/regcomp.h @@ -140,13 +140,12 @@ #define PREGf_GPOS_SEEN 0x00000100 #define PREGf_GPOS_FLOAT 0x00000200 -#define PREGf_ANCH_BOL 0x00000400 -#define PREGf_ANCH_MBOL 0x00000800 -#define PREGf_ANCH_SBOL 0x00001000 -#define PREGf_ANCH_GPOS 0x00002000 +#define PREGf_ANCH_MBOL 0x00000400 +#define PREGf_ANCH_SBOL 0x00000800 +#define PREGf_ANCH_GPOS 0x00001000 -#define PREGf_ANCH (PREGf_ANCH_SBOL | PREGf_ANCH_GPOS | \ - PREGf_ANCH_MBOL | PREGf_ANCH_BOL ) +#define PREGf_ANCH \ + ( PREGf_ANCH_SBOL | PREGf_ANCH_GPOS | PREGf_ANCH_MBOL ) /* this is where the old regcomp.h started */ @@ -184,8 +183,22 @@ struct regnode_2 { U16 arg2; }; - -#define ANYOF_BITMAP_SIZE (256 / 8) /* 8 bits/Byte */ +/* This give the number of code points that can be in the bitmap of an ANYOF + * node. The shift number must currently be one of: 8..12. It can't be less + * than 8 (256) because some code relies on it being at least that. Above 12 + * (4096), and you start running into warnings that some data structure widths + * have been exceeded, though the test suite as of this writing still passes + * for up through 16, which is as high as anyone would ever want to go, + * encompassing all of the Unicode BMP, and thus including all the economically + * important world scripts. At 12 most of them are: including Arabic, + * Cyrillic, Greek, Hebrew, Indian subcontinent, Latin, and Thai; but not Han, + * Japanese, nor Korean. (The regarglen structure in regnodes.h is a U8, and + * the trie types TRIEC and AHOCORASICKC are larger than U8 for shift values + * below above 12.) Be sure to benchmark before changing, as larger sizes do + * significantly slow down the test suite */ +#define NUM_ANYOF_CODE_POINTS (1 << 8) + +#define ANYOF_BITMAP_SIZE (NUM_ANYOF_CODE_POINTS / 8) /* 8 bits/Byte */ /* Note that these form structs which are supersets of the next smaller one, by * appending fields. Alignment problems can occur if one of those optional @@ -209,11 +222,11 @@ struct regnode_charclass { /* has runtime (locale) \d, \w, ..., [:posix:] classes */ struct regnode_charclass_class { - U8 flags; /* ANYOF_POSIXL bit must go here */ + U8 flags; /* ANYOF_MATCHES_POSIXL bit must go here */ U8 type; U16 next_off; U32 arg1; - char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */ + char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time ... */ U32 classflags; /* and run-time */ }; @@ -227,11 +240,11 @@ struct regnode_charclass_class { * have a pointer field because there is no alignment issue, and because it is * set to NULL after construction, before any cloning of the pattern */ struct regnode_ssc { - U8 flags; /* ANYOF_POSIXL bit must go here */ + U8 flags; /* ANYOF_MATCHES_POSIXL bit must go here */ U8 type; U16 next_off; U32 arg1; - char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time */ + char bitmap[ANYOF_BITMAP_SIZE]; /* both compile-time ... */ U32 classflags; /* and run-time */ /* Auxiliary, only used during construction; NULL afterwards: list of code @@ -296,7 +309,16 @@ struct regnode_ssc { #define NEXT_OFF(p) ((p)->next_off) #define NODE_ALIGN(node) -#define NODE_ALIGN_FILL(node) ((node)->flags = 0xde) /* deadbeef */ +/* the following define was set to 0xde in 075abff3 + * as part of some linting logic. I have set it to 0 + * as otherwise in every place where we /might/ set flags + * we have to set it 0 explicitly, which duplicates + * assignments and IMO adds an unacceptable level of + * surprise to working in the regex engine. If this + * is changed from 0 then at the very least make sure + * that SBOL for /^/ sets the flags to 0 explicitly. + * -- Yves */ +#define NODE_ALIGN_FILL(node) ((node)->flags = 0) #define SIZE_ALIGN NODE_ALIGN @@ -346,13 +368,13 @@ struct regnode_ssc { #define PASS1 SIZE_ONLY #define PASS2 (! SIZE_ONLY) -/* If the bitmap doesn't fully represent what this ANYOF node can match, the +/* If the bitmap fully represents what this ANYOF node can match, the * ARG is set to this special value (since 0, 1, ... are legal, but will never * reach this high). */ -#define ANYOF_NONBITMAP_EMPTY ((U32) -1) +#define ANYOF_ONLY_HAS_BITMAP ((U32) -1) /* Flags for node->flags of ANYOF. These are in short supply, with none - * currently available. The ABOVE_LATIN1_ALL bit could be freed up + * currently available. The ABOVE_BITMAP_ALL bit could be freed up * by resorting to creating a swash containing everything above 255. This * introduces a performance penalty. An option that wouldn't slow things down * would be to split one of the two LOC flags out into a separate @@ -364,57 +386,55 @@ struct regnode_ssc { * only for /d, so there are no combinatorial issues. The LOC flag to use is * probably the POSIXL one. * Several flags are not used in synthetic start class (SSC) nodes, so could be - * shared should new flags be needed for SSCs, like ANYOF_EMPTY_STRING now. */ + * shared should new flags be needed for SSCs, like SSC_MATCHES_EMPTY_STRING + * now. */ /* regexec.c is expecting this to be in the low bit */ -#define ANYOF_INVERT 0x01 +#define ANYOF_INVERT 0x01 /* For the SSC node only, which cannot be inverted, so is shared with that bit. - * This means "Does this SSC match an empty string?" This is used only during - * regex compilation. */ -#define ANYOF_EMPTY_STRING ANYOF_INVERT + * This is used only during regex compilation. */ +#define SSC_MATCHES_EMPTY_STRING ANYOF_INVERT -/* Are there things that will match only if the target string is encoded in - * UTF-8? (This is not set if ANYOF_AOVE_LATIN1_ALL is set) */ -#define ANYOF_UTF8 0x02 +/* Are there things outside the bitmap that will match only if the target + * string is encoded in UTF-8? (This is not set if ANYOF_ABOVE_BITMAP_ALL is + * set) */ +#define ANYOF_HAS_UTF8_NONBITMAP_MATCHES 0x02 /* The fold is calculated and stored in the bitmap where possible at compile * time. However under locale, the actual folding varies depending on * what the locale is at the time of execution, so it has to be deferred until * then */ -#define ANYOF_LOC_FOLD 0x04 +#define ANYOF_LOC_FOLD 0x04 /* Set if this is a regnode_charclass_posixl vs a regnode_charclass. This * is used for runtime \d, \w, [:posix:], ..., which are used only in locale * and the optimizer's synthetic start class. Non-locale \d, etc are resolved * at compile-time */ -#define ANYOF_POSIXL 0x08 -#define ANYOF_CLASS ANYOF_POSIXL -#define ANYOF_LARGE ANYOF_POSIXL +#define ANYOF_MATCHES_POSIXL 0x08 /* Should we raise a warning if matching against an above-Unicode code point? * */ -#define ANYOF_WARN_SUPER 0x10 +#define ANYOF_WARN_SUPER 0x10 /* Can match something outside the bitmap that isn't in utf8 */ -#define ANYOF_NONBITMAP_NON_UTF8 0x20 +#define ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES 0x20 -/* Matches every code point 0x100 and above*/ -#define ANYOF_ABOVE_LATIN1_ALL 0x40 -#define ANYOF_UNICODE_ALL ANYOF_ABOVE_LATIN1_ALL +/* Matches every code point NUM_ANYOF_CODE_POINTS and above*/ +#define ANYOF_MATCHES_ALL_ABOVE_BITMAP 0x40 /* Match all Latin1 characters that aren't ASCII when the target string is not * in utf8. */ -#define ANYOF_NON_UTF8_NON_ASCII_ALL 0x80 +#define ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII 0x80 #define ANYOF_FLAGS_ALL (0xff) -#define ANYOF_LOCALE_FLAGS (ANYOF_LOC_FOLD | ANYOF_POSIXL) +#define ANYOF_LOCALE_FLAGS (ANYOF_LOC_FOLD | ANYOF_MATCHES_POSIXL) /* These are the flags that apply to both regular ANYOF nodes and synthetic * start class nodes during construction of the SSC. During finalization of * the SSC, other of the flags could be added to it */ -#define ANYOF_COMMON_FLAGS (ANYOF_WARN_SUPER|ANYOF_UTF8) +#define ANYOF_COMMON_FLAGS (ANYOF_WARN_SUPER|ANYOF_HAS_UTF8_NONBITMAP_MATCHES) /* Character classes for node->classflags of ANYOF */ /* Should be synchronized with a table in regprop() */ @@ -499,7 +519,7 @@ struct regnode_ssc { #define ANYOF_FLAGS(p) ((p)->flags) -#define ANYOF_BIT(c) (1 << ((c) & 7)) +#define ANYOF_BIT(c) (1U << ((c) & 7)) #define ANYOF_POSIXL_SET(p, c) (((regnode_charclass_posixl*) (p))->classflags |= (1U << (c))) #define ANYOF_CLASS_SET(p, c) ANYOF_POSIXL_SET((p), (c)) @@ -518,7 +538,7 @@ struct regnode_ssc { #define ANYOF_CLASS_SETALL(ret) ANYOF_POSIXL_SETALL(ret) #define ANYOF_POSIXL_TEST_ANY_SET(p) \ - ((ANYOF_FLAGS(p) & ANYOF_POSIXL) \ + ((ANYOF_FLAGS(p) & ANYOF_MATCHES_POSIXL) \ && (((regnode_charclass_posixl*)(p))->classflags)) #define ANYOF_CLASS_TEST_ANY_SET(p) ANYOF_POSIXL_TEST_ANY_SET(p) @@ -531,7 +551,7 @@ struct regnode_ssc { == ((1U << ((ANYOF_POSIXL_MAX) - 1))) - 1) #define ANYOF_POSIXL_TEST_ALL_SET(p) \ - ((ANYOF_FLAGS(p) & ANYOF_POSIXL) \ + ((ANYOF_FLAGS(p) & ANYOF_MATCHES_POSIXL) \ && ((regnode_charclass_posixl*) (p))->classflags \ == ((1U << ((ANYOF_POSIXL_MAX) - 1))) - 1) @@ -545,15 +565,12 @@ struct regnode_ssc { #define ANYOF_BITMAP_BYTE(p, c) (ANYOF_BITMAP(p)[(((U8)(c)) >> 3) & 31]) #define ANYOF_BITMAP_SET(p, c) (ANYOF_BITMAP_BYTE(p, c) |= ANYOF_BIT(c)) #define ANYOF_BITMAP_CLEAR(p,c) (ANYOF_BITMAP_BYTE(p, c) &= ~ANYOF_BIT(c)) -#define ANYOF_BITMAP_TEST(p, c) (ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c)) +#define ANYOF_BITMAP_TEST(p, c) cBOOL(ANYOF_BITMAP_BYTE(p, c) & ANYOF_BIT(c)) #define ANYOF_BITMAP_SETALL(p) \ memset (ANYOF_BITMAP(p), 255, ANYOF_BITMAP_SIZE) #define ANYOF_BITMAP_CLEARALL(p) \ Zero (ANYOF_BITMAP(p), ANYOF_BITMAP_SIZE) -/* Check that all 256 bits are all set. Used in S_cl_is_anything() */ -#define ANYOF_BITMAP_TESTALLSET(p) /* Assumes sizeof(p) == 32 */ \ - memEQ (ANYOF_BITMAP(p), "\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377", ANYOF_BITMAP_SIZE) #define ANYOF_SKIP ((ANYOF_SIZE - 1)/sizeof(regnode)) #define ANYOF_POSIXL_SKIP ((ANYOF_POSIXL_SIZE - 1)/sizeof(regnode)) diff --git a/regcomp.sym b/regcomp.sym index bea2a8e..6908712 100644 --- a/regcomp.sym +++ b/regcomp.sym @@ -24,15 +24,20 @@ END END, no ; End of program. SUCCEED END, no ; Return from a subroutine, basically. -#* Anchors: - -BOL BOL, no ; Match "" at beginning of line. -MBOL BOL, no ; Same, assuming multiline. -SBOL BOL, no ; Same, assuming singleline. -EOS EOL, no ; Match "" at end of string. -EOL EOL, no ; Match "" at end of line. -MEOL EOL, no ; Same, assuming multiline. -SEOL EOL, no ; Same, assuming singleline. +#* Line Start Anchors: +#Note flags field for SBOL indicates if it is a /^/ or a /\A/ +SBOL BOL, no ; Match "" at beginning of line: /^/, /\A/ +MBOL BOL, no ; Same, assuming multiline: /^/m + +#* Line End Anchors: +SEOL EOL, no ; Match "" at end of line: /$/ +MEOL EOL, no ; Same, assuming multiline: /$/m +EOS EOL, no ; Match "" at end of string: /\z/ + +#* Match Start Anchors: +GPOS GPOS, no ; Matches where last m//g left off. + +#* Word Boundary Opcodes: # The regops that have varieties that vary depending on the character set regex # modifiers have to ordered thusly: /d, /l, /u, /a, /aa. This is because code # in regcomp.c uses the enum value of the modifier as an offset from the /d @@ -47,15 +52,14 @@ NBOUND NBOUND, no ; Match "" at any word non-boundary using nati NBOUNDL NBOUND, no ; Match "" at any locale word non-boundary NBOUNDU NBOUND, no ; Match "" at any word non-boundary using Unicode rules NBOUNDA NBOUND, no ; Match "" at any word non-boundary using ASCII rules -GPOS GPOS, no ; Matches where last m//g left off. #* [Special] alternatives: - REG_ANY REG_ANY, no 0 S ; Match any one character (except newline). SANY REG_ANY, no 0 S ; Match any one character. CANY REG_ANY, no 0 S ; Match any one byte. ANYOF ANYOF, sv 0 S ; Match character in (or not in) this class, single char match only +#* POSIX Character Classes: # Order of the below is important. See ordering comment above. POSIXD POSIXD, none 0 S ; Some [[:class:]] under /d; the FLAGS field gives which one POSIXL POSIXD, none 0 S ; Some [[:class:]] under /l; the FLAGS field gives which one @@ -147,16 +151,17 @@ NREFFL REF, no-sv 1 V ; Match already matched string, folded in loc. NREFFU REF, num 1 V ; Match already matched string, folded using unicode rules for non-utf8 NREFFA REF, num 1 V ; Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII +#*Support for long RE +LONGJMP LONGJMP, off 1 . 1 ; Jump far away. +BRANCHJ BRANCHJ, off 1 V 1 ; BRANCH with long offset. + +#*Special Case Regops IFMATCH BRANCHJ, off 1 . 2 ; Succeeds if the following matches. UNLESSM BRANCHJ, off 1 . 2 ; Fails if the following matches. SUSPEND BRANCHJ, off 1 V 1 ; "Independent" sub-RE. IFTHEN BRANCHJ, off 1 V 1 ; Switch, should be preceded by switcher. GROUPP GROUPP, num 1 ; Whether the group matched. -#*Support for long RE - -LONGJMP LONGJMP, off 1 . 1 ; Jump far away. -BRANCHJ BRANCHJ, off 1 V 1 ; BRANCH with long offset. #*The heavy worker diff --git a/regen/mk_PL_charclass.pl b/regen/mk_PL_charclass.pl index aaefb46..8a682dc 100644 --- a/regen/mk_PL_charclass.pl +++ b/regen/mk_PL_charclass.pl @@ -47,6 +47,7 @@ my @properties = qw( XDIGIT VERTSPACE IS_IN_SOME_FOLD + MNEMONIC_CNTRL ); # Read in the case fold mappings. @@ -235,6 +236,9 @@ for my $ord (0..255) { $re = qr/\p{Is_Non_Final_Fold}/; } elsif ($name eq 'IS_IN_SOME_FOLD') { $re = qr/\p{_Perl_Any_Folds}/; + } elsif ($name eq 'MNEMONIC_CNTRL') { + # These are the control characters that there are mnemonics for + $re = qr/[\a\b\e\f\n\r\t]/; } else { # The remainder have the same name and values as Unicode $re = eval "qr/\\p{$name}/"; use Carp; diff --git a/regen/op_private b/regen/op_private new file mode 100644 index 0000000..b86a1bd --- /dev/null +++ b/regen/op_private @@ -0,0 +1,716 @@ +#!perl + +=head1 F + +This file contains all the definitions of the meanings of the flags in the +op_private field of an OP. + +After editing this file, run C. This will generate/update data +in: + + opcode.h + lib/B/Op_private.pm + +C holds three global hashes, C<%bits>, C<%defines>, +C<%labels>, which hold roughly the same information as found in this file +(after processing). + +F gains a series of C defines, and a few static data +structures: + +C defines, per-op, which op_private bits are legally +allowed to be set. This is a good first place to look to see if an op has +any spare private bits. + +C, C, +C, C, +C contain (in a compact form) the data needed by +Perl_do_op_dump() to dump the op_private field of an op. + +This file actually contains perl code which is run by F. +The basic idea is that you keep calling addbits() to add definitions of +what a particular bit or range of bits in op_private means for a +particular op. This can be specified either as a 1-bit flag or a 1-or-more +bit bit field. Here's a general example: + + addbits('aelem', + 7 => qw(OPpLVAL_INTRO LVINTRO), + '5..6' => { + mask_def => 'OPpDEREF', + enum => [ qw( + 1 OPpDEREF_AV DREFAV + 2 OPpDEREF_HV DREFHV + 3 OPpDEREF_SV DREFSV + )], + }, + 4 => qw(OPpLVAL_DEFER LVDEFER), + ); + +Here for the op C, bits 4 and 7 (bits are numbered 0..7) are +defined as single-bit flags. The first string following the bit number is +the define name that gets emitted in F, and the second string is +the label, which will be displayed by F and Perl_do_op_dump() +(as used by C). + +If the bit number is actually two numbers connected with '..', then this +defines a bit field, which is 1 or more bits taken to hold a small +unsigned integer. Instead of two string arguments, it just has a single +hash ref argument. A bit field allows you to generate extra defines, such +as a mask, and optionally allows you to define an enumeration, where a +subset of the possible values of the bit field are given their own defines +and labels. The full syntax of this hash is explained further below. + +Note that not all bits for a particular op need to be added in a single +addbits() call; they accumulate. In particular, this file is arranged in +two halves; first, generic flags shared by multiple ops are added, then +in the second half, specific per-op flags are added, e.g. + + addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO)) for qw(pos substr vec ...); + + .... + + addbits('substr', + 4 => qw(OPpSUBSTR_REPL_FIRST REPL1ST), + 3 => ... + ); + +(although the dividing line between these two halves is somewhat +subjective, and is based on whether "OPp" is followed by the op name or +something generic). + +There are some utility functions for generating a list of ops from +F based on various criteria. These are: + + ops_with_check('ck_foo') + ops_with_flag('X') + ops_with_arg(N, 'XYZ') + +which respectively return a list of op names where: + + field 3 of regen/opcodes specifies 'ck_foo' as the check function; + field 4 of of regen/opcodes has flag or type 'X' set; + argument field N of of regen/opcodes matches 'XYZ'; + +For example + + addbits($_, 4 => qw(OPpTARGET_MY TARGMY)) for ops_with_flag('T'); + +If a label is specified as '-', then the flag or bit field is not +displayed symbolically by Concise/-Dx; instead the bits are treated as +unrecognised and are included in the final residual integer value after +all recognised bits have been processed (this doesn't apply to individual +enum labels). + +Here is a full example of a bit field hash: + + '5..6' => { + mask_def => 'OPpFOO_MASK', + baseshift_def => 'OPpFOO_SHIFT', + bitcount_def => 'OPpFOO_BITS', + label => 'FOO', + enum => [ qw( + 1 OPpFOO_A A + 2 OPpFOO_B B + 3 OPpFOO_C C + )], + }; + +The optional C<*_def> keys cause defines to be emitted that specify +useful values based on the bit range (5 to 6 in this case): + + mask_def: a mask that will extract the bit field + baseshift_def: how much to shift to make the bit field reach bit 0 + bitcount_def: how many bits make up the bit field + +The example above will generate + + #define OPpFOO_MASK 0x60 + #define OPpFOO_SHIFT 5 + #define OPpFOO_BITS 2 + +The optional enum list specifies a set of defines and labels for (possibly +a subset of) the possible values of the bit field (which in this example +are 0,1,2,3). If a particular value matches an enum, then it will be +displayed symbolically (e.g. 'C'), otherwise as a small integer. The +defines are suitably shifted. The example above will generate + + #define OPpFOO_A 0x20 + #define OPpFOO_B 0x40 + #define OPpFOO_C 0x60 + +So you can write code like + + if ((o->op_private & OPpFOO_MASK) == OPpFOO_C) ... + +The optional 'label' key causes Concise/-Dx output to prefix the value +with C; so in this case it might display C. If the field +value is zero, and if no label is present, and if no enum matches, then +the field isn't displayed. + +=cut + + +use warnings; +use strict; + + + + +# ==================================================================== +# +# GENERIC OPpFOO flags +# +# Flags where FOO is a generic term (like LVAL), and the flag is +# shared between multiple (possibly unrelated) ops. + + + + +{ + # The lower few bits of op_private often indicate the number of + # arguments. This is usually set by newUNOP() and newLOGOP (to 1), + # by newBINOP() (to 1 or 2), and by ck_fun() (to 1..15). + # + # These values are sometimes used at runtime: in particular, + # the MAXARG macro extracts out the lower 4 bits. + # + # Some ops encroach upon these bits; for example, entersub is a unop, + # but uses bit 0 for something else. Bit 0 is initially set to 1 in + # newUNOP(), but is later cleared (in ck_rvconst()), when the code + # notices that this op is an entersub. + # + # The important thing below is that any ops which use MAXARG at + # runtime must have all 4 bits allocated; if bit 3 were used for a new + # flag say, then things could break. The information on the other + # types of op is for completeness (so we can account for every bit + # used in every op) + + my (%maxarg, %args0, %args1, %args2, %args3, %args4); + + # these are the functions which currently use MAXARG at runtime + # (i.e. in the pp() functions). Thus they must always have 4 bits + # allocated + $maxarg{$_} = 1 for qw( + binmode bless caller chdir close enterwrite eof exit fileno getc + getpgrp gmtime index mkdir rand reset setpgrp sleep srand sysopen + tell umask + ); + + # find which ops use 0,1,2,3 or 4 bits of op_private for arg count info + + $args0{$_} = 1 for qw(entersub); # UNOPs that usurp bit 0 + + $args1{$_} = 1 for ( + qw(reverse), # ck_fun(), but most bits stolen + grep !$maxarg{$_} && !$args0{$_}, + ops_with_flag('1'), # UNOP + ops_with_flag('%'), # BASEOP/UNOP + ops_with_flag('|'), # LOGOP + ops_with_flag('-'), # FILESTATOP + ops_with_flag('}'), # LOOPEXOP + ); + + $args2{$_} = 1 for ( + qw(vec), + grep !$maxarg{$_} && !$args0{$_} && !$args1{$_}, + ops_with_flag('2'), # BINOP + # this is a binop, but special-cased as a + # baseop in regen/opcodes + 'sassign', + ); + + $args3{$_} = 1 for grep !$maxarg{$_} && !$args0{$_} + && !$args1{$_} && !$args2{$_}, + # substr starts off with 4 bits set in + # ck_fun(), but since it never has more than 7 + # args, bit 3 is later stolen + qw(substr); + + $args4{$_} = 1 for keys %maxarg, + grep !$args0{$_} && !$args1{$_} + && !$args2{$_} && !$args3{$_}, + ops_with_check('ck_fun'), + # these other ck_*() functions call ck_fun() + ops_with_check('ck_exec'), + ops_with_check('ck_glob'), + ops_with_check('ck_index'), + ops_with_check('ck_join'), + ops_with_check('ck_lfun'), + ops_with_check('ck_open'), + ops_with_check('ck_select'), + ops_with_check('ck_tell'), + ops_with_check('ck_trunc'), + ; + + + for (sort keys %args1) { + addbits($_, '0..0' => { + mask_def => 'OPpARG1_MASK', + label => '-', + } + ); + } + + for (sort keys %args2) { + addbits($_, '0..1' => { + mask_def => 'OPpARG2_MASK', + label => '-', + } + ); + } + + for (sort keys %args3) { + addbits($_, '0..2' => { + mask_def => 'OPpARG3_MASK', + label => '-', + } + ); + } + + for (sort keys %args4) { + addbits($_, '0..3' => { + mask_def => 'OPpARG4_MASK', + label => '-', + } + ); + } +} + + + +# if NATIVE_HINTS is defined, op_private on cops holds the top 8 bits +# of PL_hints, although only bits 6 & 7 are officially used for that +# purpose (the rest ought to be masked off). Bit 5 is set separately + +for (qw(nextstate dbstate)) { + addbits($_, + 5 => qw(OPpHUSH_VMSISH HUSH), + # should match HINT_M_VMSISH_STATUS, HINT_M_VMSISH_TIME + 6 => qw(OPpHINT_M_VMSISH_STATUS VMSISH_STATUS), + 7 => qw(OPpHINT_M_VMSISH_TIME VMSISH_TIME), + + ); +} + + + +addbits($_, 7 => qw(OPpLVAL_INTRO LVINTRO)) + for qw(pos substr vec gvsv rv2sv rv2hv rv2gv rv2av aelem helem aslice + hslice delete padsv padav padhv enteriter entersub padrange + pushmark cond_expr), + 'list', # this gets set in my_attrs() for some reason + ; + + + +# TARGLEX +# +# in constructs like my $x; ...; $x = $a + $b, +# the sassign is optimised away and OPpTARGET_MY is set on the add op +# +# Note that OPpTARGET_MY is mainly used at compile-time. At run time, +# the pp function just updates the SV pointed to by op_targ, and doesn't +# care whether that's a PADTMP or a lexical var. + +# Some comments about when its safe to use T/OPpTARGET_MY. +# +# Safe to set if the ppcode uses: +# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG, +# SETs(TARG), XPUSHn, XPUSHu, +# +# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF] +# +# lt and friends do SETs (including ncmp, but not scmp) +# +# Additional mode of failure: the opcode can modify TARG before it "used" +# all the arguments (or may call an external function which does the same). +# If the target coincides with one of the arguments ==> kaboom. +# +# pp.c pos substr each not OK (RETPUSHUNDEF) +# substr vec also not OK due to LV to target (are they???) +# ref not OK (RETPUSHNO) +# trans not OK (dTARG; TARG = sv_newmortal();) +# ucfirst etc not OK: TMP arg processed inplace +# quotemeta not OK (unsafe when TARG == arg) +# each repeat not OK too due to list context +# pack split - unknown whether they are safe +# sprintf: is calling do_sprintf(TARG,...) which can act on TARG +# before other args are processed. +# +# Suspicious wrt "additional mode of failure" (and only it): +# schop, chop, postinc/dec, bit_and etc, negate, complement. +# +# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack. +# +# substr/vec: doing TAINT_off()??? +# +# pp_hot.c +# readline - unknown whether it is safe +# match subst not OK (dTARG) +# grepwhile not OK (not always setting) +# join not OK (unsafe when TARG == arg) +# +# Suspicious wrt "additional mode of failure": concat (dealt with +# in ck_sassign()), join (same). +# +# pp_ctl.c +# mapwhile flip caller not OK (not always setting) +# +# pp_sys.c +# backtick glob warn die not OK (not always setting) +# warn not OK (RETPUSHYES) +# open fileno getc sysread syswrite ioctl accept shutdown +# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF) +# umask select not OK (XPUSHs(&PL_sv_undef);) +# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC")) +# sselect shm* sem* msg* syscall - unknown whether they are safe +# gmtime not OK (list context) +# +# Suspicious wrt "additional mode of failure": warn, die, select. + + +addbits($_, 4 => qw(OPpTARGET_MY TARGMY)) + for ops_with_flag('T'), + # This flag is also used to indicate matches against implicit $_, + # where $_ is lexical; e.g. my $_; ....; /foo/ + qw(match subst trans transr); +; + + + + + +# op_targ carries a refcount +addbits($_, 6 => qw(OPpREFCOUNTED REFC)) + for qw(leave leavesub leavesublv leavewrite leaveeval); + + + +# Do not copy return value +addbits($_, 7 => qw(OPpLVALUE LV)) for qw(leave leaveloop); + + + +# Pattern coming in on the stack +addbits($_, 6 => qw(OPpRUNTIME RTIME)) + for qw(match subst substcont qr pushre); + + + +# autovivify: Want ref to something +for (qw(rv2gv rv2sv padsv aelem helem entersub)) { + addbits($_, '5..6' => { + mask_def => 'OPpDEREF', + enum => [ qw( + 1 OPpDEREF_AV DREFAV + 2 OPpDEREF_HV DREFHV + 3 OPpDEREF_SV DREFSV + )], + } + ); +} + + + +# Defer creation of array/hash elem +addbits($_, 4 => qw(OPpLVAL_DEFER LVDEFER)) for qw(aelem helem); + + + +addbits($_, 2 => qw(OPpSLICEWARNING SLICEWARN)) # warn about @hash{$scalar} + for qw(rv2hv rv2av padav padhv hslice aslice); + + + +# XXX Concise seemed to think that OPpOUR_INTRO is used in rv2gv too, +# but I can't see it - DAPM +addbits($_, 4 => qw(OPpOUR_INTRO OURINTR)) # Variable was in an our() + for qw(gvsv rv2sv rv2av rv2hv enteriter); + + + +# We might be an lvalue to return +addbits($_, 3 => qw(OPpMAYBE_LVSUB LVSUB)) + for qw(aassign rv2av rv2gv rv2hv padav padhv aelem helem aslice hslice + av2arylen keys rkeys kvaslice kvhslice substr pos vec); + + + +for (qw(rv2hv padhv)) { + addbits($_, # e.g. %hash in (%hash || $foo) ... + 5 => qw(OPpTRUEBOOL BOOL), # ... in void cxt + 6 => qw(OPpMAYBE_TRUEBOOL BOOL?), # ... cx not known till run time + ); +} + + + +addbits($_, 1 => qw(OPpHINT_STRICT_REFS STRICT)) for qw(rv2sv rv2av rv2hv rv2gv); + + + +# Treat caller(1) as caller(2) +addbits($_, 7 => qw(OPpOFFBYONE +1)) for qw(caller wantarray runcv); + + + +# label is in UTF8 */ +addbits($_, 7 => qw(OPpPV_IS_UTF8 UTF)) for qw(last redo next goto dump); + + + +# ==================================================================== +# +# OP-SPECIFIC OPpFOO_* flags: +# +# where FOO is typically the name of an op, and the flag is used by a +# single op (or maybe by a few closely related ops). + + + +addbits($_, 4 => qw(OPpPAD_STATE STATE)) for qw(padav padhv padsv pushmark); + + + +addbits('aassign', 6 => qw(OPpASSIGN_COMMON COMMON)); + + + +addbits('sassign', + 6 => qw(OPpASSIGN_BACKWARDS BKWARD), # Left & right switched + 7 => qw(OPpASSIGN_CV_TO_GV CV2GV), # Possible optimisation for constants +); + + + +for (qw(trans transr)) { + addbits($_, + 0 => qw(OPpTRANS_FROM_UTF qw(OPpTRANS_TO_UTF >UTF), + 2 => qw(OPpTRANS_IDENTICAL IDENT), # right side is same as left + 3 => qw(OPpTRANS_SQUASH SQUASH), + # 4 is used for OPpTARGET_MY + 5 => qw(OPpTRANS_COMPLEMENT COMPL), + 6 => qw(OPpTRANS_GROWS GROWS), + 7 => qw(OPpTRANS_DELETE DEL), + ); +} + + + +addbits('repeat', 6 => qw(OPpREPEAT_DOLIST DOLIST)); # List replication + + + +# OP_ENTERSUB and OP_RV2CV flags +# +# Flags are set on entersub and rv2cv in three phases: +# parser - the parser passes the flag to the op constructor +# check - the check routine called by the op constructor sets the flag +# context - application of scalar/ref/lvalue context applies the flag +# +# In the third stage, an entersub op might turn into an rv2cv op (undef &foo, +# \&foo, lock &foo, exists &foo, defined &foo). The two places where that +# happens (op_lvalue_flags and doref in op.c) need to make sure the flags do +# not conflict, since some flags with different meanings overlap between +# the two ops. Flags applied in the context phase are only set when there +# is no conversion of op type. +# +# bit entersub flag phase rv2cv flag phase +# --- ------------- ----- ---------- ----- +# 0 OPpENTERSUB_INARGS context +# 1 HINT_STRICT_REFS check HINT_STRICT_REFS check +# 2 OPpENTERSUB_HASTARG checki OPpENTERSUB_HASTARG +# 3 OPpENTERSUB_AMPER check OPpENTERSUB_AMPER parser +# 4 OPpENTERSUB_DB check OPpENTERSUB_DB +# 5 OPpDEREF_AV context +# 6 OPpDEREF_HV context OPpMAY_RETURN_CONSTANT parser/context +# 7 OPpLVAL_INTRO context OPpENTERSUB_NOPAREN parser + +# NB: OPpHINT_STRICT_REFS must equal HINT_STRICT_REFS + +addbits('entersub', + 0 => qw(OPpENTERSUB_INARGS INARGS), # Lval used as arg to a sub + 1 => qw(OPpHINT_STRICT_REFS STRICT), # 'use strict' in scope + 2 => qw(OPpENTERSUB_HASTARG TARG ), # Called from OP tree + 3 => qw(OPpENTERSUB_AMPER AMPER), # Used & form to call + 4 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine + # 5..6 => OPpDEREF, already defined above + # 7 => OPpLVAL_INTRO, already defined above +); + +# note that some of these flags are just left-over from when an entersub +# is converted into an rv2cv, and could probably be cleared/re-assigned + +addbits('rv2cv', + 1 => qw(OPpHINT_STRICT_REFS STRICT), # 'use strict' in scope + 2 => qw(OPpENTERSUB_HASTARG TARG ), # If const sub, return the const + 3 => qw(OPpENTERSUB_AMPER AMPER ), # Used & form to call + 4 => qw(OPpENTERSUB_DB DBG ), # Debug subroutine + + 6 => qw(OPpMAY_RETURN_CONSTANT CONST ), + 7 => qw(OPpENTERSUB_NOPAREN NO() ), # bare sub call (without parens) +); + + + +#foo() called before sub foo was parsed */ +addbits('gv', 5 => qw(OPpEARLY_CV EARLYCV)); + + + +# 1st arg is replacement string */ +addbits('substr', 4 => qw(OPpSUBSTR_REPL_FIRST REPL1ST)); + + + +addbits('padrange', + # bits 0..6 hold target range + '0..6' => { + label => '-', + mask_def => 'OPpPADRANGE_COUNTMASK', + bitcount_def => 'OPpPADRANGE_COUNTSHIFT', + } + # 7 => OPpLVAL_INTRO, already defined above +); + + + +for (qw(aelemfast aelemfast_lex)) { + addbits($_, + '0..7' => { + label => '-', + } + ); +} + + + +addbits('rv2gv', + 2 => qw(OPpDONT_INIT_GV NOINIT), # Call gv_fetchpv with GV_NOINIT + # (Therefore will return whatever is currently in + # the symbol table, not guaranteed to be a PVGV) + 4 => qw(OPpALLOW_FAKE FAKE), # OK to return fake glob +); + + + +addbits('enteriter', + 2 => qw(OPpITER_REVERSED REVERSED),# for (reverse ...) + 3 => qw(OPpITER_DEF DEF), # 'for $_' or 'for my $_' +); +addbits('iter', 2 => qw(OPpITER_REVERSED REVERSED)); + + + +addbits('const', + 1 => qw(OPpCONST_NOVER NOVER), # no 6; + 2 => qw(OPpCONST_SHORTCIRCUIT SHORT), # e.g. the constant 5 in (5 || foo) + 3 => qw(OPpCONST_STRICT STRICT), # bareword subject to strict 'subs' + 4 => qw(OPpCONST_ENTERED ENTERED), # Has been entered as symbol + 6 => qw(OPpCONST_BARE BARE), # Was a bare word (filehandle?) +); + + + +# Range arg potentially a line num. */ +addbits($_, 6 => qw(OPpFLIP_LINENUM LINENUM)) for qw(flip flop); + + + +# Guessed that pushmark was needed. */ +addbits('list', 6 => qw(OPpLIST_GUESSED GUESSED)); + + + +# Operating on a list of keys +addbits('delete', 6 => qw(OPpSLICE SLICE)); +# also 7 => OPpLVAL_INTRO, already defined above + + + +# Checking for &sub, not {} or []. +addbits('exists', 6 => qw(OPpEXISTS_SUB SUB)); + + + +addbits('sort', + 0 => qw(OPpSORT_NUMERIC NUM ), # Optimized away { $a <=> $b } + 1 => qw(OPpSORT_INTEGER INT ), # Ditto while under "use integer" + 2 => qw(OPpSORT_REVERSE REV ), # Reversed sort + 3 => qw(OPpSORT_INPLACE INPLACE), # sort in-place; eg @a = sort @a + 4 => qw(OPpSORT_DESCEND DESC ), # Descending sort + 5 => qw(OPpSORT_QSORT QSORT ), # Use quicksort (not mergesort) + 6 => qw(OPpSORT_STABLE STABLE ), # Use a stable algorithm +); + + + +# reverse in-place (@a = reverse @a) */ +addbits('reverse', 3 => qw(OPpREVERSE_INPLACE INPLACE)); + + + +for (qw(open backtick)) { + addbits($_, + 4 => qw(OPpOPEN_IN_RAW INBIN ), # binmode(F,":raw") on input fh + 5 => qw(OPpOPEN_IN_CRLF INCR ), # binmode(F,":crlf") on input fh + 6 => qw(OPpOPEN_OUT_RAW OUTBIN), # binmode(F,":raw") on output fh + 7 => qw(OPpOPEN_OUT_CRLF OUTCR ), # binmode(F,":crlf") on output fh + ); +} + + + +# The various OPpFT* filetest ops + +# "use filetest 'access'" is in scope: +# this flag is set only on a subset of the FT* ops +addbits($_, 1 => qw(OPpFT_ACCESS FTACCESS)) for ops_with_arg(0, 'F-+'); + +# all OPpFT* ops except stat and lstat +for (grep { $_ !~ /^l?stat$/ } ops_with_flag('-')) { + addbits($_, + 2 => qw(OPpFT_STACKED FTSTACKED ), # stacked filetest, + # e.g. "-f" in "-f -x $foo" + 3 => qw(OPpFT_STACKING FTSTACKING), # stacking filetest. + # e.g. "-x" in "-f -x $foo" + 4 => qw(OPpFT_AFTER_t FTAFTERt ), # previous op was -t + ); +} + + + +addbits($_, 1 => qw(OPpGREP_LEX GREPLEX)) # iterate over lexical $_ + for qw(mapwhile mapstart grepwhile grepstart); + + + +addbits('entereval', + 1 => qw(OPpEVAL_HAS_HH HAS_HH ), # Does it have a copy of %^H ? + 2 => qw(OPpEVAL_UNICODE UNI ), + 3 => qw(OPpEVAL_BYTES BYTES ), + 4 => qw(OPpEVAL_COPHH COPHH ), # Construct %^H from COP hints + 5 => qw(OPpEVAL_RE_REPARSING REPARSE), # eval_sv(..., G_RE_REPARSING) +); + + + +# These must not conflict with OPpDONT_INIT_GV or OPpALLOW_FAKE. +# See pp.c:S_rv2gv. */ +addbits('coreargs', + 0 => qw(OPpCOREARGS_DEREF1 DEREF1), # Arg 1 is a handle constructor + 1 => qw(OPpCOREARGS_DEREF2 DEREF2), # Arg 2 is a handle constructor + #2 reserved for OPpDONT_INIT_GV in rv2gv + #4 reserved for OPpALLOW_FAKE in rv2gv + 6 => qw(OPpCOREARGS_SCALARMOD $MOD ), # \$ rather than \[$@%*] + 7 => qw(OPpCOREARGS_PUSHMARK MARK ), # Call pp_pushmark +); + + + +addbits('split', 7 => qw(OPpSPLIT_IMPLIM IMPLIM)); # implicit limit + +1; + +# ex: set ts=8 sts=4 sw=4 et: diff --git a/regen/opcode.pl b/regen/opcode.pl index a081c64..93fdc06 100755 --- a/regen/opcode.pl +++ b/regen/opcode.pl @@ -5,9 +5,12 @@ # opcode.h # opnames.h # pp_proto.h +# lib/B/Op_private.pm # -# from information stored in regen/opcodes, plus the -# values hardcoded into this script in @raw_alias. +# from: +# * information stored in regen/opcodes; +# * information stored in regen/op_private (which is actually perl code); +# * the values hardcoded into this script in @raw_alias. # # Accepts the standard regen_lib -q and -v args. # @@ -29,7 +32,15 @@ my $on = open_new('opnames.h', '>', { by => 'regen/opcode.pl', from => 'its data', style => '*', file => 'opnames.h', copyright => [1999 .. 2008] }); -# Read data. +my $oprivpm = open_new('lib/B/Op_private.pm', '>', + { by => 'regen/opcode.pl', + from => "data in\nregen/op_private " + ."and pod embedded in regen/opcode.pl", + style => '#', + file => 'lib/B/Op_private.pm', + copyright => [2014 .. 2014] }); + +# Read 'opcodes' data. my %seen; my (@ops, %desc, %check, %ckname, %flags, %args, %opnum); @@ -143,6 +154,728 @@ foreach my $sock_func (qw(socket bind listen accept shutdown $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'], } + + +# ================================================================= +# +# Functions for processing regen/op_private data. +# +# Put them in a separate package so that croak() does the right thing + +package OP_PRIVATE; + +use Carp; + + +# the vars holding the global state built up by all the calls to addbits() + + +# map OPpLVAL_INTRO => LVINTRO +my %LABELS; + + +# the numeric values of flags - what will get output as a #define +my %DEFINES; + +# %BITFIELDS: the various bit field types. The key is the concatenation of +# all the field values that make up a bit field hash; the values are bit +# field hash refs. This allows us to de-dup identical bit field defs +# across different ops, and thus make the output tables more compact (esp +# important for the C version) +my %BITFIELDS; + +# %FLAGS: the main data structure. Indexed by op name, then bit index: +# single bit flag: +# $FLAGS{rv2av}{2} = 'OPpSLICEWARNING'; +# bit field (bits 5 and 6): +# $FLAGS{rv2av}{5} = $FLAGS{rv2av}{6} = { .... }; +my %FLAGS; + + +# do, with checking, $LABELS{$name} = $label + +sub add_label { + my ($name, $label) = @_; + if (exists $LABELS{$name} and $LABELS{$name} ne $label) { + croak "addbits(): label for flag '$name' redefined:\n" + . " was '$LABELS{$name}', now '$label'"; + } + $LABELS{$name} = $label; +} + +# +# do, with checking, $DEFINES{$name} = $val + +sub add_define { + my ($name, $val) = @_; + if (exists $DEFINES{$name} && $DEFINES{$name} != $val) { + croak "addbits(): value for flag '$name' redefined:\n" + . " was $DEFINES{$name}, now $val"; + } + $DEFINES{$name} = $val; +} + + +# intended to be called from regen/op_private; see that file for details + +sub ::addbits { + my @args = @_; + + croak "too few arguments for addbits()" unless @args >= 3; + my $op = shift @args; + croak "invalid op name: '$op'" unless exists $opnum{$op}; + + while (@args) { + my $bits = shift @args; + if ($bits =~ /^[0-7]$/) { + # single bit + croak "addbits(): too few arguments for single bit flag" + unless @args >= 2; + my $flag_name = shift @args; + my $flag_label = shift @args; + add_label($flag_name, $flag_label); + croak "addbits(): bit $bits of $op already specified" + if defined $FLAGS{$op}{$bits}; + $FLAGS{$op}{$bits} = $flag_name; + add_define($flag_name, (1 << $bits)); + } + elsif ($bits =~ /^([0-7])\.\.([0-7])$/) { + # bit range + my ($bitmin, $bitmax) = ($1,$2); + + croak "addbits(): min bit > max bit in bit range '$bits'" + unless $bitmin <= $bitmax; + croak "addbits(): bit field argument missing" + unless @args >= 1; + + my $arg_hash = shift @args; + croak "addbits(): arg to $bits must be a hash ref" + unless defined $arg_hash and ref($arg_hash) =~ /HASH/; + + my %valid_keys; + @valid_keys{qw(baseshift_def bitcount_def mask_def label enum)} = (); + for (keys %$arg_hash) { + croak "addbits(): unrecognised bifield key: '$_'" + unless exists $valid_keys{$_}; + } + + my $bitmask = 0; + $bitmask += (1 << $_) for $bitmin..$bitmax; + + my $enum_id =''; + + if (defined $arg_hash->{enum}) { + my $enum = $arg_hash->{enum}; + croak "addbits(): arg to enum must be an array ref" + unless defined $enum and ref($enum) =~ /ARRAY/; + croak "addbits(): enum list must be in triplets" + unless @$enum % 3 == 0; + + my $max_id = (1 << ($bitmax - $bitmin + 1)) - 1; + + my @e = @$enum; + while (@e) { + my $enum_ix = shift @e; + my $enum_name = shift @e; + my $enum_label = shift @e; + croak "addbits(): enum index must be a number: '$enum_ix'" + unless $enum_ix =~ /^\d+$/; + croak "addbits(): enum index too big: '$enum_ix'" + unless $enum_ix <= $max_id; + add_label($enum_name, $enum_label); + add_define($enum_name, $enum_ix << $bitmin); + $enum_id .= "($enum_ix:$enum_name:$enum_label)"; + } + } + + # id is a fingerprint of all the content of the bit field hash + my $id = join ':', map defined() ? $_ : "-undef-", + $bitmin, $bitmax, + $arg_hash->{label}, + $arg_hash->{mask_def}, + $arg_hash->{baseshift_def}, + $arg_hash->{bitcount_def}, + $enum_id; + + unless (defined $BITFIELDS{$id}) { + + if (defined $arg_hash->{mask_def}) { + add_define($arg_hash->{mask_def}, $bitmask); + } + + if (defined $arg_hash->{baseshift_def}) { + add_define($arg_hash->{baseshift_def}, $bitmin); + } + + if (defined $arg_hash->{bitcount_def}) { + add_define($arg_hash->{bitcount_def}, $bitmax-$bitmin+1); + } + + # create deep copy + + my $copy = {}; + for (qw(baseshift_def bitcount_def mask_def label)) { + $copy->{$_} = $arg_hash->{$_} if defined $arg_hash->{$_}; + } + if (defined $arg_hash->{enum}) { + $copy->{enum} = [ @{$arg_hash->{enum}} ]; + } + + # and add some extra fields + + $copy->{bitmask} = $bitmask; + $copy->{bitmin} = $bitmin; + $copy->{bitmax} = $bitmax; + + $BITFIELDS{$id} = $copy; + } + + for my $bit ($bitmin..$bitmax) { + croak "addbits(): bit $bit of $op already specified" + if defined $FLAGS{$op}{$bit}; + $FLAGS{$op}{$bit} = $BITFIELDS{$id}; + } + } + else { + croak "addbits(): invalid bit specifier '$bits'"; + } + } +} + + +# intended to be called from regen/op_private; see that file for details + +sub ::ops_with_flag { + my $flag = shift; + return grep $flags{$_} =~ /\Q$flag/, sort keys %flags; +} + + +# intended to be called from regen/op_private; see that file for details + +sub ::ops_with_check { + my $c = shift; + return grep $check{$_} eq $c, sort keys %check; +} + + +# intended to be called from regen/op_private; see that file for details + +sub ::ops_with_arg { + my ($i, $arg_type) = @_; + my @ops; + for my $op (sort keys %args) { + my @args = split(' ',$args{$op}); + push @ops, $op if defined $args[$i] and $args[$i] eq $arg_type; + } + @ops; +} + + +# output '#define OPpLVAL_INTRO 0x80' etc + +sub print_defines { + my $fh = shift; + + for (sort { $DEFINES{$a} <=> $DEFINES{$b} || $a cmp $b } keys %DEFINES) { + printf $fh "#define %-23s 0x%02x\n", $_, $DEFINES{$_}; + } +} + + +# Generate the content of B::Op_private + +sub print_B_Op_private { + my $fh = shift; + + my $header = <<'EOF'; +@=head1 NAME +@ +@B::Op_private - OP op_private flag definitions +@ +@=head1 SYNOPSIS +@ +@ use B::Op_private; +@ +@ # flag details for bit 7 of OP_AELEM's op_private: +@ my $name = $B::Op_private::bits{aelem}{7}; # OPpLVAL_INTRO +@ my $value = $B::Op_private::defines{$name}; # 128 +@ my $label = $B::Op_private::labels{$name}; # LVINTRO +@ +@ # the bit field at bits 5..6 of OP_AELEM's op_private: +@ my $bf = $B::Op_private::bits{aelem}{6}; +@ my $mask = $bf->{bitmask}; # etc +@ +@=head1 DESCRIPTION +@ +@This module provides three global hashes: +@ +@ %B::Op_private::bits +@ %B::Op_private::defines +@ %B::Op_private::labels +@ +@which contain information about the per-op meanings of the bits in the +@op_private field. +@ +@=head2 C<%bits> +@ +@This is indexed by op name and then bit number (0..7). For single bit flags, +@it returns the name of the define (if any) for that bit: +@ +@ $B::Op_private::bits{aelem}{7} eq 'OPpLVAL_INTRO'; +@ +@For bit fields, it returns a hash ref containing details about the field. +@The same reference will be returned for all bit positions that make +@up the bit field; so for example these both return the same hash ref: +@ +@ $bitfield = $B::Op_private::bits{aelem}{5}; +@ $bitfield = $B::Op_private::bits{aelem}{6}; +@ +@The general format of this hash ref is +@ +@ { +@ # The bit range and mask; these are always present. +@ bitmin => 5, +@ bitmax => 6, +@ bitmask => 0x60, +@ +@ # (The remaining keys are optional) +@ +@ # The names of any defines that were requested: +@ mask_def => 'OPpFOO_MASK', +@ baseshift_def => 'OPpFOO_SHIFT', +@ bitcount_def => 'OPpFOO_BITS', +@ +@ # If present, Concise etc will display the value with a 'FOO=' +@ # prefix. If it equals '-', then Concise will treat the bit +@ # field as raw bits and not try to interpret it. +@ label => 'FOO', +@ +@ # If present, specifies the names of some defines and the +@ # display labels that are used to assign meaning to particu- +@ # lar integer values within the bit field; e.g. 3 is dis- +@ # played as 'C'. +@ enum => [ qw( +@ 1 OPpFOO_A A +@ 2 OPpFOO_B B +@ 3 OPpFOO_C C +@ )], +@ +@ }; +@ +@ +@=head2 C<%defines> +@ +@This gives the value of every C define, e.g. +@ +@ $B::Op_private::defines{OPpLVAL_INTRO} == 128; +@ +@=head2 C<%labels> +@ +@This gives the short display label for each define, as used by C +@and C, e.g. +@ +@ $B::Op_private::labels{OPpLVAL_INTRO} eq 'LVINTRO'; +@ +@If the label equals '-', then Concise will treat the bit as a raw bit and +@not try to display it symbolically. +@ +@=cut + +package B::Op_private; + +our %bits; + +EOF + # remove podcheck.t-defeating leading char + $header =~ s/^\@//gm; + print $fh $header; + my $v = (::perl_version())[3]; + print $fh qq{\nour \$VERSION = "$v";\n\n}; + + # for each flag/bit combination, find the ops which use it + my %combos; + for my $op (sort keys %FLAGS) { + my $entry = $FLAGS{$op}; + for my $bit (0..7) { + my $e = $entry->{$bit}; + next unless defined $e; + next if ref $e; # bit field, not flag + push @{$combos{$e}{$bit}}, $op; + } + } + + # dump flags used by multiple ops + for my $flag (sort keys %combos) { + for my $bit (sort keys %{$combos{$flag}}) { + my $ops = $combos{$flag}{$bit}; + next unless @$ops > 1; + my @o = sort @$ops; + print $fh "\$bits{\$_}{$bit} = '$flag' for qw(@o);\n"; + } + } + + # dump bit field definitions + + my %bitfield_ix; + { + my %bitfields; + # stringified-ref to ref mapping + $bitfields{$_} = $_ for values %BITFIELDS; + my $ix = -1; + my $s = "\nmy \@bf = (\n"; + for my $bitfield_key (sort keys %BITFIELDS) { + my $bitfield = $BITFIELDS{$bitfield_key}; + $ix++; + $bitfield_ix{$bitfield} = $ix; + + $s .= " {\n"; + for (qw(label mask_def baseshift_def bitcount_def)) { + next unless defined $bitfield->{$_}; + $s .= sprintf " %-9s => '%s',\n", + $_, $bitfield->{$_}; + } + for (qw(bitmin bitmax bitmask)) { + croak "panic" unless defined $bitfield->{$_}; + $s .= sprintf " %-9s => %d,\n", + $_, $bitfield->{$_}; + } + if (defined $bitfield->{enum}) { + $s .= " enum => [\n"; + my @enum = @{$bitfield->{enum}}; + while (@enum) { + my $i = shift @enum; + my $name = shift @enum; + my $label = shift @enum; + $s .= sprintf " %d, %-10s, %s,\n", + $i, "'$name'", "'$label'"; + } + $s .= " ],\n"; + } + $s .= " },\n"; + + } + $s .= ");\n"; + print $fh "$s\n"; + } + + # dump bitfields and remaining labels + + for my $op (sort keys %FLAGS) { + my @indices; + my @vals; + my $entry = $FLAGS{$op}; + my $bit; + + for ($bit = 7; $bit >= 0; $bit--) { + next unless defined $entry->{$bit}; + my $e = $entry->{$bit}; + if (ref $e) { + my $ix = $bitfield_ix{$e}; + for (reverse $e->{bitmin}..$e->{bitmax}) { + push @indices, $_; + push @vals, "\$bf[$ix]"; + } + $bit = $e->{bitmin}; + } + else { + next if @{$combos{$e}{$bit}} > 1; # already output + push @indices, $bit; + push @vals, "'$e'"; + } + } + if (@indices) { + my $s = ''; + $s = '@{' if @indices > 1; + $s .= "\$bits{$op}"; + $s .= '}' if @indices > 1; + $s .= '{' . join(',', @indices) . '} = '; + $s .= '(' if @indices > 1; + $s .= join ', ', @vals; + $s .= ')' if @indices > 1; + print $fh "$s;\n"; + } + } + + # populate %defines and %labels + + print $fh "\n\nour %defines = (\n"; + printf $fh " %-23s => %3d,\n", $_ , $DEFINES{$_} for sort keys %DEFINES; + print $fh ");\n\nour %labels = (\n"; + printf $fh " %-23s => '%s',\n", $_ , $LABELS{$_} for sort keys %LABELS; + print $fh ");\n"; + +} + + + +# output the contents of the assorted PL_op_private_*[] tables + +sub print_PL_op_private_tables { + my $fh = shift; + + my $PL_op_private_labels = ''; + my $PL_op_private_valid = ''; + my $PL_op_private_bitdef_ix = ''; + my $PL_op_private_bitdefs = ''; + my $PL_op_private_bitfields = ''; + + my %label_ix; + my %bitfield_ix; + + # generate $PL_op_private_labels + + { + my %labs; + $labs{$_} = 1 for values %LABELS; # de-duplicate labels + # add in bit field labels + for (values %BITFIELDS) { + next unless defined $_->{label}; + $labs{$_->{label}} = 1; + } + + my $labels = ''; + for my $lab (sort keys %labs) { + $label_ix{$lab} = length $labels; + $labels .= "$lab\0"; + $PL_op_private_labels .= + " " + . join(',', map("'$_'", split //, $lab)) + . ",'\\0',\n"; + } + } + + + # generate PL_op_private_bitfields + + { + my %bitfields; + # stringified-ref to ref mapping + $bitfields{$_} = $_ for values %BITFIELDS; + + my $ix = 0; + for my $bitfield_key (sort keys %BITFIELDS) { + my $bf = $BITFIELDS{$bitfield_key}; + $bitfield_ix{$bf} = $ix; + + my @b; + push @b, $bf->{bitmin}, + defined $bf->{label} ? $label_ix{$bf->{label}} : -1; + my $enum = $bf->{enum}; + if (defined $enum) { + my @enum = @$enum; + while (@enum) { + my $i = shift @enum; + my $name = shift @enum; + my $label = shift @enum; + push @b, $i, $label_ix{$label}; + } + } + push @b, -1; # terminate enum list + + $PL_op_private_bitfields .= " " . join(', ', @b) .",\n"; + $ix += @b; + } + } + + + # generate PL_op_private_bitdefs, PL_op_private_bitdef_ix + + { + my $bitdef_count = 0; + + my %not_seen = %FLAGS; + + my $opnum = -1; + for my $op (sort { $opnum{$a} <=> $opnum{$b} } keys %opnum) { + $opnum++; + die "panic: opnum misorder: opnum=$opnum opnum{op}=$opnum{$op}" + unless $opnum == $opnum{$op}; + delete $not_seen{$op}; + + my @bitdefs; + my $entry = $FLAGS{$op}; + my $bit; + my $index; + + for ($bit = 7; $bit >= 0; $bit--) { + my $e = $entry->{$bit}; + next unless defined $e; + + my $ix; + if (ref $e) { + $ix = $bitfield_ix{$e}; + die "panic: \$bit =\= $e->{bitmax}" + unless $bit == $e->{bitmax}; + + push @bitdefs, ( ($ix << 5) | ($bit << 2) | 2 ); + $bit = $e->{bitmin}; + } + else { + $ix = $label_ix{$LABELS{$e}}; + die "panic: no label ix for '$e'" unless defined $ix; + push @bitdefs, ( ($ix << 5) | ($bit << 2)); + } + if ($ix > 2047) { + die "Too many labels or bitfields (ix=$ix): " + . "maybe the type of PL_op_private_bitdefs needs " + . "expanding from U16 to U32???"; + } + } + if (@bitdefs) { + $bitdefs[-1] |= 1; # stop bit + $index = $bitdef_count; + $bitdef_count += @bitdefs; + $PL_op_private_bitdefs .= sprintf " /* %-13s */ %s,\n", + $op, + join(', ', map(sprintf("0x%04x", $_), @bitdefs)); + } + else { + $index = -1; + } + $PL_op_private_bitdef_ix .= sprintf " %4d, /* %s */\n", $index, $op; + } + if (%not_seen) { + die "panic: unprocessed ops: ". join(',', keys %not_seen); + } + } + + + # generate PL_op_private_valid + + for my $op (@ops) { + my $last; + my @flags; + for my $bit (0..7) { + next unless exists $FLAGS{$op}; + my $entry = $FLAGS{$op}{$bit}; + next unless defined $entry; + if (ref $entry) { + # skip later entries for the same bit field + next if defined $last and $last == $entry; + $last = $entry; + push @flags, + defined $entry->{mask_def} + ? $entry->{mask_def} + : $entry->{bitmask}; + } + else { + push @flags, $entry; + } + } + + # all bets are off + @flags = '0xff' if $op eq 'null' or $op eq 'custom'; + + $PL_op_private_valid .= sprintf " /* %-10s */ (%s),\n", uc($op), + @flags ? join('|', @flags): '0'; + } + + print $fh <', } print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs; } -foreach ($oc, $on, $pp) { - read_only_bottom_close_and_rename($_); -} - -# Some comments about 'T' opcode classifier: - -# Safe to set if the ppcode uses: -# tryAMAGICbin, tryAMAGICun, SETn, SETi, SETu, PUSHn, PUSHTARG, SETTARG, -# SETs(TARG), XPUSHn, XPUSHu, - -# Unsafe to set if the ppcode uses dTARG or [X]RETPUSH[YES|NO|UNDEF] -# lt and friends do SETs (including ncmp, but not scmp) +print $oc "\n\n"; +OP_PRIVATE::print_defines($oc); +OP_PRIVATE::print_PL_op_private_tables($oc); -# Additional mode of failure: the opcode can modify TARG before it "used" -# all the arguments (or may call an external function which does the same). -# If the target coincides with one of the arguments ==> kaboom. +OP_PRIVATE::print_B_Op_private($oprivpm); -# pp.c pos substr each not OK (RETPUSHUNDEF) -# substr vec also not OK due to LV to target (are they???) -# ref not OK (RETPUSHNO) -# trans not OK (dTARG; TARG = sv_newmortal();) -# ucfirst etc not OK: TMP arg processed inplace -# quotemeta not OK (unsafe when TARG == arg) -# each repeat not OK too due to list context -# pack split - unknown whether they are safe -# sprintf: is calling do_sprintf(TARG,...) which can act on TARG -# before other args are processed. - -# Suspicious wrt "additional mode of failure" (and only it): -# schop, chop, postinc/dec, bit_and etc, negate, complement. - -# Also suspicious: 4-arg substr, sprintf, uc/lc (POK_only), reverse, pack. - -# substr/vec: doing TAINT_off()??? - -# pp_hot.c -# readline - unknown whether it is safe -# match subst not OK (dTARG) -# grepwhile not OK (not always setting) -# join not OK (unsafe when TARG == arg) - -# Suspicious wrt "additional mode of failure": concat (dealt with -# in ck_sassign()), join (same). - -# pp_ctl.c -# mapwhile flip caller not OK (not always setting) - -# pp_sys.c -# backtick glob warn die not OK (not always setting) -# warn not OK (RETPUSHYES) -# open fileno getc sysread syswrite ioctl accept shutdown -# ftsize(etc) readlink telldir fork alarm getlogin not OK (RETPUSHUNDEF) -# umask select not OK (XPUSHs(&PL_sv_undef);) -# fileno getc sysread syswrite tell not OK (meth("FILENO" "GETC")) -# sselect shm* sem* msg* syscall - unknown whether they are safe -# gmtime not OK (list context) +foreach ($oc, $on, $pp, $oprivpm) { + read_only_bottom_close_and_rename($_); +} -# Suspicious wrt "additional mode of failure": warn, die, select. diff --git a/regen/opcodes b/regen/opcodes index 988b841..82e0e0f 100644 --- a/regen/opcodes +++ b/regen/opcodes @@ -16,15 +16,15 @@ # pvop/svop - " cop - ; # Other options are: -# needs stack mark - m -# needs constant folding - f -# produces a scalar - s -# produces an integer - i -# needs a target - t -# target can be in a pad - T -# has a corresponding integer version - I -# has side effects - d -# uses $_ if no argument given - u +# needs stack mark - m (OA_MARK) +# needs constant folding - f (OA_FOLDCONST) +# produces a scalar - s (OA_RETSCALAR) +# produces an integer - i (unused) +# needs a target - t (OA_TARGET) +# target can be in a pad - T (OA_TARGET|OA_TARGLEX) +# has a corresponding integer version - I (OA_OTHERINT) +# has side effects - d (OA_DANGEROUS) +# uses $_ if no argument given - u (OA_DEFGV) # Values for the operands are: # scalar - S list - L array - A diff --git a/regen/regcomp.pl b/regen/regcomp.pl index 2b6d964..b90efc7 100644 --- a/regen/regcomp.pl +++ b/regen/regcomp.pl @@ -28,6 +28,7 @@ open DESC, 'regcomp.sym'; my $ind = 0; my (@name,@rest,@type,@code,@args,@flags,@longj,@cmnt); my ($longest_name_length,$desc,$lastregop) = 0; +my (%seen_op, %type_alias); while () { # Special pod comments if (/^#\* ?/) { $cmnt[$ind] .= "# $'"; } @@ -43,8 +44,22 @@ while () { } unless ($lastregop) { ($name[$ind], $desc, $rest[$ind]) = /^(\S+)\s+([^\t]+?)\s*;\s*(.*)/; + + if (defined $seen_op{$name[$ind]}) { + die "Duplicate regop $name[$ind] in regcomp.sym line $. previously defined on line $seen_op{$name[$ind]}\n"; + } else { + $seen_op{$name[$ind]}= $.; + } + ($type[$ind], $code[$ind], $args[$ind], $flags[$ind], $longj[$ind]) = split /[,\s]\s*/, $desc; + + if (!defined $seen_op{$type[$ind]} and !defined $type_alias{$type[$ind]}) { + #warn "Regop type '$type[$ind]' from regcomp.sym line $. is not an existing regop, and will be aliased to $name[$ind]\n" + # if -t STDERR; + $type_alias{$type[$ind]}= $name[$ind]; + } + $longest_name_length = length $name[$ind] if length $name[$ind] > $longest_name_length; ++$ind; @@ -148,10 +163,15 @@ EOP -$width, REGMATCH_STATE_MAX => $tot - 1 ; - +my %rev_type_alias= reverse %type_alias; for ($ind=0; $ind < $lastregop ; ++$ind) { printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", -$width, $name[$ind], $ind, $ind, $rest[$ind]; + if (defined(my $alias= $rev_type_alias{$name[$ind]})) { + printf $out "#define\t%*s\t%d\t/* %#04x %s */\n", + -$width, $alias, $ind, $ind, "type alias"; + } + } print $out "\t/* ------------ States ------------- */\n"; for ( ; $ind < $tot ; $ind++) { diff --git a/regen/regen_lib.pl b/regen/regen_lib.pl index b64e0b0..463b5cd 100644 --- a/regen/regen_lib.pl +++ b/regen/regen_lib.pl @@ -224,4 +224,24 @@ sub wrap { Text::Wrap::wrap(@_); } +# return the perl version as defined in patchlevel.h. +# (we may be being run by another perl, so $] won't be right) +# return e.g. (5, 14, 3, "5.014003") + +sub perl_version { + my $plh = 'patchlevel.h'; + open my $fh, "<", $plh or die "can't open '$plh': $!\n"; + my ($v1,$v2,$v3); + while (<$fh>) { + $v1 = $1 if /PERL_REVISION\s+(\d+)/; + $v2 = $1 if /PERL_VERSION\s+(\d+)/; + $v3 = $1 if /PERL_SUBVERSION\s+(\d+)/; + } + die "can't locate PERL_REVISION in '$plh'" unless defined $v1; + die "can't locate PERL_VERSION in '$plh'" unless defined $v2; + die "can't locate PERL_SUBVERSION in '$plh'" unless defined $v3; + return ($v1,$v2,$v3, sprintf("%d.%03d%03d", $v1, $v2, $v3)); +} + + 1; diff --git a/regen/unicode_constants.pl b/regen/unicode_constants.pl index 81a609b..c81f767 100644 --- a/regen/unicode_constants.pl +++ b/regen/unicode_constants.pl @@ -147,6 +147,13 @@ foreach my $charset (get_supported_code_pages()) { } printf $out_fh "# define %s%s %s /* U+%04X */\n", $name, $suffix, $str, $U_cp; } + + my $max_PRINT_A = 0; + for my $i (0x20 .. 0x7E) { + $max_PRINT_A = $a2n[$i] if $a2n[$i] > $max_PRINT_A; + } + printf $out_fh "# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0x%02X /* The max code point that isPRINT_A */\n", $max_PRINT_A; + print $out_fh "\n" . get_conditional_compile_line_end(); } @@ -178,6 +185,8 @@ NBSP string DEL native CR native LF native +VT native +ESC native U+00DF native U+00E5 native U+00C5 native diff --git a/regexec.c b/regexec.c index 33fb5da..9e5872c 100644 --- a/regexec.c +++ b/regexec.c @@ -772,7 +772,7 @@ Perl_re_intuit_start(pTHX_ * be too fiddly (e.g. REXEC_IGNOREPOS). */ if ( strpos != strbeg - && (prog->intflags & (PREGf_ANCH_BOL|PREGf_ANCH_SBOL))) + && (prog->intflags & PREGf_ANCH_SBOL)) { DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " Not at start...\n")); @@ -896,7 +896,7 @@ Perl_re_intuit_start(pTHX_ /* If the regex is absolutely anchored to either the start of the - * string (BOL,SBOL) or to pos() (ANCH_GPOS), then + * string (SBOL) or to pos() (ANCH_GPOS), then * check_offset_max represents an upper bound on the string where * the substr could start. For the ANCH_GPOS case, we assume that * the caller of intuit will have already set strpos to @@ -2637,7 +2637,6 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, magic belonging to this SV. Not newSVsv, either, as it does not COW. */ - assert(!IS_PADGV(sv)); reginfo->sv = newSV(0); SvSetSV_nosteal(reginfo->sv, sv); SAVEFREESV(reginfo->sv); @@ -2715,7 +2714,7 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend, } /* Simplest case: anchored match need be tried only once. */ - /* [unless only anchor is BOL and multiline is set] */ + /* [unless only anchor is MBOL - implying multiline is set] */ if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) { if (s == startpos && regtry(reginfo, &s)) goto got_it; @@ -4013,8 +4012,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS)); switch (state_num) { - case BOL: /* /^../ */ - case SBOL: /* /^../s */ + case SBOL: /* /^../ and /\A../ */ if (locinput == reginfo->strbeg) break; sayNO; @@ -4052,9 +4050,7 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog) sayNO; break; - case EOL: /* /..$/ */ - /* FALLTHROUGH */ - case SEOL: /* /..$/s */ + case SEOL: /* /..$/ */ if (!NEXTCHR_IS_EOS && nextchr != '\n') sayNO; if (reginfo->strend - locinput > 1) @@ -7630,121 +7626,9 @@ Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, *altsvp = NULL; } - return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL)); + return newSVsv(_get_regclass_nonbitmap_data(prog, node, doinit, listsvp, NULL, NULL)); } -SV * -Perl__get_regclass_nonbitmap_data(pTHX_ const regexp *prog, - const regnode* node, - bool doinit, - SV** listsvp, - SV** only_utf8_locale_ptr) -{ - /* For internal core use only. - * Returns the swash for the input 'node' in the regex 'prog'. - * If is 'true', will attempt to create the swash if not already - * done. - * If is non-null, will return the printable contents of the - * swash. This can be used to get debugging information even before the - * swash exists, by calling this function with 'doinit' set to false, in - * which case the components that will be used to eventually create the - * swash are returned (in a printable form). - * Tied intimately to how regcomp.c sets up the data structure */ - - SV *sw = NULL; - SV *si = NULL; /* Input swash initialization string */ - SV* invlist = NULL; - - RXi_GET_DECL(prog,progi); - const struct reg_data * const data = prog ? progi->data : NULL; - - PERL_ARGS_ASSERT__GET_REGCLASS_NONBITMAP_DATA; - - assert(ANYOF_FLAGS(node) - & (ANYOF_UTF8|ANYOF_NONBITMAP_NON_UTF8|ANYOF_LOC_FOLD)); - - if (data && data->count) { - const U32 n = ARG(node); - - if (data->what[n] == 's') { - SV * const rv = MUTABLE_SV(data->data[n]); - AV * const av = MUTABLE_AV(SvRV(rv)); - SV **const ary = AvARRAY(av); - U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST; - - si = *ary; /* ary[0] = the string to initialize the swash with */ - - /* Elements 3 and 4 are either both present or both absent. [3] is - * any inversion list generated at compile time; [4] indicates if - * that inversion list has any user-defined properties in it. */ - if (av_tindex(av) >= 2) { - if (only_utf8_locale_ptr - && ary[2] - && ary[2] != &PL_sv_undef) - { - *only_utf8_locale_ptr = ary[2]; - } - else { - assert(only_utf8_locale_ptr); - *only_utf8_locale_ptr = NULL; - } - - if (av_tindex(av) >= 3) { - invlist = ary[3]; - if (SvUV(ary[4])) { - swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY; - } - } - else { - invlist = NULL; - } - } - - /* Element [1] is reserved for the set-up swash. If already there, - * return it; if not, create it and store it there */ - if (ary[1] && SvROK(ary[1])) { - sw = ary[1]; - } - else if (doinit && ((si && si != &PL_sv_undef) - || (invlist && invlist != &PL_sv_undef))) { - assert(si); - sw = _core_swash_init("utf8", /* the utf8 package */ - "", /* nameless */ - si, - 1, /* binary */ - 0, /* not from tr/// */ - invlist, - &swash_init_flags); - (void)av_store(av, 1, sw); - } - } - } - - /* If requested, return a printable version of what this swash matches */ - if (listsvp) { - SV* matches_string = newSVpvs(""); - - /* The swash should be used, if possible, to get the data, as it - * contains the resolved data. But this function can be called at - * compile-time, before everything gets resolved, in which case we - * return the currently best available information, which is the string - * that will eventually be used to do that resolving, 'si' */ - if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL) - && (si && si != &PL_sv_undef)) - { - sv_catsv(matches_string, si); - } - - /* Add the inversion list to whatever we have. This may have come from - * the swash, or from an input parameter */ - if (invlist) { - sv_catsv(matches_string, _invlist_contents(invlist)); - } - *listsvp = matches_string; - } - - return sw; -} #endif /* !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION) */ /* @@ -7787,22 +7671,25 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const } /* If this character is potentially in the bitmap, check it */ - if (c < 256) { + if (c < NUM_ANYOF_CODE_POINTS) { if (ANYOF_BITMAP_TEST(n, c)) match = TRUE; - else if (flags & ANYOF_NON_UTF8_NON_ASCII_ALL - && ! utf8_target - && ! isASCII(c)) + else if ((flags & ANYOF_MATCHES_ALL_NON_UTF8_NON_ASCII) + && ! utf8_target + && ! isASCII(c)) { match = TRUE; } else if (flags & ANYOF_LOCALE_FLAGS) { - if (flags & ANYOF_LOC_FOLD) { - if (ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) { - match = TRUE; - } + if ((flags & ANYOF_LOC_FOLD) + && c < 256 + && ANYOF_BITMAP_TEST(n, PL_fold_locale[c])) + { + match = TRUE; } - if (! match && ANYOF_POSIXL_TEST_ANY_SET(n)) { + else if (ANYOF_POSIXL_TEST_ANY_SET(n) + && c < 256 + ) { /* The data structure is arranged so bits 0, 2, 4, ... are set * if the class includes the Posix character class given by @@ -7855,18 +7742,20 @@ S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const /* If the bitmap didn't (or couldn't) match, and something outside the * bitmap could match, try that. */ if (!match) { - if (c >= 256 && (flags & ANYOF_ABOVE_LATIN1_ALL)) { - match = TRUE; /* Everything above 255 matches */ + if (c >= NUM_ANYOF_CODE_POINTS + && (flags & ANYOF_MATCHES_ALL_ABOVE_BITMAP)) + { + match = TRUE; /* Everything above the bitmap matches */ } - else if ((flags & ANYOF_NONBITMAP_NON_UTF8) - || (utf8_target && (flags & ANYOF_UTF8)) + else if ((flags & ANYOF_HAS_NONBITMAP_NON_UTF8_MATCHES) + || (utf8_target && (flags & ANYOF_HAS_UTF8_NONBITMAP_MATCHES)) || ((flags & ANYOF_LOC_FOLD) && IN_UTF8_CTYPE_LOCALE - && ARG(n) != ANYOF_NONBITMAP_EMPTY)) + && ARG(n) != ANYOF_ONLY_HAS_BITMAP)) { SV* only_utf8_locale = NULL; SV * const sw = _get_regclass_nonbitmap_data(prog, n, TRUE, 0, - &only_utf8_locale); + &only_utf8_locale, NULL); if (sw) { U8 utf8_buffer[2]; U8 * utf8_p; diff --git a/regnodes.h b/regnodes.h index 43ec681..133ad65 100644 --- a/regnodes.h +++ b/regnodes.h @@ -6,103 +6,103 @@ /* Regops and State definitions */ -#define REGNODE_MAX 93 -#define REGMATCH_STATE_MAX 133 +#define REGNODE_MAX 91 +#define REGMATCH_STATE_MAX 131 #define END 0 /* 0000 End of program. */ #define SUCCEED 1 /* 0x01 Return from a subroutine, basically. */ -#define BOL 2 /* 0x02 Match "" at beginning of line. */ -#define MBOL 3 /* 0x03 Same, assuming multiline. */ -#define SBOL 4 /* 0x04 Same, assuming singleline. */ -#define EOS 5 /* 0x05 Match "" at end of string. */ -#define EOL 6 /* 0x06 Match "" at end of line. */ -#define MEOL 7 /* 0x07 Same, assuming multiline. */ -#define SEOL 8 /* 0x08 Same, assuming singleline. */ -#define BOUND 9 /* 0x09 Match "" at any word boundary using native charset rules for non-utf8 */ -#define BOUNDL 10 /* 0x0a Match "" at any locale word boundary */ -#define BOUNDU 11 /* 0x0b Match "" at any word boundary using Unicode rules */ -#define BOUNDA 12 /* 0x0c Match "" at any word boundary using ASCII rules */ -#define NBOUND 13 /* 0x0d Match "" at any word non-boundary using native charset rules for non-utf8 */ -#define NBOUNDL 14 /* 0x0e Match "" at any locale word non-boundary */ -#define NBOUNDU 15 /* 0x0f Match "" at any word non-boundary using Unicode rules */ -#define NBOUNDA 16 /* 0x10 Match "" at any word non-boundary using ASCII rules */ -#define GPOS 17 /* 0x11 Matches where last m//g left off. */ -#define REG_ANY 18 /* 0x12 Match any one character (except newline). */ -#define SANY 19 /* 0x13 Match any one character. */ -#define CANY 20 /* 0x14 Match any one byte. */ -#define ANYOF 21 /* 0x15 Match character in (or not in) this class, single char match only */ -#define POSIXD 22 /* 0x16 Some [[:class:]] under /d; the FLAGS field gives which one */ -#define POSIXL 23 /* 0x17 Some [[:class:]] under /l; the FLAGS field gives which one */ -#define POSIXU 24 /* 0x18 Some [[:class:]] under /u; the FLAGS field gives which one */ -#define POSIXA 25 /* 0x19 Some [[:class:]] under /a; the FLAGS field gives which one */ -#define NPOSIXD 26 /* 0x1a complement of POSIXD, [[:^class:]] */ -#define NPOSIXL 27 /* 0x1b complement of POSIXL, [[:^class:]] */ -#define NPOSIXU 28 /* 0x1c complement of POSIXU, [[:^class:]] */ -#define NPOSIXA 29 /* 0x1d complement of POSIXA, [[:^class:]] */ -#define CLUMP 30 /* 0x1e Match any extended grapheme cluster sequence */ -#define BRANCH 31 /* 0x1f Match this alternative, or the next... */ -#define BACK 32 /* 0x20 Match "", "next" ptr points backward. */ -#define EXACT 33 /* 0x21 Match this string (preceded by length). */ -#define EXACTF 34 /* 0x22 Match this non-UTF-8 string (not guaranteed to be folded) using /id rules (w/len). */ -#define EXACTFL 35 /* 0x23 Match this string (not guaranteed to be folded) using /il rules (w/len). */ -#define EXACTFU 36 /* 0x24 Match this string (folded iff in UTF-8, length in folding doesn't change if not in UTF-8) using /iu rules (w/len). */ -#define EXACTFA 37 /* 0x25 Match this string (not guaranteed to be folded) using /iaa rules (w/len). */ -#define EXACTFU_SS 38 /* 0x26 Match this string (folded iff in UTF-8, length in folding may change even if not in UTF-8) using /iu rules (w/len). */ -#define EXACTFA_NO_TRIE 39 /* 0x27 Match this string (which is not trie-able; not guaranteed to be folded) using /iaa rules (w/len). */ -#define NOTHING 40 /* 0x28 Match empty string. */ -#define TAIL 41 /* 0x29 Match empty string. Can jump here from outside. */ -#define STAR 42 /* 0x2a Match this (simple) thing 0 or more times. */ -#define PLUS 43 /* 0x2b Match this (simple) thing 1 or more times. */ -#define CURLY 44 /* 0x2c Match this simple thing {n,m} times. */ -#define CURLYN 45 /* 0x2d Capture next-after-this simple thing */ -#define CURLYM 46 /* 0x2e Capture this medium-complex thing {n,m} times. */ -#define CURLYX 47 /* 0x2f Match this complex thing {n,m} times. */ -#define WHILEM 48 /* 0x30 Do curly processing and see if rest matches. */ -#define OPEN 49 /* 0x31 Mark this point in input as start of #n. */ -#define CLOSE 50 /* 0x32 Analogous to OPEN. */ -#define REF 51 /* 0x33 Match some already matched string */ -#define REFF 52 /* 0x34 Match already matched string, folded using native charset rules for non-utf8 */ -#define REFFL 53 /* 0x35 Match already matched string, folded in loc. */ -#define REFFU 54 /* 0x36 Match already matched string, folded using unicode rules for non-utf8 */ -#define REFFA 55 /* 0x37 Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */ -#define NREF 56 /* 0x38 Match some already matched string */ -#define NREFF 57 /* 0x39 Match already matched string, folded using native charset rules for non-utf8 */ -#define NREFFL 58 /* 0x3a Match already matched string, folded in loc. */ -#define NREFFU 59 /* 0x3b Match already matched string, folded using unicode rules for non-utf8 */ -#define NREFFA 60 /* 0x3c Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */ +#define SBOL 2 /* 0x02 Match "" at beginning of line: /^/, /\A/ */ +#define BOL 2 /* 0x02 type alias */ +#define MBOL 3 /* 0x03 Same, assuming multiline: /^/m */ +#define SEOL 4 /* 0x04 Match "" at end of line: /$/ */ +#define EOL 4 /* 0x04 type alias */ +#define MEOL 5 /* 0x05 Same, assuming multiline: /$/m */ +#define EOS 6 /* 0x06 Match "" at end of string: /\z/ */ +#define GPOS 7 /* 0x07 Matches where last m//g left off. */ +#define BOUND 8 /* 0x08 Match "" at any word boundary using native charset rules for non-utf8 */ +#define BOUNDL 9 /* 0x09 Match "" at any locale word boundary */ +#define BOUNDU 10 /* 0x0a Match "" at any word boundary using Unicode rules */ +#define BOUNDA 11 /* 0x0b Match "" at any word boundary using ASCII rules */ +#define NBOUND 12 /* 0x0c Match "" at any word non-boundary using native charset rules for non-utf8 */ +#define NBOUNDL 13 /* 0x0d Match "" at any locale word non-boundary */ +#define NBOUNDU 14 /* 0x0e Match "" at any word non-boundary using Unicode rules */ +#define NBOUNDA 15 /* 0x0f Match "" at any word non-boundary using ASCII rules */ +#define REG_ANY 16 /* 0x10 Match any one character (except newline). */ +#define SANY 17 /* 0x11 Match any one character. */ +#define CANY 18 /* 0x12 Match any one byte. */ +#define ANYOF 19 /* 0x13 Match character in (or not in) this class, single char match only */ +#define POSIXD 20 /* 0x14 Some [[:class:]] under /d; the FLAGS field gives which one */ +#define POSIXL 21 /* 0x15 Some [[:class:]] under /l; the FLAGS field gives which one */ +#define POSIXU 22 /* 0x16 Some [[:class:]] under /u; the FLAGS field gives which one */ +#define POSIXA 23 /* 0x17 Some [[:class:]] under /a; the FLAGS field gives which one */ +#define NPOSIXD 24 /* 0x18 complement of POSIXD, [[:^class:]] */ +#define NPOSIXL 25 /* 0x19 complement of POSIXL, [[:^class:]] */ +#define NPOSIXU 26 /* 0x1a complement of POSIXU, [[:^class:]] */ +#define NPOSIXA 27 /* 0x1b complement of POSIXA, [[:^class:]] */ +#define CLUMP 28 /* 0x1c Match any extended grapheme cluster sequence */ +#define BRANCH 29 /* 0x1d Match this alternative, or the next... */ +#define BACK 30 /* 0x1e Match "", "next" ptr points backward. */ +#define EXACT 31 /* 0x1f Match this string (preceded by length). */ +#define EXACTF 32 /* 0x20 Match this non-UTF-8 string (not guaranteed to be folded) using /id rules (w/len). */ +#define EXACTFL 33 /* 0x21 Match this string (not guaranteed to be folded) using /il rules (w/len). */ +#define EXACTFU 34 /* 0x22 Match this string (folded iff in UTF-8, length in folding doesn't change if not in UTF-8) using /iu rules (w/len). */ +#define EXACTFA 35 /* 0x23 Match this string (not guaranteed to be folded) using /iaa rules (w/len). */ +#define EXACTFU_SS 36 /* 0x24 Match this string (folded iff in UTF-8, length in folding may change even if not in UTF-8) using /iu rules (w/len). */ +#define EXACTFA_NO_TRIE 37 /* 0x25 Match this string (which is not trie-able; not guaranteed to be folded) using /iaa rules (w/len). */ +#define NOTHING 38 /* 0x26 Match empty string. */ +#define TAIL 39 /* 0x27 Match empty string. Can jump here from outside. */ +#define STAR 40 /* 0x28 Match this (simple) thing 0 or more times. */ +#define PLUS 41 /* 0x29 Match this (simple) thing 1 or more times. */ +#define CURLY 42 /* 0x2a Match this simple thing {n,m} times. */ +#define CURLYN 43 /* 0x2b Capture next-after-this simple thing */ +#define CURLYM 44 /* 0x2c Capture this medium-complex thing {n,m} times. */ +#define CURLYX 45 /* 0x2d Match this complex thing {n,m} times. */ +#define WHILEM 46 /* 0x2e Do curly processing and see if rest matches. */ +#define OPEN 47 /* 0x2f Mark this point in input as start of #n. */ +#define CLOSE 48 /* 0x30 Analogous to OPEN. */ +#define REF 49 /* 0x31 Match some already matched string */ +#define REFF 50 /* 0x32 Match already matched string, folded using native charset rules for non-utf8 */ +#define REFFL 51 /* 0x33 Match already matched string, folded in loc. */ +#define REFFU 52 /* 0x34 Match already matched string, folded using unicode rules for non-utf8 */ +#define REFFA 53 /* 0x35 Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */ +#define NREF 54 /* 0x36 Match some already matched string */ +#define NREFF 55 /* 0x37 Match already matched string, folded using native charset rules for non-utf8 */ +#define NREFFL 56 /* 0x38 Match already matched string, folded in loc. */ +#define NREFFU 57 /* 0x39 Match already matched string, folded using unicode rules for non-utf8 */ +#define NREFFA 58 /* 0x3a Match already matched string, folded using unicode rules for non-utf8, no mixing ASCII, non-ASCII */ +#define LONGJMP 59 /* 0x3b Jump far away. */ +#define BRANCHJ 60 /* 0x3c BRANCH with long offset. */ #define IFMATCH 61 /* 0x3d Succeeds if the following matches. */ #define UNLESSM 62 /* 0x3e Fails if the following matches. */ #define SUSPEND 63 /* 0x3f "Independent" sub-RE. */ #define IFTHEN 64 /* 0x40 Switch, should be preceded by switcher. */ #define GROUPP 65 /* 0x41 Whether the group matched. */ -#define LONGJMP 66 /* 0x42 Jump far away. */ -#define BRANCHJ 67 /* 0x43 BRANCH with long offset. */ -#define EVAL 68 /* 0x44 Execute some Perl code. */ -#define MINMOD 69 /* 0x45 Next operator is not greedy. */ -#define LOGICAL 70 /* 0x46 Next opcode should set the flag only. */ -#define RENUM 71 /* 0x47 Group with independently numbered parens. */ -#define TRIE 72 /* 0x48 Match many EXACT(F[ALU]?)? at once. flags==type */ -#define TRIEC 73 /* 0x49 Same as TRIE, but with embedded charclass data */ -#define AHOCORASICK 74 /* 0x4a Aho Corasick stclass. flags==type */ -#define AHOCORASICKC 75 /* 0x4b Same as AHOCORASICK, but with embedded charclass data */ -#define GOSUB 76 /* 0x4c recurse to paren arg1 at (signed) ofs arg2 */ -#define GOSTART 77 /* 0x4d recurse to start of pattern */ -#define NGROUPP 78 /* 0x4e Whether the group matched. */ -#define INSUBP 79 /* 0x4f Whether we are in a specific recurse. */ -#define DEFINEP 80 /* 0x50 Never execute directly. */ -#define ENDLIKE 81 /* 0x51 Used only for the type field of verbs */ -#define OPFAIL 82 /* 0x52 Same as (?!) */ -#define ACCEPT 83 /* 0x53 Accepts the current matched string. */ -#define VERB 84 /* 0x54 Used only for the type field of verbs */ -#define PRUNE 85 /* 0x55 Pattern fails at this startpoint if no-backtracking through this */ -#define MARKPOINT 86 /* 0x56 Push the current location for rollback by cut. */ -#define SKIP 87 /* 0x57 On failure skip forward (to the mark) before retrying */ -#define COMMIT 88 /* 0x58 Pattern fails outright if backtracking through this */ -#define CUTGROUP 89 /* 0x59 On failure go to the next alternation in the group */ -#define KEEPS 90 /* 0x5a $& begins here. */ -#define LNBREAK 91 /* 0x5b generic newline pattern */ -#define OPTIMIZED 92 /* 0x5c Placeholder for dump. */ -#define PSEUDO 93 /* 0x5d Pseudo opcode for internal use. */ +#define EVAL 66 /* 0x42 Execute some Perl code. */ +#define MINMOD 67 /* 0x43 Next operator is not greedy. */ +#define LOGICAL 68 /* 0x44 Next opcode should set the flag only. */ +#define RENUM 69 /* 0x45 Group with independently numbered parens. */ +#define TRIE 70 /* 0x46 Match many EXACT(F[ALU]?)? at once. flags==type */ +#define TRIEC 71 /* 0x47 Same as TRIE, but with embedded charclass data */ +#define AHOCORASICK 72 /* 0x48 Aho Corasick stclass. flags==type */ +#define AHOCORASICKC 73 /* 0x49 Same as AHOCORASICK, but with embedded charclass data */ +#define GOSUB 74 /* 0x4a recurse to paren arg1 at (signed) ofs arg2 */ +#define GOSTART 75 /* 0x4b recurse to start of pattern */ +#define NGROUPP 76 /* 0x4c Whether the group matched. */ +#define INSUBP 77 /* 0x4d Whether we are in a specific recurse. */ +#define DEFINEP 78 /* 0x4e Never execute directly. */ +#define ENDLIKE 79 /* 0x4f Used only for the type field of verbs */ +#define OPFAIL 80 /* 0x50 Same as (?!) */ +#define ACCEPT 81 /* 0x51 Accepts the current matched string. */ +#define VERB 82 /* 0x52 Used only for the type field of verbs */ +#define PRUNE 83 /* 0x53 Pattern fails at this startpoint if no-backtracking through this */ +#define MARKPOINT 84 /* 0x54 Push the current location for rollback by cut. */ +#define SKIP 85 /* 0x55 On failure skip forward (to the mark) before retrying */ +#define COMMIT 86 /* 0x56 Pattern fails outright if backtracking through this */ +#define CUTGROUP 87 /* 0x57 On failure go to the next alternation in the group */ +#define KEEPS 88 /* 0x58 $& begins here. */ +#define LNBREAK 89 /* 0x59 generic newline pattern */ +#define OPTIMIZED 90 /* 0x5a Placeholder for dump. */ +#define PSEUDO 91 /* 0x5b Pseudo opcode for internal use. */ /* ------------ States ------------- */ #define TRIE_next (REGNODE_MAX + 1) /* state for TRIE */ #define TRIE_next_fail (REGNODE_MAX + 2) /* state for TRIE */ @@ -153,13 +153,12 @@ EXTCONST U8 PL_regkind[]; EXTCONST U8 PL_regkind[] = { END, /* END */ END, /* SUCCEED */ - BOL, /* BOL */ - BOL, /* MBOL */ BOL, /* SBOL */ - EOL, /* EOS */ - EOL, /* EOL */ - EOL, /* MEOL */ + BOL, /* MBOL */ EOL, /* SEOL */ + EOL, /* MEOL */ + EOL, /* EOS */ + GPOS, /* GPOS */ BOUND, /* BOUND */ BOUND, /* BOUNDL */ BOUND, /* BOUNDU */ @@ -168,7 +167,6 @@ EXTCONST U8 PL_regkind[] = { NBOUND, /* NBOUNDL */ NBOUND, /* NBOUNDU */ NBOUND, /* NBOUNDA */ - GPOS, /* GPOS */ REG_ANY, /* REG_ANY */ REG_ANY, /* SANY */ REG_ANY, /* CANY */ @@ -212,13 +210,13 @@ EXTCONST U8 PL_regkind[] = { REF, /* NREFFL */ REF, /* NREFFU */ REF, /* NREFFA */ + LONGJMP, /* LONGJMP */ + BRANCHJ, /* BRANCHJ */ BRANCHJ, /* IFMATCH */ BRANCHJ, /* UNLESSM */ BRANCHJ, /* SUSPEND */ BRANCHJ, /* IFTHEN */ GROUPP, /* GROUPP */ - LONGJMP, /* LONGJMP */ - BRANCHJ, /* BRANCHJ */ EVAL, /* EVAL */ MINMOD, /* MINMOD */ LOGICAL, /* LOGICAL */ @@ -295,13 +293,12 @@ EXTCONST U8 PL_regkind[] = { static const U8 regarglen[] = { 0, /* END */ 0, /* SUCCEED */ - 0, /* BOL */ - 0, /* MBOL */ 0, /* SBOL */ - 0, /* EOS */ - 0, /* EOL */ - 0, /* MEOL */ + 0, /* MBOL */ 0, /* SEOL */ + 0, /* MEOL */ + 0, /* EOS */ + 0, /* GPOS */ 0, /* BOUND */ 0, /* BOUNDL */ 0, /* BOUNDU */ @@ -310,7 +307,6 @@ static const U8 regarglen[] = { 0, /* NBOUNDL */ 0, /* NBOUNDU */ 0, /* NBOUNDA */ - 0, /* GPOS */ 0, /* REG_ANY */ 0, /* SANY */ 0, /* CANY */ @@ -354,13 +350,13 @@ static const U8 regarglen[] = { EXTRA_SIZE(struct regnode_1), /* NREFFL */ EXTRA_SIZE(struct regnode_1), /* NREFFU */ EXTRA_SIZE(struct regnode_1), /* NREFFA */ + EXTRA_SIZE(struct regnode_1), /* LONGJMP */ + EXTRA_SIZE(struct regnode_1), /* BRANCHJ */ EXTRA_SIZE(struct regnode_1), /* IFMATCH */ EXTRA_SIZE(struct regnode_1), /* UNLESSM */ EXTRA_SIZE(struct regnode_1), /* SUSPEND */ EXTRA_SIZE(struct regnode_1), /* IFTHEN */ EXTRA_SIZE(struct regnode_1), /* GROUPP */ - EXTRA_SIZE(struct regnode_1), /* LONGJMP */ - EXTRA_SIZE(struct regnode_1), /* BRANCHJ */ EXTRA_SIZE(struct regnode_1), /* EVAL */ 0, /* MINMOD */ 0, /* LOGICAL */ @@ -394,13 +390,12 @@ static const U8 regarglen[] = { static const char reg_off_by_arg[] = { 0, /* END */ 0, /* SUCCEED */ - 0, /* BOL */ - 0, /* MBOL */ 0, /* SBOL */ - 0, /* EOS */ - 0, /* EOL */ - 0, /* MEOL */ + 0, /* MBOL */ 0, /* SEOL */ + 0, /* MEOL */ + 0, /* EOS */ + 0, /* GPOS */ 0, /* BOUND */ 0, /* BOUNDL */ 0, /* BOUNDU */ @@ -409,7 +404,6 @@ static const char reg_off_by_arg[] = { 0, /* NBOUNDL */ 0, /* NBOUNDU */ 0, /* NBOUNDA */ - 0, /* GPOS */ 0, /* REG_ANY */ 0, /* SANY */ 0, /* CANY */ @@ -453,13 +447,13 @@ static const char reg_off_by_arg[] = { 0, /* NREFFL */ 0, /* NREFFU */ 0, /* NREFFA */ + 1, /* LONGJMP */ + 1, /* BRANCHJ */ 2, /* IFMATCH */ 2, /* UNLESSM */ 1, /* SUSPEND */ 1, /* IFTHEN */ 0, /* GROUPP */ - 1, /* LONGJMP */ - 1, /* BRANCHJ */ 0, /* EVAL */ 0, /* MINMOD */ 0, /* LOGICAL */ @@ -498,98 +492,96 @@ EXTCONST char * PL_reg_name[]; EXTCONST char * const PL_reg_name[] = { "END", /* 0000 */ "SUCCEED", /* 0x01 */ - "BOL", /* 0x02 */ + "SBOL", /* 0x02 */ "MBOL", /* 0x03 */ - "SBOL", /* 0x04 */ - "EOS", /* 0x05 */ - "EOL", /* 0x06 */ - "MEOL", /* 0x07 */ - "SEOL", /* 0x08 */ - "BOUND", /* 0x09 */ - "BOUNDL", /* 0x0a */ - "BOUNDU", /* 0x0b */ - "BOUNDA", /* 0x0c */ - "NBOUND", /* 0x0d */ - "NBOUNDL", /* 0x0e */ - "NBOUNDU", /* 0x0f */ - "NBOUNDA", /* 0x10 */ - "GPOS", /* 0x11 */ - "REG_ANY", /* 0x12 */ - "SANY", /* 0x13 */ - "CANY", /* 0x14 */ - "ANYOF", /* 0x15 */ - "POSIXD", /* 0x16 */ - "POSIXL", /* 0x17 */ - "POSIXU", /* 0x18 */ - "POSIXA", /* 0x19 */ - "NPOSIXD", /* 0x1a */ - "NPOSIXL", /* 0x1b */ - "NPOSIXU", /* 0x1c */ - "NPOSIXA", /* 0x1d */ - "CLUMP", /* 0x1e */ - "BRANCH", /* 0x1f */ - "BACK", /* 0x20 */ - "EXACT", /* 0x21 */ - "EXACTF", /* 0x22 */ - "EXACTFL", /* 0x23 */ - "EXACTFU", /* 0x24 */ - "EXACTFA", /* 0x25 */ - "EXACTFU_SS", /* 0x26 */ - "EXACTFA_NO_TRIE", /* 0x27 */ - "NOTHING", /* 0x28 */ - "TAIL", /* 0x29 */ - "STAR", /* 0x2a */ - "PLUS", /* 0x2b */ - "CURLY", /* 0x2c */ - "CURLYN", /* 0x2d */ - "CURLYM", /* 0x2e */ - "CURLYX", /* 0x2f */ - "WHILEM", /* 0x30 */ - "OPEN", /* 0x31 */ - "CLOSE", /* 0x32 */ - "REF", /* 0x33 */ - "REFF", /* 0x34 */ - "REFFL", /* 0x35 */ - "REFFU", /* 0x36 */ - "REFFA", /* 0x37 */ - "NREF", /* 0x38 */ - "NREFF", /* 0x39 */ - "NREFFL", /* 0x3a */ - "NREFFU", /* 0x3b */ - "NREFFA", /* 0x3c */ + "SEOL", /* 0x04 */ + "MEOL", /* 0x05 */ + "EOS", /* 0x06 */ + "GPOS", /* 0x07 */ + "BOUND", /* 0x08 */ + "BOUNDL", /* 0x09 */ + "BOUNDU", /* 0x0a */ + "BOUNDA", /* 0x0b */ + "NBOUND", /* 0x0c */ + "NBOUNDL", /* 0x0d */ + "NBOUNDU", /* 0x0e */ + "NBOUNDA", /* 0x0f */ + "REG_ANY", /* 0x10 */ + "SANY", /* 0x11 */ + "CANY", /* 0x12 */ + "ANYOF", /* 0x13 */ + "POSIXD", /* 0x14 */ + "POSIXL", /* 0x15 */ + "POSIXU", /* 0x16 */ + "POSIXA", /* 0x17 */ + "NPOSIXD", /* 0x18 */ + "NPOSIXL", /* 0x19 */ + "NPOSIXU", /* 0x1a */ + "NPOSIXA", /* 0x1b */ + "CLUMP", /* 0x1c */ + "BRANCH", /* 0x1d */ + "BACK", /* 0x1e */ + "EXACT", /* 0x1f */ + "EXACTF", /* 0x20 */ + "EXACTFL", /* 0x21 */ + "EXACTFU", /* 0x22 */ + "EXACTFA", /* 0x23 */ + "EXACTFU_SS", /* 0x24 */ + "EXACTFA_NO_TRIE", /* 0x25 */ + "NOTHING", /* 0x26 */ + "TAIL", /* 0x27 */ + "STAR", /* 0x28 */ + "PLUS", /* 0x29 */ + "CURLY", /* 0x2a */ + "CURLYN", /* 0x2b */ + "CURLYM", /* 0x2c */ + "CURLYX", /* 0x2d */ + "WHILEM", /* 0x2e */ + "OPEN", /* 0x2f */ + "CLOSE", /* 0x30 */ + "REF", /* 0x31 */ + "REFF", /* 0x32 */ + "REFFL", /* 0x33 */ + "REFFU", /* 0x34 */ + "REFFA", /* 0x35 */ + "NREF", /* 0x36 */ + "NREFF", /* 0x37 */ + "NREFFL", /* 0x38 */ + "NREFFU", /* 0x39 */ + "NREFFA", /* 0x3a */ + "LONGJMP", /* 0x3b */ + "BRANCHJ", /* 0x3c */ "IFMATCH", /* 0x3d */ "UNLESSM", /* 0x3e */ "SUSPEND", /* 0x3f */ "IFTHEN", /* 0x40 */ "GROUPP", /* 0x41 */ - "LONGJMP", /* 0x42 */ - "BRANCHJ", /* 0x43 */ - "EVAL", /* 0x44 */ - "MINMOD", /* 0x45 */ - "LOGICAL", /* 0x46 */ - "RENUM", /* 0x47 */ - "TRIE", /* 0x48 */ - "TRIEC", /* 0x49 */ - "AHOCORASICK", /* 0x4a */ - "AHOCORASICKC", /* 0x4b */ - "GOSUB", /* 0x4c */ - "GOSTART", /* 0x4d */ - "NGROUPP", /* 0x4e */ - "INSUBP", /* 0x4f */ - "DEFINEP", /* 0x50 */ - "ENDLIKE", /* 0x51 */ - "OPFAIL", /* 0x52 */ - "ACCEPT", /* 0x53 */ - "VERB", /* 0x54 */ - "PRUNE", /* 0x55 */ - "MARKPOINT", /* 0x56 */ - "SKIP", /* 0x57 */ - "COMMIT", /* 0x58 */ - "CUTGROUP", /* 0x59 */ - "KEEPS", /* 0x5a */ - "LNBREAK", /* 0x5b */ - "OPTIMIZED", /* 0x5c */ - "PSEUDO", /* 0x5d */ + "EVAL", /* 0x42 */ + "MINMOD", /* 0x43 */ + "LOGICAL", /* 0x44 */ + "RENUM", /* 0x45 */ + "TRIE", /* 0x46 */ + "TRIEC", /* 0x47 */ + "AHOCORASICK", /* 0x48 */ + "AHOCORASICKC", /* 0x49 */ + "GOSUB", /* 0x4a */ + "GOSTART", /* 0x4b */ + "NGROUPP", /* 0x4c */ + "INSUBP", /* 0x4d */ + "DEFINEP", /* 0x4e */ + "ENDLIKE", /* 0x4f */ + "OPFAIL", /* 0x50 */ + "ACCEPT", /* 0x51 */ + "VERB", /* 0x52 */ + "PRUNE", /* 0x53 */ + "MARKPOINT", /* 0x54 */ + "SKIP", /* 0x55 */ + "COMMIT", /* 0x56 */ + "CUTGROUP", /* 0x57 */ + "KEEPS", /* 0x58 */ + "LNBREAK", /* 0x59 */ + "OPTIMIZED", /* 0x5a */ + "PSEUDO", /* 0x5b */ /* ------------ States ------------- */ "TRIE_next", /* REGNODE_MAX +0x01 */ "TRIE_next_fail", /* REGNODE_MAX +0x02 */ @@ -696,15 +688,14 @@ EXTCONST char * const PL_reg_intflags_name[] = { "CANY_SEEN", /* 0x00000080 - PREGf_CANY_SEEN */ "GPOS_SEEN", /* 0x00000100 - PREGf_GPOS_SEEN */ "GPOS_FLOAT", /* 0x00000200 - PREGf_GPOS_FLOAT */ - "ANCH_BOL", /* 0x00000400 - PREGf_ANCH_BOL */ - "ANCH_MBOL", /* 0x00000800 - PREGf_ANCH_MBOL */ - "ANCH_SBOL", /* 0x00001000 - PREGf_ANCH_SBOL */ - "ANCH_GPOS", /* 0x00002000 - PREGf_ANCH_GPOS */ + "ANCH_MBOL", /* 0x00000400 - PREGf_ANCH_MBOL */ + "ANCH_SBOL", /* 0x00000800 - PREGf_ANCH_SBOL */ + "ANCH_GPOS", /* 0x00001000 - PREGf_ANCH_GPOS */ }; #endif /* DOINIT */ #ifdef DEBUGGING -# define REG_INTFLAGS_NAME_SIZE 14 +# define REG_INTFLAGS_NAME_SIZE 13 #endif /* The following have no fixed length. U8 so we can do strchr() on it. */ @@ -716,7 +707,7 @@ EXTCONST U8 PL_varies[] __attribute__deprecated__; EXTCONST U8 PL_varies[] __attribute__deprecated__ = { CLUMP, BRANCH, BACK, STAR, PLUS, CURLY, CURLYN, CURLYM, CURLYX, WHILEM, REF, REFF, REFFL, REFFU, REFFA, NREF, NREFF, NREFFL, NREFFU, NREFFA, - SUSPEND, IFTHEN, BRANCHJ, + BRANCHJ, SUSPEND, IFTHEN, 0 }; #endif /* DOINIT */ @@ -725,7 +716,7 @@ EXTCONST U8 PL_varies[] __attribute__deprecated__ = { EXTCONST U8 PL_varies_bitmask[]; #else EXTCONST U8 PL_varies_bitmask[] = { - 0x00, 0x00, 0x00, 0xC0, 0x01, 0xFC, 0xF9, 0x9F, 0x09, 0x00, 0x00, 0x00 + 0x00, 0x00, 0x00, 0x70, 0x00, 0x7F, 0xFE, 0x97, 0x01, 0x00, 0x00, 0x00 }; #endif /* DOINIT */ @@ -747,7 +738,7 @@ EXTCONST U8 PL_simple[] __attribute__deprecated__ = { EXTCONST U8 PL_simple_bitmask[]; #else EXTCONST U8 PL_simple_bitmask[] = { - 0x00, 0x00, 0xFC, 0x3F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 + 0x00, 0x00, 0xFF, 0x0F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; #endif /* DOINIT */ diff --git a/scope.c b/scope.c index 5cfd78b..a9c73a4 100644 --- a/scope.c +++ b/scope.c @@ -846,7 +846,7 @@ Perl_leave_scope(pTHX_ I32 base) { if ((char *)svp < (char *)GvGP(ARG2_GV) || (char *)svp > (char *)GvGP(ARG2_GV) + sizeof(struct gp) - || GvREFCNT(ARG2_GV) > 1) + || GvREFCNT(ARG2_GV) > 2) /* "> 2" to ignore savestack's ref */ PL_sub_generation++; else mro_method_changed_in(hv); } @@ -1029,11 +1029,15 @@ Perl_leave_scope(pTHX_ I32 base) break; case SVt_PVCV: { - HEK * const hek = CvNAME_HEK((CV *)sv); + HEK *hek = + CvNAMED(sv) + ? CvNAME_HEK((CV *)sv) + : GvNAME_HEK(CvGV(sv)); assert(hek); - share_hek_hek(hek); + (void)share_hek_hek(hek); cv_undef((CV *)sv); CvNAME_HEK_set(sv, hek); + CvLEXICAL_on(sv); break; } default: @@ -1055,13 +1059,17 @@ Perl_leave_scope(pTHX_ I32 base) case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break; case SVt_PVCV: { + HEK * const hek = CvNAMED(sv) + ? CvNAME_HEK((CV *)sv) + : GvNAME_HEK(CvGV(sv)); + /* Create a stub */ *svp = newSV_type(SVt_PVCV); /* Share name */ - assert(CvNAMED(sv)); CvNAME_HEK_set(*svp, - share_hek_hek(CvNAME_HEK((CV *)sv))); + share_hek_hek(hek)); + CvLEXICAL_on(*svp); break; } default: *svp = newSV(0); break; @@ -1218,6 +1226,22 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_READONLY_OFF: SvREADONLY_off(ARG0_SV); break; + case SAVEt_GP_ALIASED_SV: { + /* The GP may have been abandoned, leaving the savestack with + the only remaining reference to it. */ + GP * const gp = (GP *)ARG0_PTR; + if (gp->gp_refcnt == 1) { + GV * const gv = (GV *)sv_2mortal(newSV_type(SVt_PVGV)); + GvGP_set(gv,gp); + gp_free(gv); + } + else { + gp->gp_refcnt--; + if (uv >> 8) gp->gp_flags |= GPf_ALIASED_SV; + else gp->gp_flags &= ~GPf_ALIASED_SV; + } + break; + } default: Perl_croak(aTHX_ "panic: leave_scope inconsistency %u", type); } diff --git a/scope.h b/scope.h index 0dce9d6..cad02cd 100644 --- a/scope.h +++ b/scope.h @@ -16,12 +16,12 @@ #define SAVEt_CLEARPADRANGE 1 #define SAVEt_CLEARSV 2 #define SAVEt_REGCONTEXT 3 -/*** SPARE 4 ***/ -#define SAVEt_ARG0_MAX 4 +#define SAVEt_ARG0_MAX 3 /* one arg */ +#define SAVEt_GP_ALIASED_SV 4 #define SAVEt_BOOL 5 #define SAVEt_COMPILE_WARNINGS 6 #define SAVEt_COMPPAD 7 diff --git a/sv.c b/sv.c index 44f816b..04c2826 100644 --- a/sv.c +++ b/sv.c @@ -35,20 +35,19 @@ # include #endif -#ifndef HAS_C99 -# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS) -# define HAS_C99 1 -# endif -#endif -#ifdef HAS_C99 -# include -#endif - #ifdef __Lynx__ /* Missing proto on LynxOS */ char *gconvert(double, int, int, char *); #endif +#ifdef USE_QUADMATH +# define SNPRINTF_G(nv, buffer, size, ndig) \ + quadmath_snprintf(buffer, size, "%.*Qg", (int)ndig, (NV)(nv)) +#else +# define SNPRINTF_G(nv, buffer, size, ndig) \ + PERL_UNUSED_RESULT(Gconvert((NV)(nv), (int)ndig, 0, buffer)) +#endif + #ifdef PERL_NEW_COPY_ON_WRITE # ifndef SV_COW_THRESHOLD # define SV_COW_THRESHOLD 0 /* COW iff len > K */ @@ -112,9 +111,6 @@ GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \ GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \ ) -/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to), - * has a mandatory return value, even though that value is just the same - * as the buf arg */ #ifdef PERL_UTF8_CACHE_ASSERT /* if adding more checks watch out for the following tests: @@ -2234,17 +2230,19 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if (! numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv))); -#else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv))); -#endif #ifdef NV_PRESERVES_UV (void)SvIOKp_on(sv); (void)SvNOK_on(sv); +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + if (Perl_isnan(SvNVX(sv))) { + SvUV_set(sv, 0); + SvIsUV_on(sv); + return FALSE; + } +#endif if (SvNVX(sv) < (NV)IV_MAX + 0.5) { SvIV_set(sv, I_V(SvNVX(sv))); if ((NV)(SvIVX(sv)) == SvNVX(sv)) { @@ -2395,6 +2393,14 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) return (IV)value; } } + + /* Quite wrong but no good choices. */ + if ((numtype & IS_NUMBER_INFINITY)) { + return (numtype & IS_NUMBER_NEG) ? IV_MIN : IV_MAX; + } else if ((numtype & IS_NUMBER_NAN)) { + return 0; /* So wrong. */ + } + if (!numtype) { if (ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -2475,6 +2481,14 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) if (!(numtype & IS_NUMBER_NEG)) return value; } + + /* Quite wrong but no good choices. */ + if ((numtype & IS_NUMBER_INFINITY)) { + return UV_MAX; /* So wrong. */ + } else if ((numtype & IS_NUMBER_NAN)) { + return 0; /* So wrong. */ + } + if (!numtype) { if (ckWARN(WARN_NUMERIC)) not_a_number(sv); @@ -2584,22 +2598,13 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (SvTYPE(sv) < SVt_NV) { /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ sv_upgrade(sv, SVt_NV); -#ifdef USE_LONG_DOUBLE DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, - "0x%"UVxf" num(%" PERL_PRIgldbl ")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", + "0x%"UVxf" num(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); -#endif } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -2634,8 +2639,14 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) == IS_NUMBER_IN_UV) { /* It's definitely an integer */ SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); - } else - SvNV_set(sv, Atof(SvPVX_const(sv))); + } else { + if ((numtype & IS_NUMBER_INFINITY)) { + SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF); + } else if ((numtype & IS_NUMBER_NAN)) { + SvNV_set(sv, NV_NAN); + } else + SvNV_set(sv, Atof(SvPVX_const(sv))); + } if (numtype) SvNOK_on(sv); else @@ -2681,6 +2692,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) /* Both already have p flags, so do nothing */ } else { const NV nv = SvNVX(sv); + /* XXX should this spot have NAN_COMPARE_BROKEN, too? */ if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { SvNOK_on(sv); @@ -2728,21 +2740,12 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) and ideally should be fixed. */ return 0.0; } -#if defined(USE_LONG_DOUBLE) DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); -#else - DEBUG_c({ - STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", - PTR2UV(sv), SvNVX(sv)); - RESTORE_NUMERIC_LOCAL(); - }); -#endif return SvNVX(sv); } @@ -2806,6 +2809,50 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe return ptr; } +/* Helper for sv_2pv_flags and sv_vcatpvfn_flags. If the NV is an + * infinity or a not-a-number, writes the appropriate strings to the + * buffer, including a zero byte. On success returns the written length, + * excluding the zero byte, on failure (not an infinity, not a nan, or the + * maxlen too small) returns zero. */ +STATIC size_t +S_infnan_2pv(NV nv, char* buffer, size_t maxlen) { + /* XXX this should be an assert */ + if (maxlen < 4) /* "Inf\0", "NaN\0" */ + return 0; + else { + char* s = buffer; + /* isnan must be first due to NAN_COMPARE_BROKEN builds, since NAN might + use the broken for NAN >/< ops in the inf check, and then the inf + check returns true for NAN on NAN_COMPARE_BROKEN compilers */ + if (Perl_isnan(nv)) { + *s++ = 'N'; + *s++ = 'a'; + *s++ = 'N'; + /* XXX optionally output the payload mantissa bits as + * "(unsigned)" (to match the nan("...") C99 function, + * or maybe as "(0xhhh...)" would make more sense... + * provide a format string so that the user can decide? + * NOTE: would affect the maxlen and assert() logic.*/ + } + else if (Perl_isinf(nv)) { + if (nv < 0) { + if (maxlen < 5) /* "-Inf\0" */ + return 0; + *s++ = '-'; + } + *s++ = 'I'; + *s++ = 'n'; + *s++ = 'f'; + } + + else + return 0; + assert((s == buffer + 3) || (s == buffer + 4)); + *s++ = 0; + return s - buffer - 1; /* -1: excluding the zero byte */ + } +} + /* =for apidoc sv_2pv_flags @@ -2984,42 +3031,55 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) else if (SvNOK(sv)) { if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - if (SvNVX(sv) == 0.0) { + if (SvNVX(sv) == 0.0 +#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) + && !Perl_isnan(SvNVX(sv)) +#endif + ) { s = SvGROW_mutable(sv, 2); *s++ = '0'; *s = '\0'; } else { - dSAVE_ERRNO; /* The +20 is pure guesswork. Configure test needed. --jhi */ - s = SvGROW_mutable(sv, NV_DIG + 20); - /* some Xenix systems wipe out errno here */ + STRLEN size = NV_DIG + 20; + STRLEN len; + s = SvGROW_mutable(sv, size); + + len = S_infnan_2pv(SvNVX(sv), s, size); + if (len > 0) + s += len; + else { + dSAVE_ERRNO; + /* some Xenix systems wipe out errno here */ #ifndef USE_LOCALE_NUMERIC - PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); - SvPOK_on(sv); + SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); + + SvPOK_on(sv); #else - { - DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s)); - - /* If the radix character is UTF-8, and actually is in the - * output, turn on the UTF-8 flag for the scalar */ - if (PL_numeric_local - && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) - && instr(s, SvPVX_const(PL_numeric_radix_sv))) { - SvUTF8_on(sv); + DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED(); + SNPRINTF_G(SvNVX(sv), s, SvLEN(sv), NV_DIG); + + /* If the radix character is UTF-8, and actually is in the + * output, turn on the UTF-8 flag for the scalar */ + if (PL_numeric_local + && PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv) + && instr(s, SvPVX_const(PL_numeric_radix_sv))) + { + SvUTF8_on(sv); + } + RESTORE_LC_NUMERIC(); } - RESTORE_LC_NUMERIC(); - } - /* We don't call SvPOK_on(), because it may come to pass that the - * locale changes so that the stringification we just did is no - * longer correct. We will have to re-stringify every time it is - * needed */ + /* We don't call SvPOK_on(), because it may come to + * pass that the locale changes so that the + * stringification we just did is no longer correct. We + * will have to re-stringify every time it is needed */ #endif - RESTORE_ERRNO; - while (*s) s++; + RESTORE_ERRNO; + } + while (*s) s++; } } else if (isGV_with_GP(sv)) { @@ -3106,9 +3166,7 @@ Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) PERL_ARGS_ASSERT_SV_COPYPV_FLAGS; - if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv)) - mg_get(ssv); - s = SvPV_nomg_const(ssv,len); + s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC)); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -3458,7 +3516,7 @@ must_be_utf8: * set so starts from there. Otherwise, can use memory copy to * get up to where we are now, and then start from here */ - if (invariant_head <= 0) { + if (invariant_head == 0) { d = dst; } else { Copy(s, dst, invariant_head, char); @@ -3963,13 +4021,37 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if(GvSTASH(dstr)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if (intro && GvREFCNT(dstr) > 1) { + /* temporary remove extra savestack's ref */ + --GvREFCNT(dstr); + gv_method_changed(dstr); + ++GvREFCNT(dstr); + } + else gv_method_changed(dstr); + } } *location = SvREFCNT_inc_simple_NN(sref); if (import_flag && !(GvFLAGS(dstr) & import_flag) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvFLAGS(dstr) |= import_flag; } + if (import_flag == GVf_IMPORTED_SV) { + if (intro) { + dSS_ADD; + SS_ADD_PTR(gp_ref(GvGP(dstr))); + SS_ADD_UV(SAVEt_GP_ALIASED_SV + | cBOOL(GvALIASED_SV(dstr)) << 8); + SS_ADD_END(2); + } + /* Turn off the flag if sref is not referenced elsewhere, + even by weak refs. (SvRMAGICAL is a pessimistic check for + back refs.) */ + if (SvREFCNT(sref) <= 2 && !SvRMAGICAL(sref)) + GvALIASED_SV_off(dstr); + else + GvALIASED_SV_on(dstr); + } if (stype == SVt_PVHV) { const char * const name = GvNAME((GV*)dstr); const STRLEN len = GvNAMELEN(dstr); @@ -7263,12 +7345,9 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b assert(cache); if (PL_utf8cache < 0 && SvPOKp(sv)) { - /* SvPOKp() because it's possible that sv has string overloading, and - therefore is a reference, hence SvPVX() is actually a pointer. - This cures the (very real) symptoms of RT 69422, but I'm not actually - sure whether we should even be caching the results of UTF-8 - operations on overloading, given that nothing stops overloading - returning a different value every time it's called. */ + /* SvPOKp() because, if sv is a reference, then SvPVX() is actually + a pointer. Note that we no longer cache utf8 offsets on refer- + ences, but this check is still a good idea, for robustness. */ const U8 *start = (const U8 *) SvPVX_const(sv); const STRLEN realutf8 = utf8_length(start, start + byte); @@ -8537,7 +8616,8 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) } if (flags & SVp_NOK) { const NV was = SvNVX(sv); - if (NV_OVERFLOWS_INTEGERS_AT && + if (!Perl_isinfnan(was) && + NV_OVERFLOWS_INTEGERS_AT && was >= NV_OVERFLOWS_INTEGERS_AT) { /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), @@ -8586,13 +8666,8 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) /* I don't think we can get here. Maybe I should assert this And if we do get here I suspect that sv_setnv will croak. NWC Fall through. */ -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#endif } #endif /* PERL_PRESERVE_IVUV */ if (!numtype && ckWARN(WARN_NUMERIC)) @@ -8615,7 +8690,7 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) * arranged in order (although not consecutively) and that only * [A-Za-z] are accepted by isALPHA in the C locale. */ - if (*d != 'z' && *d != 'Z') { + if (isALPHA_FOLD_NE(*d, 'z')) { do { ++*d; } while (!isALPHA(*d)); return; } @@ -8720,7 +8795,8 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) oops_its_num: { const NV was = SvNVX(sv); - if (NV_OVERFLOWS_INTEGERS_AT && + if (!Perl_isinfnan(was) && + NV_OVERFLOWS_INTEGERS_AT && was <= -NV_OVERFLOWS_INTEGERS_AT) { /* diag_listed_as: Lost precision when %s %f by 1 */ Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), @@ -8763,13 +8839,8 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) /* I don't think we can get here. Maybe I should assert this And if we do get here I suspect that sv_setnv will croak. NWC Fall through. */ -#if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#else DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); -#endif } } #endif /* PERL_PRESERVE_IVUV */ @@ -9703,7 +9774,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" /* tied lvalues should appear to be * scalars for backwards compatibility */ - : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T') + : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) ? "SCALAR" : "LVALUE"); case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; @@ -10509,6 +10580,11 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) PERL_ARGS_ASSERT_F0CONVERT; + if (Perl_isinfnan(nv)) { + STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len); + *len = n; + return endbuf - n; + } if (neg) nv = -nv; if (nv < UV_MAX) { @@ -10563,25 +10639,66 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC); } +#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN +# define LONGDOUBLE_LITTLE_ENDIAN +#endif + +#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN +# define LONGDOUBLE_BIG_ENDIAN +#endif + +#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN +# define LONGDOUBLE_X86_80_BIT +#endif + +#if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \ + LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN +# define LONGDOUBLE_DOUBLEDOUBLE +# define DOUBLEDOUBLE_MAXBITS 1028 +#endif + /* vhex will contain the values (0..15) of the hex digits ("nybbles" - * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa, - * four bits per xdigit. */ -#define VHEX_SIZE (1+128/4) + * of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits + * per xdigit. */ +#ifdef LONGDOUBLE_DOUBLEDOUBLE +# define VHEX_SIZE (1+DOUBLEDOUBLE_MAXBITS/4) +#else +# define VHEX_SIZE (1+128/4) +#endif /* If we do not have a known long double format, (including not using * long doubles, or long doubles being equal to doubles) then we will * fall back to the ldexp/frexp route, with which we can retrieve at * most as many bits as our widest unsigned integer type is. We try - * to get a 64-bit unsigned integer even if we are not having 64-bit - * UV. */ + * to get a 64-bit unsigned integer even if we are not using a 64-bit UV. + * + * (If you want to test the case of UVSIZE == 4, NVSIZE == 8, + * set the MANTISSATYPE to int and the MANTISSASIZE to 4.) + */ #if defined(HAS_QUAD) && defined(Uquad_t) # define MANTISSATYPE Uquad_t # define MANTISSASIZE 8 #else -# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */ +# define MANTISSATYPE UV # define MANTISSASIZE UVSIZE #endif +/* We make here the wild assumption that the endianness of doubles + * is similar to the endianness of integers, and that there is no + * middle-endianness. This may come back to haunt us (the rumor + * has it that ARM can be quite haunted). */ +#if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \ + defined(DOUBLEKIND_LITTLE_ENDIAN) +# define HEXTRACT_LITTLE_ENDIAN +#else +# define HEXTRACT_BIG_ENDIAN +#endif + /* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting * the hexadecimal values (for %a/%A). The nv is the NV where the value * are being extracted from (either directly from the long double in-memory @@ -10610,55 +10727,60 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend) * repetitions below, but usually only one (or sometimes two) * of them is really being used. */ /* HEXTRACT_OUTPUT() extracts the high nybble first. */ -#define HEXTRACT_OUTPUT() \ +#define HEXTRACT_OUTPUT_HI(ix) (*v++ = nvp[ix] >> 4) +#define HEXTRACT_OUTPUT_LO(ix) (*v++ = nvp[ix] & 0xF) +#define HEXTRACT_OUTPUT(ix) \ STMT_START { \ - *v++ = nvp[ix] >> 4; \ - *v++ = nvp[ix] & 0xF; \ - } STMT_END -#define HEXTRACT_COUNT() \ + HEXTRACT_OUTPUT_HI(ix); HEXTRACT_OUTPUT_LO(ix); \ + } STMT_END +#define HEXTRACT_COUNT(ix, c) \ STMT_START { \ - v += 2; \ - if (ix < ixmin) \ - ixmin = ix; \ - else if (ix > ixmax) \ - ixmax = ix; \ - } STMT_END -#define HEXTRACT_IMPLICIT_BIT() \ - if (exponent) { \ - if (vend) \ - *v++ = 1; \ - else \ - v++; \ - } + v += c; if (ix < ixmin) ixmin = ix; else if (ix > ixmax) ixmax = ix; \ + } STMT_END +#define HEXTRACT_BYTE(ix) \ + STMT_START { \ + if (vend) HEXTRACT_OUTPUT(ix); else HEXTRACT_COUNT(ix, 2); \ + } STMT_END +#define HEXTRACT_LO_NYBBLE(ix) \ + STMT_START { \ + if (vend) HEXTRACT_OUTPUT_LO(ix); else HEXTRACT_COUNT(ix, 1); \ + } STMT_END +# define HEXTRACT_IMPLICIT_BIT(nv) \ + STMT_START { \ + if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \ + } STMT_END - /* First see if we are using long doubles. */ -#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE - const U8* nvp = (const U8*)(&nv); +#ifdef LONGDOUBLE_DOUBLEDOUBLE +# define HEXTRACTSIZE (DOUBLEDOUBLE_MAXBITS/8) +#else # define HEXTRACTSIZE NVSIZE +#endif + + const U8* nvp = (const U8*)(&nv); + const U8* vmaxend = vhex + 2 * HEXTRACTSIZE + 1; (void)Perl_frexp(PERL_ABS(nv), exponent); + if (vend && (vend <= vhex || vend > vmaxend)) + Perl_croak(aTHX_ "Hexadecimal float: internal error"); + + /* First check if using long doubles. */ +#if NVSIZE > DOUBLESIZE # if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN /* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L: * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */ /* The bytes 13..0 are the mantissa/fraction, * the 15,14 are the sign+exponent. */ - HEXTRACT_IMPLICIT_BIT(); + HEXTRACT_IMPLICIT_BIT(nv); for (ix = 13; ix >= 0; ix--) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + HEXTRACT_BYTE(ix); } # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN /* Used in e.g. Solaris Sparc and HP-UX PA-RISC, e.g. -0.1L: * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */ /* The bytes 2..15 are the mantissa/fraction, * the 0,1 are the sign+exponent. */ - HEXTRACT_IMPLICIT_BIT(); + HEXTRACT_IMPLICIT_BIT(nv); for (ix = 2; ix <= 15; ix++) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + HEXTRACT_BYTE(ix); } # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN /* x86 80-bit "extended precision", 64 bits of mantissa / fraction / @@ -10666,145 +10788,152 @@ S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend) * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X), * meaning that 2 or 6 bytes are empty padding. */ /* The bytes 7..0 are the mantissa/fraction */ - /* There explicitly is *no* implicit bit in this case. */ + + /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */ for (ix = 7; ix >= 0; ix--) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + HEXTRACT_BYTE(ix); } # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN - /* The last 8 bytes are the mantissa/fraction. - * (does this format ever happen?) */ - /* There explicitly is *no* implicit bit in this case. */ - for (ix = LONGDBLSIZE - 8; ix < LONGDBLSIZE; ix++) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); - } -# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN - /* Where is this used? + /* Does this format ever happen? (Wikipedia says the Motorola + * 6888x math coprocessors used format _like_ this but padded + * to 96 bits with 16 unused bits between the exponent and the + * mantissa.) */ + + /* Intentionally NO HEXTRACT_IMPLICIT_BIT here. */ + for (ix = 0; ix < 8; ix++) { + HEXTRACT_BYTE(ix); + } +# elif defined(LONGDOUBLE_DOUBLEDOUBLE) + /* Double-double format: two doubles next to each other. + * The first double is the high-order one, exactly like + * it would be for a "lone" double. The second double + * is shifted down using the exponent so that that there + * are no common bits. The tricky part is that the value + * of the double-double is the SUM of the two doubles and + * the second one can be also NEGATIVE. * - * Guessing that the format would be the reverse - * of big endian, i.e. for -0.1L: - * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */ - HEXTRACT_IMPLICIT_BIT(); - for (ix = 13; ix >= 8; ix--) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); - } - for (ix = 5; ix >= 0; ix--) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); - } -# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN - /* Used in e.g. PPC/Power (AIX) and MIPS. + * Because of this tricky construction the bytewise extraction we + * use for the other long double formats doesn't work, we must + * extract the values bit by bit. * - * The mantissa bits are in two separate stretches, - * e.g. for -0.1L: - * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a + * The little-endian double-double is used .. somewhere? * - * Note that this blind copying might be considered not to be - * the right thing, since the first double already does - * rounding (0x9A as opposed to 0x99). But then again, we - * probably should just copy the bits as they are? + * The big endian double-double is used in e.g. PPC/Power (AIX) + * and MIPS (SGI). + * + * The mantissa bits are in two separate stretches, e.g. for -0.1L: + * 9a 99 99 99 99 99 59 bc 9a 99 99 99 99 99 b9 3f (LE) + * 3f b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE) */ - HEXTRACT_IMPLICIT_BIT(); - for (ix = 2; ix < 8; ix++) { + + if (nv == (NV)0.0) { if (vend) - HEXTRACT_OUTPUT(); + *v++ = 0; else - HEXTRACT_COUNT(); + v++; + *exponent = 0; } - for (ix = 10; ix < 16; ix++) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + else { + NV d = nv < 0 ? -nv : nv; + NV e = (NV)1.0; + U8 ha = 0x0; /* hexvalue accumulator */ + U8 hd = 0x8; /* hexvalue digit */ + + /* Shift d and e (and update exponent) so that e <= d < 2*e, + * this is essentially manual frexp(). Multiplying by 0.5 and + * doubling should be lossless in binary floating point. */ + + *exponent = 1; + + while (e > d) { + e *= (NV)0.5; + (*exponent)--; + } + /* Now d >= e */ + + while (d >= e + e) { + e += e; + (*exponent)++; + } + /* Now e <= d < 2*e */ + + /* First extract the leading hexdigit (the implicit bit). */ + if (d >= e) { + d -= e; + if (vend) + *v++ = 1; + else + v++; + } + else { + if (vend) + *v++ = 0; + else + v++; + } + e *= (NV)0.5; + + /* Then extract the remaining hexdigits. */ + while (d > (NV)0.0) { + if (d >= e) { + ha |= hd; + d -= e; + } + if (hd == 1) { + /* Output or count in groups of four bits, + * that is, when the hexdigit is down to one. */ + if (vend) + *v++ = ha; + else + v++; + /* Reset the hexvalue. */ + ha = 0x0; + hd = 0x8; + } + else + hd >>= 1; + e *= (NV)0.5; + } + + /* Flush possible pending hexvalue. */ + if (ha) { + if (vend) + *v++ = ha; + else + v++; + } } # else Perl_croak(aTHX_ "Hexadecimal float: unsupported long double format"); # endif #else - /* If not using long doubles (or if the long double format is - * known but not yet supported), try to retrieve the mantissa bits - * via frexp+ldexp. */ - - NV norm = Perl_frexp(PERL_ABS(nv), exponent); - /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to - * inspect; but in practice we don't want the leading nybbles that - * are zero. With the common IEEE 754 value for NV_MANT_DIG being - * 53, we want the limit byte to be (int)((53-1)/8) == 6. - * - * Note that this is _not_ inspecting the in-memory format of the - * nv (as opposed to the long double method), but instead the UV - * retrieved with the frexp+ldexp invocation. */ -# if MANTISSASIZE * 8 > NV_MANT_DIG - MANTISSATYPE mantissa = Perl_ldexp(norm, NV_MANT_DIG); - int limit_byte = (NV_MANT_DIG - 1) / 8; -# else - /* There will be low-order precision loss. Try to salvage as many - * bits as possible. Will truncate, not round. */ - MANTISSATYPE mantissa = - Perl_ldexp(norm, - /* The highest possible shift by two that fits in the - * mantissa and is aligned (by four) the same was as - * NV_MANT_DIG. */ - MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4)); - int limit_byte = MANTISSASIZE - 1; -# endif - const U8* nvp = (const U8*)(&mantissa); -# define HEXTRACTSIZE MANTISSASIZE - /* We make here the wild assumption that the endianness of doubles - * is similar to the endianness of integers, and that there is no - * middle-endianness. This may come back to haunt us (the rumor - * has it that ARM can be quite haunted). + /* Using normal doubles, not long doubles. * * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit - * bytes, since we might need to handle printf precision, and also - * insert the radix. - */ -# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \ - LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN - /* Little endian. */ - for (ix = limit_byte; ix >= 0; ix--) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + * bytes, since we might need to handle printf precision, and + * also need to insert the radix. */ + HEXTRACT_IMPLICIT_BIT(nv); +# ifdef HEXTRACT_LITTLE_ENDIAN + HEXTRACT_LO_NYBBLE(6); + for (ix = 5; ix >= 0; ix--) { + HEXTRACT_BYTE(ix); } # else - /* Big endian. */ - for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) { - if (vend) - HEXTRACT_OUTPUT(); - else - HEXTRACT_COUNT(); + HEXTRACT_LO_NYBBLE(1); + for (ix = 2; ix < HEXTRACTSIZE; ix++) { + HEXTRACT_BYTE(ix); } # endif - /* If there are not enough bits in MANTISSATYPE, we couldn't get - * all of them, issue a warning. - * - * Note that NV_PRESERVES_UV_BITS would not help here, it is the - * wrong way around. */ -# if NV_MANT_DIG > MANTISSASIZE * 8 - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Hexadecimal float: precision loss"); -# endif #endif /* Croak for various reasons: if the output pointer escaped the * output buffer, if the extraction index escaped the extraction * buffer, or if the ending output pointer didn't match the * previously computed value. */ if (v <= vhex || v - vhex >= VHEX_SIZE || + /* For double-double the ixmin and ixmax stay at zero, + * which is convenient since the HEXTRACTSIZE is tricky + * for double-double. */ ixmin < 0 || ixmax >= HEXTRACTSIZE || (vend && v != vend)) Perl_croak(aTHX_ "Hexadecimal float: internal error"); @@ -10830,10 +10959,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * NV_DIG: mantissa takes than many decimal digits. * Plus 32: Playing safe. */ char ebuf[IV_DIG * 4 + NV_DIG + 32]; - /* large enough for "%#.#f" --chip */ - /* what about long double NVs? --jhi */ bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */ - bool hexfp = FALSE; + bool hexfp = FALSE; /* hexadecimal floating point? */ DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED; @@ -10897,26 +11024,28 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Munged by Nicholas Clark in v5.13.0-209-g95ea86d */ if (pp - pat == (int)patlen - 1 && svix < svmax) { const NV nv = SvNV(*svargs); - if (*pp == 'g') { - /* Add check for digits != 0 because it seems that some - gconverts are buggy in this case, and we don't yet have - a Configure test for this. */ - if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { - /* 0, point, slack */ - STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf)); - sv_catpv_nomg(sv, ebuf); - if (*ebuf) /* May return an empty string for digits==0 */ - return; - } - } else if (!digits) { - STRLEN l; + if (LIKELY(!Perl_isinfnan(nv))) { + if (*pp == 'g') { + /* Add check for digits != 0 because it seems that some + gconverts are buggy in this case, and we don't yet have + a Configure test for this. */ + if (digits && digits < sizeof(ebuf) - NV_DIG - 10) { + /* 0, point, slack */ + STORE_LC_NUMERIC_SET_TO_NEEDED(); + SNPRINTF_G(nv, ebuf, size, digits); + sv_catpv_nomg(sv, ebuf); + if (*ebuf) /* May return an empty string for digits==0 */ + return; + } + } else if (!digits) { + STRLEN l; - if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { - sv_catpvn_nomg(sv, p, l); - return; - } - } + if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) { + sv_catpvn_nomg(sv, p, l); + return; + } + } + } } } #endif /* !USE_LONG_DOUBLE */ @@ -10961,13 +11090,22 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p unsigned base = 0; IV iv = 0; UV uv = 0; - /* we need a long double target in case HAS_LONG_DOUBLE but - not USE_LONG_DOUBLE + /* We need a long double target in case HAS_LONG_DOUBLE, + * even without USE_LONG_DOUBLE, so that we can printf with + * long double formats, even without NV being long double. + * But we call the target 'fv' instead of 'nv', since most of + * the time it is not (most compilers these days recognize + * "long double", even if only as a synonym for "double"). */ -#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE - long double nv; +#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ + defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) + long double fv; +# define FV_ISFINITE(x) Perl_isfinitel(x) +# define FV_GF PERL_PRIgldbl #else - NV nv; + NV fv; +# define FV_ISFINITE(x) Perl_isfinite((NV)(x)) +# define FV_GF NVgf #endif STRLEN have; STRLEN need; @@ -10979,6 +11117,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p I32 epix = 0; /* explicit precision index */ I32 evix = 0; /* explicit vector index */ bool asterisk = FALSE; + bool infnan = FALSE; /* echo everything up to the next format specification */ for (q = p; q < patend && *q != '%'; ++q) ; @@ -11265,6 +11404,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE) case 'L': /* Ld */ /* FALLTHROUGH */ +#ifdef USE_QUADMATH + case 'Q': + /* FALLTHROUGH */ +#endif #if IVSIZE >= 8 case 'q': /* qd */ #endif @@ -11294,7 +11437,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'V': case 'z': case 't': -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': #endif intsize = *q++; @@ -11324,6 +11467,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } + if (argsv && SvNOK(argsv)) { + /* XXX va_arg(*args) case? */ + infnan = Perl_isinfnan(SvNV(argsv)); + } + switch (c = *q++) { /* STRINGS */ @@ -11331,7 +11479,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 'c': if (vectorize) goto unknown; - uv = (args) ? va_arg(*args, int) : SvIV(argsv); + uv = (args) ? va_arg(*args, int) : + infnan ? UNICODE_REPLACEMENT : SvIV(argsv); if ((uv > 255 || (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -11387,6 +11536,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* INTEGERS */ case 'p': + if (infnan) { + c = 'g'; + goto floating_point; + } if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -11402,6 +11555,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FALLTHROUGH */ case 'd': case 'i': + if (infnan) { + c = 'g'; + goto floating_point; + } if (vectorize) { STRLEN ulen; if (!veclen) @@ -11429,7 +11586,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p case 't': iv = va_arg(*args, ptrdiff_t); break; #endif default: iv = va_arg(*args, int); break; -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': iv = va_arg(*args, intmax_t); break; #endif case 'q': @@ -11503,6 +11660,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p base = 16; uns_integer: + if (infnan) { + c = 'g'; + goto floating_point; + } if (vectorize) { STRLEN ulen; vector: @@ -11528,7 +11689,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef HAS_PTRDIFF_T case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */ #endif -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': uv = va_arg(*args, uintmax_t); break; #endif default: uv = va_arg(*args, unsigned); break; @@ -11619,6 +11780,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* FLOATING POINT */ + floating_point: + case 'F': c = 'f'; /* maybe %F isn't supported here */ /* FALLTHROUGH */ @@ -11663,47 +11826,73 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto unknown; } - /* now we need (long double) if intsize == 'q', else (double) */ - nv = (args) ? -#if LONG_DOUBLESIZE > DOUBLESIZE - intsize == 'q' ? - va_arg(*args, long double) : - va_arg(*args, double) + /* Now we need (long double) if intsize == 'q', else (double). */ + if (args) { + /* Note: do not pull NVs off the va_list with va_arg() + * (pull doubles instead) because if you have a build + * with long doubles, you would always be pulling long + * doubles, which would badly break anyone using only + * doubles (i.e. the majority of builds). In other + * words, you cannot mix doubles and long doubles. + * The only case where you can pull off long doubles + * is when the format specifier explicitly asks so with + * e.g. "%Lg". */ +#ifdef USE_QUADMATH + fv = intsize == 'q' ? + va_arg(*args, NV) : va_arg(*args, double); +#elif LONG_DOUBLESIZE > DOUBLESIZE + fv = intsize == 'q' ? + va_arg(*args, long double) : va_arg(*args, double); #else - va_arg(*args, double) + fv = va_arg(*args, double); #endif - : SvNV(argsv); + } + else + fv = SvNV(argsv); need = 0; - /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything - else. frexp() has some unspecified behaviour for those three */ - if (c != 'e' && c != 'E' && (nv * 0) == 0) { + /* frexp() (or frexpl) has some unspecified behaviour for + * nan/inf/-inf, so let's avoid calling that on non-finites. */ + if (isALPHA_FOLD_NE(c, 'e') && FV_ISFINITE(fv)) { i = PERL_INT_MIN; - /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this - will cast our (long double) to (double) */ - (void)Perl_frexp(nv, &i); + (void)Perl_frexp((NV)fv, &i); if (i == PERL_INT_MIN) - Perl_die(aTHX_ "panic: frexp"); - hexfp = (c == 'a' || c == 'A'); + Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv); + /* Do not set hexfp earlier since we want to printf + * Inf/NaN for Inf/NaN, not their hexfp. */ + hexfp = isALPHA_FOLD_EQ(c, 'a'); if (UNLIKELY(hexfp)) { - /* Hexadecimal floating point: this size - * computation probably overshoots, but that is - * better than undershooting. */ + /* This seriously overshoots in most cases, but + * better the undershooting. Firstly, all bytes + * of the NV are not mantissa, some of them are + * exponent. Secondly, for the reasonably common + * long doubles case, the "80-bit extended", two + * or six bytes of the NV are unused. */ need += - (nv < 0) + /* possible unary minus */ + (fv < 0) ? 1 : 0 + /* possible unary minus */ 2 + /* "0x" */ 1 + /* the very unlikely carry */ 1 + /* "1" */ 1 + /* "." */ - /* We want one byte per each 4 bits in the - * mantissa. This works out to about 0.83 - * bytes per NV decimal digit (of 4 bits): - * (NV_DIG * log(10)/log(2)) / 4, - * we overestimate by using 5/6 (0.8333...) */ - ((NV_DIG * 5) / 6 + 1) + + 2 * NVSIZE + /* 2 hexdigits for each byte */ 2 + /* "p+" */ - (i >= 0 ? BIT_DIGITS(i) : 1 + BIT_DIGITS(-i)) + + 6 + /* exponent: sign, plus up to 16383 (quad fp) */ 1; /* \0 */ +#ifdef LONGDOUBLE_DOUBLEDOUBLE + /* However, for the "double double", we need more. + * Since each double has their own exponent, the + * doubles may float (haha) rather far from each + * other, and the number of required bits is much + * larger, up to total of 1028 bits. (NOTE: this + * is not actually implemented properly yet, + * we are using just the first double, see + * S_hextract() for details. But let's prepare + * for the future.) */ + + /* 2 hexdigits for each byte. */ + need += (DOUBLEDOUBLE_MAXBITS/8 + 1) * 2; + /* the size for the exponent already added */ +#endif #ifdef USE_LOCALE_NUMERIC STORE_LC_NUMERIC_SET_TO_NEEDED(); if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) @@ -11751,22 +11940,22 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p # endif if ((intsize == 'q') && (c == 'f') && - ((nv < MY_DBL_MAX_BUG) && (nv > -MY_DBL_MAX_BUG)) && + ((fv < MY_DBL_MAX_BUG) && (fv > -MY_DBL_MAX_BUG)) && (need < DBL_DIG)) { /* it's going to be short enough that * long double precision is not needed */ - if ((nv <= 0L) && (nv >= -0L)) + if ((fv <= 0L) && (fv >= -0L)) fix_ldbl_sprintf_bug = TRUE; /* 0 is 0 - easiest */ else { /* would use Perl_fp_class as a double-check but not * functional on IRIX - see perl.h comments */ - if ((nv >= MY_DBL_MIN) || (nv <= -MY_DBL_MIN)) { + if ((fv >= MY_DBL_MIN) || (fv <= -MY_DBL_MIN)) { /* It's within the range that a double can represent */ #if defined(DBL_MAX) && !defined(DBL_MIN) - if ((nv >= ((long double)1/DBL_MAX)) || - (nv <= (-(long double)1/DBL_MAX))) + if ((fv >= ((long double)1/DBL_MAX)) || + (fv <= (-(long double)1/DBL_MAX))) #endif fix_ldbl_sprintf_bug = TRUE; } @@ -11775,8 +11964,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p double temp; intsize = 0; - temp = (double)nv; - nv = (NV)temp; + temp = (double)fv; + fv = (NV)temp; } } @@ -11795,19 +11984,20 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } if ( !(width || left || plus || alt) && fill != '0' - && has_precis && intsize != 'q' ) { /* Shortcuts */ + && has_precis && intsize != 'q' /* Shortcuts */ + && LIKELY(!Perl_isinfnan((NV)fv)) ) { /* See earlier comment about buggy Gconvert when digits, aka precis is 0 */ - if ( c == 'g' && precis) { + if ( c == 'g' && precis ) { STORE_LC_NUMERIC_SET_TO_NEEDED(); - PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf)); + SNPRINTF_G(fv, PL_efloatbuf, PL_efloatsize, precis); /* May return an empty string for digits==0 */ if (*PL_efloatbuf) { elen = strlen(PL_efloatbuf); goto float_converted; } - } else if ( c == 'f' && !precis) { - if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) + } else if ( c == 'f' && !precis ) { + if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen))) break; } } @@ -11825,12 +12015,30 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * human-readable xdigits. */ const char* xdig = PL_hexdigit; int zerotail = 0; /* how many extra zeros to append */ - int exponent; /* exponent of the floating point input */ - - vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL); - S_hextract(aTHX_ nv, &exponent, vhex, vend); + int exponent = 0; /* exponent of the floating point input */ + + /* XXX: denormals, NaN, Inf. + * + * For example with denormals, (assuming the vanilla + * 64-bit double): the exponent is zero. 1xp-1074 is + * the smallest denormal and the smallest double, it + * should be output as 0x0.0000000000001p-1022 to + * match its internal structure. */ + + /* Note: fv can be (and often is) long double. + * Here it is explicitly cast to NV. */ + vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL); + S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend); + +#if NVSIZE > DOUBLESIZE +# ifdef LONGDOUBLE_X86_80_BIT + exponent -= 4; +# else + exponent--; +# endif +#endif - if (nv < 0) + if (fv < 0) *p++ = '-'; else if (plus) *p++ = plus; @@ -11862,9 +12070,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - /* Adjust the exponent so that the first output - * xdigit aligns with the 4-bit nybbles. */ - exponent -= NV_MANT_DIG % 4 ? NV_MANT_DIG % 4 : 4; +#if NVSIZE == DOUBLESIZE + if (fv != 0.0) + exponent--; +#endif if (precis > 0) { v = vhex + precis + 1; @@ -11970,19 +12179,29 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p elen = width; } } - else { - char *ptr = ebuf + sizeof ebuf; - *--ptr = '\0'; - *--ptr = c; - /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ + else + elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize); + + if (elen == 0) { + char *ptr = ebuf + sizeof ebuf; + *--ptr = '\0'; + *--ptr = c; + /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) + /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, + * not USE_LONG_DOUBLE and NVff. In other words, + * this needs to work without USE_LONG_DOUBLE. */ if (intsize == 'q') { /* Copy the one or more characters in a long double * format before the 'base' ([efgEFG]) character to * the format string. */ - static char const prifldbl[] = PERL_PRIfldbl; - char const *p = prifldbl + sizeof(prifldbl) - 3; - while (p >= prifldbl) { *--ptr = *p--; } +#ifdef USE_QUADMATH + *--ptr = 'Q'; +#else + static char const ldblf[] = PERL_PRIfldbl; + char const *p = ldblf + sizeof(ldblf) - 3; + while (p >= ldblf) { *--ptr = *p--; } +#endif } #endif if (has_precis) { @@ -12013,18 +12232,31 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* hopefully the above makes ptr a very constrained format * that is safe to use, even though it's not literal */ GCC_DIAG_IGNORE(-Wformat-nonliteral); -#if defined(HAS_LONG_DOUBLE) +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(ptr); + if (!qfmt) + Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr); + elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, + qfmt, fv); + if ((IV)elen == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt); + if (qfmt != ptr) + Safefree(qfmt); + } +#elif defined(HAS_LONG_DOUBLE) elen = ((intsize == 'q') - ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv) - : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv)); + ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv) + : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv)); #else - elen = my_sprintf(PL_efloatbuf, ptr, nv); + elen = my_sprintf(PL_efloatbuf, ptr, fv); #endif GCC_DIAG_RESTORE; } float_converted: eptr = PL_efloatbuf; + assert((IV)elen > 0); /* here zero elen is bad */ #ifdef USE_LOCALE_NUMERIC /* If the decimal point character in the string is UTF-8, make the @@ -12055,7 +12287,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #ifdef HAS_PTRDIFF_T case 't': *(va_arg(*args, ptrdiff_t*)) = i; break; #endif -#ifdef HAS_C99 +#ifdef I_STDINT case 'j': *(va_arg(*args, intmax_t*)) = i; break; #endif case 'q': @@ -12136,6 +12368,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } + assert((IV)elen >= 0); /* here zero elen is fine */ have = esignlen + zeros + elen; if (have < zeros) croak_memory_wrap(); @@ -12289,7 +12522,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); parser->lex_defer = proto->lex_defer; parser->lex_dojoin = proto->lex_dojoin; - parser->lex_expect = proto->lex_expect; parser->lex_formbrack = proto->lex_formbrack; parser->lex_inpat = proto->lex_inpat; parser->lex_inwhat = proto->lex_inwhat; @@ -13229,7 +13461,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr)); if (CvNAMED(dstr)) SvANY((CV *)dstr)->xcv_gv_u.xcv_hek = - share_hek_hek(CvNAME_HEK((CV *)sstr)); + hek_dup(CvNAME_HEK((CV *)sstr), param); /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ else @@ -13724,6 +13956,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); break; + case SAVEt_GP_ALIASED_SV: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = gp_dup((GP *)ptr, param); + ((GP *)ptr)->gp_refcnt++; + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) type); @@ -13953,6 +14190,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_minus_F = proto_perl->Iminus_F; PL_doswitches = proto_perl->Idoswitches; PL_dowarn = proto_perl->Idowarn; + PL_sawalias = proto_perl->Isawalias; #ifdef PERL_SAWAMPERSAND PL_sawampersand = proto_perl->Isawampersand; #endif @@ -14365,6 +14603,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); + PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param); PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param); @@ -14705,7 +14944,6 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) nsv = sv_newmortal(); SvSetSV_nosteal(nsv, sv); } - save_re_context(); PUSHMARK(sp); EXTEND(SP, 3); PUSHs(encoding); @@ -14776,7 +15014,6 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, dSP; ENTER; SAVETMPS; - save_re_context(); PUSHMARK(sp); EXTEND(SP, 6); PUSHs(encoding); diff --git a/sv.h b/sv.h index 753b5bb..f3d2e4e 100644 --- a/sv.h +++ b/sv.h @@ -408,7 +408,8 @@ perform the upgrade if necessary. See C. /* note that SVf_AMAGIC is now only set on stashes, so this bit is free * for non-HV SVs */ -/* Ensure this value does not clash with the GV_ADD* flags in gv.h: */ +/* Ensure this value does not clash with the GV_ADD* flags in gv.h, or the + CV_CKPROTO_* flags in op.c, or the padadd_* flags in pad.h: */ #define SVf_UTF8 0x20000000 /* SvPV is UTF-8 encoded This is also set on RVs whose overloaded stringification is UTF-8. This might @@ -1679,15 +1680,15 @@ Like sv_utf8_upgrade, but doesn't do magic on C. #define SvPV_flags_const(sv, lp, flags) \ (SvPOK_nog(sv) \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ - (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) + (const char*) sv_2pv_flags(sv, &lp, (flags|SV_CONST_RETURN))) #define SvPV_flags_const_nolen(sv, flags) \ (SvPOK_nog(sv) \ ? SvPVX_const(sv) : \ - (const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN)) + (const char*) sv_2pv_flags(sv, 0, (flags|SV_CONST_RETURN))) #define SvPV_flags_mutable(sv, lp, flags) \ (SvPOK_nog(sv) \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ - sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) + sv_2pv_flags(sv, &lp, (flags|SV_MUTABLE_RETURN))) #define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) @@ -1970,6 +1971,12 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect (littlelen), SV_GMAGIC) #define sv_mortalcopy(sv) \ Perl_sv_mortalcopy_flags(aTHX_ sv, SV_GMAGIC|SV_DO_COW_SVSETSV) +#define sv_cathek(sv,hek) \ + STMT_START { \ + HEK * const bmxk = hek; \ + sv_catpvn_flags(sv, HEK_KEY(bmxk), HEK_LEN(bmxk), \ + HEK_UTF8(bmxk) ? SV_CATUTF8 : SV_CATBYTES); \ + } STMT_END /* Should be named SvCatPVN_utf8_upgrade? */ #define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \ diff --git a/symbian/config.sh b/symbian/config.sh index 27f5a5b..193b8db 100644 --- a/symbian/config.sh +++ b/symbian/config.sh @@ -50,6 +50,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='undef' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='undef' d_archlib='define' @@ -135,6 +136,7 @@ d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='undef' d_fds_bits='undef' +d_fegetround='undef' d_fgetpos='undef' d_finite='undef' d_finitel='undef' @@ -143,10 +145,13 @@ d_flock='undef' d_flockproto='undef' d_fork='undef' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -240,9 +245,13 @@ d_ipv6_mreq_source='undef' d_isascii='undef' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='undef' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' @@ -467,6 +476,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='undef' d_u32align='define' @@ -575,6 +585,7 @@ i_dirent='define' i_dlfcn='undef' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='undef' i_fp='undef' i_fp_class='undef' @@ -603,6 +614,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='define' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -610,6 +622,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='undef' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -836,6 +849,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='define' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='false' diff --git a/t/base/lex.t b/t/base/lex.t index 01ab208..7604ee1 100644 --- a/t/base/lex.t +++ b/t/base/lex.t @@ -1,6 +1,6 @@ #!./perl -print "1..91\n"; +print "1..93\n"; $x = 'x'; @@ -434,3 +434,13 @@ print "ok $test - y ...\n"; $test++; print "not " unless (time =>) eq time=>; print "ok $test - => quotes keywords across lines\n"; $test++; + +# [perl #80368] +print "not " unless eval '"a\U="' eq "a="; +print "ok $test - [perl #80368] qq \n"; $test++; + +sub Function_with_side_effects { $_ = "sidekick function called" } +print "not " unless + (eval '${Function_with_side_effects,\$_}' || $@) + eq "sidekick function called"; +print "ok $test - \${...} where {...} looks like hash\n"; $test++; diff --git a/t/comp/fold.t b/t/comp/fold.t index 844ee41..4fa0734 100644 --- a/t/comp/fold.t +++ b/t/comp/fold.t @@ -4,7 +4,7 @@ # we've not yet verified that use works. # use strict; -print "1..29\n"; +print "1..30\n"; my $test = 0; # Historically constant folding was performed by evaluating the ops, and if @@ -171,3 +171,12 @@ my @values; for (1,2) { for (\(1+3)) { push @values, $$_; $$_++ } } is "@values", "4 4", '\1+3 folding making modification affect future retvals'; + +{ + BEGIN { $^W = 0; $::{u} = \undef } + my $w; + local $SIG{__WARN__} = sub { ++$w }; + () = 1 + u; + is $w, 1, '1+undef_constant is not folded outside warninsg scope'; + BEGIN { $^W = 1 } +} diff --git a/t/comp/hints.t b/t/comp/hints.t index 9a08854..307f298 100644 --- a/t/comp/hints.t +++ b/t/comp/hints.t @@ -3,7 +3,7 @@ # Tests the scoping of $^H and %^H BEGIN { - @INC = qw(. ../lib); + @INC = qw(. ../lib ../ext/re); chdir 't'; } @@ -122,7 +122,12 @@ BEGIN { my $res; BEGIN { $^H{73174} = "foo" } BEGIN { $res = ($^H{73174} // "") } - "" =~ /\x{100}/i; # forces loading of utf8.pm, which used to reset %^H + # /x{100}/i forces loading of utf8.pm, which used to reset %^H + eval '"" =~ /\x{100}/i; 1' + # Allow miniperl to fail this regexp compilation (effectively skip + # the test) in case tables have not been build, but require real + # perl to succeed. + or defined &DynaLoader::boot_DynaLoader and die; BEGIN { $res .= '-' . ($^H{73174} // "")} $res .= '-' . ($^H{73174} // ""); print $res eq "foo-foo-" ? "" : "not ", diff --git a/t/comp/proto.t b/t/comp/proto.t index 47ebf74..f984aaf 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -500,11 +500,11 @@ star(\*FOO, sub { print "ok $i - star(\\*FOO)\n"; }); $i++; star2 FOO, BAR, sub { - print "not " unless $_[0] eq 'FOO' and $_[1] eq 'BAR'; + print "not " unless $_[0] eq 'FOO' and $_[1] eq 'quux'; print "ok $i - star2 FOO, BAR\n"; }; $i++; star2(Bar::BAZ, FOO, sub { - print "not " unless $_[0] eq 'Bar::BAZ' and $_[1] eq 'FOO'; + print "not " unless $_[0] eq 'quuz' and $_[1] eq 'FOO'; print "ok $i - star2(Bar::BAZ, FOO)\n" }); $i++; star2 BAR(), FOO, sub { diff --git a/t/comp/require.t b/t/comp/require.t index 4eafce4..f817527 100644 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '.'; - push @INC, '../lib'; + push @INC, '../lib', '../ext/re'; } sub do_require { diff --git a/t/harness b/t/harness index 2b47313..cb3d8d7 100644 --- a/t/harness +++ b/t/harness @@ -206,6 +206,14 @@ if ($^O eq 'MSWin32') { @tests=grep /$re/, @tests if $re; +# Allow eg ./perl t/harness t/op/lc.t +for (@tests) { + if (-f "../$_") { + $_ = "../$_"; + s{^\.\./t/}{}; + } +} + my %options; my $type = 'perl'; @@ -219,6 +227,7 @@ my $h = TAP::Harness->new({ color => $color, jobs => $jobs, verbosity => $Verbose, + timer => $ENV{HARNESS_TIMER}, exec => sub { my ($harness, $test) = @_; diff --git a/t/io/fs.t b/t/io/fs.t index 0d3f435..628a2ca 100644 --- a/t/io/fs.t +++ b/t/io/fs.t @@ -469,7 +469,10 @@ ok(-d $tmpdir1, "rename on directories working"); # Calling unlink on a directory without -U and privileges will always fail, but # it should set errno to EISDIR even though unlink(2) is never called. -{ +SKIP: { + if (is_miniperl && !eval 'require Errno') { + skip "Errno not built yet", 3; + } require Errno; my $tmpdir = tempfile(); diff --git a/t/io/open.t b/t/io/open.t index 3e6efb4..3817bdd 100644 --- a/t/io/open.t +++ b/t/io/open.t @@ -438,23 +438,29 @@ pass("no crash when open autovivifies glob in freed package"); is($WARN, '', "ignore warning on embedded nul with no warnings syscalls"); } - use Errno 'ENOENT'; - # check handling of multiple arguments, which the original patch - # mis-handled - $! = 0; - is (unlink($fn, $fn), 0, "check multiple arguments to unlink"); - is($!+0, ENOENT, "check errno"); - $! = 0; - is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod"); - is($!+0, ENOENT, "check errno"); - $! = 0; - is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime"); - is($!+0, ENOENT, "check errno"); SKIP: { - skip "no chown", 2 unless $Config{d_chown}; + if (is_miniperl && !eval 'require Errno') { + skip "Errno not built yet", 8; + } + require Errno; + import Errno 'ENOENT'; + # check handling of multiple arguments, which the original patch + # mis-handled $! = 0; - is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown"); - is($!+0, ENOENT, "check errno"); + is (unlink($fn, $fn), 0, "check multiple arguments to unlink"); + is($!+0, &ENOENT, "check errno"); + $! = 0; + is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod"); + is($!+0, &ENOENT, "check errno"); + $! = 0; + is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime"); + is($!+0, &ENOENT, "check errno"); + SKIP: { + skip "no chown", 2 unless $Config{d_chown}; + $! = 0; + is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown"); + is($!+0, &ENOENT, "check errno"); + } } is (unlink($fn), 0, "unlink fails with \\0 in name"); diff --git a/t/lib/strict/subs b/t/lib/strict/subs index 5fd0b03..095adee 100644 --- a/t/lib/strict/subs +++ b/t/lib/strict/subs @@ -108,7 +108,7 @@ use strict 'vars' ; $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8. Execution of - aborted due to compilation errors. ######## @@ -120,7 +120,7 @@ no strict; } $joe = 1 ; EXPECT -Global symbol "$joe" requires explicit package name at - line 6. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6. Execution of - aborted due to compilation errors. ######## diff --git a/t/lib/strict/vars b/t/lib/strict/vars index c6cb067..b571751 100644 --- a/t/lib/strict/vars +++ b/t/lib/strict/vars @@ -49,7 +49,7 @@ EXPECT use strict ; $fred ; EXPECT -Global symbol "$fred" requires explicit package name at - line 4. +Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4. Execution of - aborted due to compilation errors. ######## @@ -57,7 +57,7 @@ Execution of - aborted due to compilation errors. use strict 'vars' ; <$fred> ; EXPECT -Global symbol "$fred" requires explicit package name at - line 4. +Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4. Execution of - aborted due to compilation errors. ######## @@ -65,7 +65,7 @@ Execution of - aborted due to compilation errors. use strict 'vars' ; local $fred ; EXPECT -Global symbol "$fred" requires explicit package name at - line 4. +Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 4. Execution of - aborted due to compilation errors. ######## @@ -78,7 +78,7 @@ use strict 'vars' ; $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 8. -Global symbol "$joe" requires explicit package name at - line 8. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8. Execution of - aborted due to compilation errors. ######## @@ -93,7 +93,7 @@ use open qw( :utf8 :std ); $jòè = 1 ; EXPECT Variable "$jòè" is not imported at - line 10. -Global symbol "$jòè" requires explicit package name at - line 10. +Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at - line 10. Execution of - aborted due to compilation errors. ######## @@ -105,7 +105,7 @@ no strict; } $joe = 1 ; EXPECT -Global symbol "$joe" requires explicit package name at - line 6. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6. Execution of - aborted due to compilation errors. ######## @@ -138,7 +138,7 @@ $joe = 1 ; require "./abc"; EXPECT Variable "$joe" is not imported at ./abc line 2. -Global symbol "$joe" requires explicit package name at ./abc line 2. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at ./abc line 2. Compilation failed in require at - line 2. ######## @@ -155,7 +155,7 @@ $jòè = 1 ; require "./abc"; EXPECT Variable "$jòè" is not imported at ./abc line 4. -Global symbol "$jòè" requires explicit package name at ./abc line 4. +Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at ./abc line 4. Compilation failed in require at - line 4. ######## @@ -168,7 +168,7 @@ $joe = 1 ; use abc; EXPECT Variable "$joe" is not imported at abc.pm line 2. -Global symbol "$joe" requires explicit package name at abc.pm line 2. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at abc.pm line 2. Compilation failed in require at - line 2. BEGIN failed--compilation aborted at - line 2. ######## @@ -186,7 +186,7 @@ $jòè = 1 ; use abc; EXPECT Variable "$jòè" is not imported at abc.pm line 4. -Global symbol "$jòè" requires explicit package name at abc.pm line 4. +Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at abc.pm line 4. Compilation failed in require at - line 4. BEGIN failed--compilation aborted at - line 4. ######## @@ -203,20 +203,20 @@ $p = 0b12; --FILE-- use abc; EXPECT -Global symbol "$f" requires explicit package name at abc.pm line 3. -Global symbol "$k" requires explicit package name at abc.pm line 3. -Global symbol "$g" requires explicit package name at abc.pm line 4. -Global symbol "$l" requires explicit package name at abc.pm line 4. -Global symbol "$c" requires explicit package name at abc.pm line 5. -Global symbol "$h" requires explicit package name at abc.pm line 5. -Global symbol "$m" requires explicit package name at abc.pm line 5. -Global symbol "$d" requires explicit package name at abc.pm line 6. -Global symbol "$i" requires explicit package name at abc.pm line 6. -Global symbol "$n" requires explicit package name at abc.pm line 6. -Global symbol "$e" requires explicit package name at abc.pm line 7. -Global symbol "$j" requires explicit package name at abc.pm line 7. -Global symbol "$o" requires explicit package name at abc.pm line 7. -Global symbol "$p" requires explicit package name at abc.pm line 8. +Global symbol "$f" requires explicit package name (did you forget to declare "my $f"?) at abc.pm line 3. +Global symbol "$k" requires explicit package name (did you forget to declare "my $k"?) at abc.pm line 3. +Global symbol "$g" requires explicit package name (did you forget to declare "my $g"?) at abc.pm line 4. +Global symbol "$l" requires explicit package name (did you forget to declare "my $l"?) at abc.pm line 4. +Global symbol "$c" requires explicit package name (did you forget to declare "my $c"?) at abc.pm line 5. +Global symbol "$h" requires explicit package name (did you forget to declare "my $h"?) at abc.pm line 5. +Global symbol "$m" requires explicit package name (did you forget to declare "my $m"?) at abc.pm line 5. +Global symbol "$d" requires explicit package name (did you forget to declare "my $d"?) at abc.pm line 6. +Global symbol "$i" requires explicit package name (did you forget to declare "my $i"?) at abc.pm line 6. +Global symbol "$n" requires explicit package name (did you forget to declare "my $n"?) at abc.pm line 6. +Global symbol "$e" requires explicit package name (did you forget to declare "my $e"?) at abc.pm line 7. +Global symbol "$j" requires explicit package name (did you forget to declare "my $j"?) at abc.pm line 7. +Global symbol "$o" requires explicit package name (did you forget to declare "my $o"?) at abc.pm line 7. +Global symbol "$p" requires explicit package name (did you forget to declare "my $p"?) at abc.pm line 8. Illegal binary digit '2' at abc.pm line 8, at end of line abc.pm has too many errors. Compilation failed in require at - line 1. @@ -243,7 +243,7 @@ eval { print STDERR $@; $joe = 1 ; EXPECT -Global symbol "$joe" requires explicit package name at - line 6. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 6. Execution of - aborted due to compilation errors. ######## @@ -255,8 +255,8 @@ eval { print STDERR $@; $joe = 1 ; EXPECT -Global symbol "$joe" requires explicit package name at - line 5. -Global symbol "$joe" requires explicit package name at - line 8. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 5. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8. Execution of - aborted due to compilation errors. ######## @@ -270,7 +270,7 @@ print STDERR $@; $joe = 1 ; EXPECT Variable "$joe" is not imported at - line 9. -Global symbol "$joe" requires explicit package name at - line 9. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 9. Execution of - aborted due to compilation errors. ######## @@ -286,7 +286,7 @@ print STDERR $@; $jòè = 1 ; EXPECT Variable "$jòè" is not imported at - line 11. -Global symbol "$jòè" requires explicit package name at - line 11. +Global symbol "$jòè" requires explicit package name (did you forget to declare "my $jòè"?) at - line 11. Execution of - aborted due to compilation errors. ######## @@ -307,7 +307,7 @@ eval q[ $joe = 1 ; ]; print STDERR $@; EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 3. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at (eval 1) line 3. ######## # Check scope of pragma with eval @@ -316,7 +316,7 @@ eval ' $joe = 1 ; '; print STDERR $@ ; EXPECT -Global symbol "$joe" requires explicit package name at (eval 1) line 2. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at (eval 1) line 2. ######## # Check scope of pragma with eval @@ -327,7 +327,7 @@ eval ' '; print STDERR $@; $joe = 1 ; EXPECT -Global symbol "$joe" requires explicit package name at - line 8. +Global symbol "$joe" requires explicit package name (did you forget to declare "my $joe"?) at - line 8. Execution of - aborted due to compilation errors. ######## @@ -340,9 +340,9 @@ $ret = eval q{ print $x; }; print $@; print "ok 2\n" unless defined $ret; EXPECT -Global symbol "$x" requires explicit package name at (eval 1) line 1. +Global symbol "$x" requires explicit package name (did you forget to declare "my $x"?) at (eval 1) line 1. ok 1 -Global symbol "$x" requires explicit package name at (eval 2) line 1. +Global symbol "$x" requires explicit package name (did you forget to declare "my $x"?) at (eval 2) line 1. ok 2 ######## @@ -399,7 +399,7 @@ sub foo { $fred ; EXPECT Variable "$fred" is not imported at - line 8. -Global symbol "$fred" requires explicit package name at - line 8. +Global symbol "$fred" requires explicit package name (did you forget to declare "my $fred"?) at - line 8. Execution of - aborted due to compilation errors. ######## @@ -414,7 +414,7 @@ sub fòò { $frèd ; EXPECT Variable "$frèd" is not imported at - line 10. -Global symbol "$frèd" requires explicit package name at - line 10. +Global symbol "$frèd" requires explicit package name (did you forget to declare "my $frèd"?) at - line 10. Execution of - aborted due to compilation errors. ######## @@ -502,7 +502,7 @@ use strict 'vars'; no warnings; "@i_like_crackers"; EXPECT -Global symbol "@i_like_crackers" requires explicit package name at - line 7. +Global symbol "@i_like_crackers" requires explicit package name (did you forget to declare "my @i_like_crackers"?) at - line 7. Execution of - aborted due to compilation errors. ######## @@ -510,15 +510,15 @@ Execution of - aborted due to compilation errors. use strict 'vars'; @k = <$k>; EXPECT -Global symbol "@k" requires explicit package name at - line 4. -Global symbol "$k" requires explicit package name at - line 4. +Global symbol "@k" requires explicit package name (did you forget to declare "my @k"?) at - line 4. +Global symbol "$k" requires explicit package name (did you forget to declare "my $k"?) at - line 4. Execution of - aborted due to compilation errors. ######## # [perl #26910] hints not propagated into (?{...}) use strict 'vars'; qr/(?{$foo++})/; EXPECT -Global symbol "$foo" requires explicit package name at - line 3. +Global symbol "$foo" requires explicit package name (did you forget to declare "my $foo"?) at - line 3. Execution of - aborted due to compilation errors. ######## # Regex compilation errors weren't UTF-8 clean. @@ -527,7 +527,7 @@ use utf8; use open qw( :utf8 :std ); qr/(?{$fòò++})/; EXPECT -Global symbol "$fòò" requires explicit package name at - line 5. +Global symbol "$fòò" requires explicit package name (did you forget to declare "my $fòò"?) at - line 5. Execution of - aborted due to compilation errors. ######## # [perl #73712] 'Variable is not imported' should be suppressible diff --git a/t/lib/warnings/mg b/t/lib/warnings/mg index 9e3652b..7eb8428 100644 --- a/t/lib/warnings/mg +++ b/t/lib/warnings/mg @@ -44,6 +44,29 @@ EXPECT ######## # mg.c +use warnings 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{__WARN__} = sub { warn shift =~ s/\0/\\0/rugs }; +$SIG{"INT"} = "fr\0d"; kill "INT",$$; +EXPECT +SIGINT handler "fr\0d" not defined. +######## +# mg.c +use warnings 'signal' ; +use open ":std", ":utf8"; +use utf8; +if ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') { + print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "프레드"; kill "INT",$$; +EXPECT +SIGINT handler "프레드" not defined. +######## +# mg.c use warnings 'uninitialized'; 'foo' =~ /(foo)/; oct $3; diff --git a/t/lib/warnings/regcomp b/t/lib/warnings/regcomp index b55959e..f62f5f1 100644 --- a/t/lib/warnings/regcomp +++ b/t/lib/warnings/regcomp @@ -1,5 +1,6 @@ regcomp.c These tests have been moved to t/re/reg_mesg.t - except for those that explicitly test line numbers. + except for those that explicitly test line numbers + and those that don't have a <-- HERE in them. __END__ use warnings 'regexp'; @@ -7,3 +8,25 @@ $r=qr/(??{ q"\\b+" })/; "a" =~ /a$r/; # warning should come from this line EXPECT \b+ matches null string many times in regex; marked by <-- HERE in m/\b+ <-- HERE / at - line 3. +######## +# regcomp.c +use warnings 'digit' ; +my $a = qr/\o{1238456}\x{100}/; +my $a = qr/[\o{6548321}]\x{100}/; +no warnings 'digit' ; +my $a = qr/\o{1238456}\x{100}/; +my $a = qr/[\o{6548321}]\x{100}/; +EXPECT +Non-octal character '8'. Resolved as "\o{123}" at - line 3. +Non-octal character '8'. Resolved as "\o{654}" at - line 4. +######## +# regcomp.c.c +use warnings; +$a = qr/\c,/; +$a = qr/[\c,]/; +no warnings 'syntax'; +$a = qr/\c,/; +$a = qr/[\c,]/; +EXPECT +"\c," is more clearly written simply as "l" at - line 3. +"\c," is more clearly written simply as "l" at - line 4. diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv index f09a97c..188e9c6 100644 --- a/t/lib/warnings/sv +++ b/t/lib/warnings/sv @@ -411,7 +411,7 @@ $x = "ABC"; ++$x; $x = "ABC123"; ++$x; $x = " +10"; ++$x; EXPECT -Argument "a_c" treated as 0 in increment (++) at - line 5. -Argument "(?^:abc)" treated as 0 in increment (++) at - line 6. +Argument "a_c" isn't numeric in preincrement (++) at - line 5. +Argument "(?^:abc)" isn't numeric in preincrement (++) at - line 6. Argument "123x" isn't numeric in preincrement (++) at - line 7. Argument "123e" isn't numeric in preincrement (++) at - line 8. diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index 39d3695..8c0158a 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -783,15 +783,14 @@ use warnings "ambiguous"; print for keys %+; # should not warn EXPECT ######## -# toke.c +# toke.c [This does not warn any more.] sub fred {}; -fred ; sub hank : lvalue {$_} --hank; # This should *not* warn [perl #77240] EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 3. ######## -# toke.c +# toke.c [This does not warn any more.] $^W = 0 ; sub fred {} ; -fred ; @@ -803,19 +802,15 @@ sub fred {} ; } -fred ; EXPECT -Ambiguous use of -fred resolved as -&fred() at - line 4. -Ambiguous use of -fred resolved as -&fred() at - line 9. -Ambiguous use of -fred resolved as -&fred() at - line 11. ######## -# toke.c +# toke.c [This does not warn any more.] use utf8; use open qw( :utf8 :std ); sub frèd {}; -frèd ; EXPECT -Ambiguous use of -frèd resolved as -&frèd() at - line 5. ######## -# toke.c +# toke.c [This does not warn any more.] $^W = 0 ; use utf8; use open qw( :utf8 :std ); @@ -829,19 +824,15 @@ sub frèd {} ; } -frèd ; EXPECT -Ambiguous use of -frèd resolved as -&frèd() at - line 6. -Ambiguous use of -frèd resolved as -&frèd() at - line 11. -Ambiguous use of -frèd resolved as -&frèd() at - line 13. ######## -# toke.c +# toke.c [This does not warn any more.] use utf8; use open qw( :utf8 :std ); sub ᒍᒘᒊ {}; -ᒍᒘᒊ ; EXPECT -Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 5. ######## -# toke.c +# toke.c [This does not warn any more.] $^W = 0 ; use utf8; use open qw( :utf8 :std ); @@ -855,9 +846,6 @@ sub ᒍᒘᒊ {} ; } -ᒍᒘᒊ ; EXPECT -Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 6. -Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 11. -Ambiguous use of -ᒍᒘᒊ resolved as -&ᒍᒘᒊ() at - line 13. ######## # toke.c open FOO || time; diff --git a/t/op/anonsub.t b/t/op/anonsub.t index 6b8745f..d65acfe 100644 --- a/t/op/anonsub.t +++ b/t/op/anonsub.t @@ -91,3 +91,23 @@ undef &{$x=sub{}}; $x->(); EXPECT Undefined subroutine called at - line 4. +######## +# NAME anon constant clobbering __ANON__ +sub __ANON__ { "42\n" } +print __ANON__; +sub(){3}; +EXPECT +42 +######## +# NAME undef &anon giving it a freed GV +$_ = sub{}; +delete $::{__ANON__}; +undef &$_; # SvREFCNT_dec + inc on a GV with a refcnt of 1 + # so now SvTYPE(CvGV(anon)) is 0xff == freed +if (!eval { require B }) { # miniperl, presumably + print "__ANON__\n"; +} else { + print B::svref_2object($_)->GV->NAME, "\n"; +} +EXPECT +__ANON__ diff --git a/t/op/avhv.t b/t/op/avhv.t index d301fad..39a54dc 100644 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -5,7 +5,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + require './test.pl'; + set_up_inc('../lib'); } require Tie::Array; @@ -20,7 +21,6 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -require './test.pl'; plan(tests => 40); # Helper function to check the typical error message. diff --git a/t/op/blocks.t b/t/op/blocks.t index fb15eee..bfab9e0 100644 --- a/t/op/blocks.t +++ b/t/op/blocks.t @@ -2,8 +2,8 @@ BEGIN { chdir 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan tests => 7; diff --git a/t/op/caller.t b/t/op/caller.t index c43f576..e0534ba 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -31,7 +31,7 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo { @c = caller(0) } my $fooref = delete $::{foo}; $fooref -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); +is( $c[3], "main::foo", "deleted subroutine name" ); ok( $c[4], "hasargs true with deleted sub" ); BEGIN { @@ -66,7 +66,7 @@ ok( $c[4], "hasargs true with anon sub" ); sub foo2 { f() } my $fooref2 = delete $::{foo2}; $fooref2 -> (); -is( $c[3], "main::__ANON__", "deleted subroutine name" ); +is( $c[3], "main::foo2", "deleted subroutine name" ); ok( $c[4], "hasargs true with deleted sub" ); # See if caller() returns the correct warning mask diff --git a/t/op/chdir.t b/t/op/chdir.t index 2c6535b..d785285 100644 --- a/t/op/chdir.t +++ b/t/op/chdir.t @@ -1,16 +1,15 @@ #!./perl -w BEGIN { + # We really want to know if chdir is working, as the build process will + # all go wrong if it is not. So avoid clearing @INC under miniperl. + @INC = () if defined &DynaLoader::boot_DynaLoader; + # We're not going to chdir() into 't' because we don't know if # chdir() works! Instead, we'll hedge our bets and put both # possibilities into @INC. - @INC = qw(t . lib ../lib); + unshift @INC, qw(t . lib ../lib); require "test.pl"; - # Really want to know if chdir is working, as the build process will all go - # wrong if it is not. - if (is_miniperl() && !eval {require File::Spec::Functions; 1}) { - push @INC, qw(dist/Cwd/lib dist/Cwd ../dist/Cwd/lib ../dist/Cwd); - } plan(tests => 48); } diff --git a/t/op/closure.t b/t/op/closure.t index 82e65c5..569724f 100644 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -8,8 +8,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use Config; diff --git a/t/op/coreamp.t b/t/op/coreamp.t index aef3260..ffd02df 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); + @INC = qw(. ../lib ../dist/if); require "test.pl"; $^P |= 0x100; } diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 58f7d5f..36a6a10 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -80,6 +80,9 @@ while(<$kh>) { } if ($hpcode) { $tests ++; + # __FILE__ won’t fold with warnings on, and then we get + # ‘(eval 21)’ vs ‘(eval 22)’. + no warnings 'numeric'; $core = $bd->coderef2text(eval $hpcode =~ s/my/CORE::/r or die); $my = $bd->coderef2text(eval $hpcode or die); is $my, $core, "precedence of CORE::$word without parens"; diff --git a/t/op/eval.t b/t/op/eval.t index f404df5..fcfe675 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan(tests => 132); diff --git a/t/op/exp.t b/t/op/exp.t index d132b1f..eb53f1b 100644 --- a/t/op/exp.t +++ b/t/op/exp.t @@ -1,39 +1,91 @@ #!./perl +# Simple tests for the basic math functions. + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; } -plan tests => 16; +use Config; + +plan tests => 31; # compile time evaluation +eval { $s = sqrt(-1) }; # Kind of compile time. +like($@, qr/sqrt of -1/, 'compile time sqrt(-1) fails'); + +$s = sqrt(0); +is($s, 0, 'compile time sqrt(0)'); + +$s = sqrt(1); +is($s, 1, 'compile time sqrt(1)'); + $s = sqrt(2); is(substr($s,0,5), '1.414', 'compile time sqrt(2) == 1.414'); +$s = exp(0); +is($s, 1, 'compile time exp(0) == 1'); + $s = exp(1); is(substr($s,0,7), '2.71828', 'compile time exp(1) == e'); +eval { $s = log(0) }; # Kind of compile time. +like($@, qr/log of 0/, 'compile time log(0) fails'); + +$s = log(1); +is($s, 0, 'compile time log(1) == 0'); + +$s = log(2); +is(substr($s,0,5), '0.693', 'compile time log(2)'); + cmp_ok(exp(log(1)), '==', 1, 'compile time exp(log(1)) == 1'); +cmp_ok(round(atan2(1, 2)), '==', '0.463647609', "atan2(1, 2)"); + # run time evaluation +$x0 = 0; $x1 = 1; $x2 = 2; + +eval { $s = sqrt(-$x1) }; +like($@, qr/sqrt of -1/, 'run time sqrt(-1) fails'); + +$s = sqrt($x0); +is($s, 0, 'run time sqrt(0)'); + +$s = sqrt($x1); +is($s, 1, 'run time sqrt(1)'); + $s = sqrt($x2); is(substr($s,0,5), '1.414', 'run time sqrt(2) == 1.414'); +$s = exp($x0); +is($s, 1, 'run time exp(0) = 1'); + $s = exp($x1); is(substr($s,0,7), '2.71828', 'run time exp(1) = e'); +eval { $s = log($x0) }; +like($@, qr/log of 0/, 'run time log(0) fails'); + +$s = log($x1); +is($s, 0, 'compile time log(1) == 0'); + +$s = log($x2); +is(substr($s,0,5), '0.693', 'run time log(2)'); + cmp_ok(exp(log($x1)), '==', 1, 'run time exp(log(1)) == 1'); -# tests for transcendental functions +# NOTE: do NOT test the trigonometric functions at [+-]Pi +# and expect to get exact results like 0, 1, -1, because +# you may not be able to feed them exactly [+-]Pi given +# all the variations of different long doubles. -my $pi = 3.1415926535897931160; -my $pi_2 = 1.5707963267948965580; +my $pi_2 = 1.5707963267949; sub round { my $result = shift; @@ -42,18 +94,28 @@ sub round { # sin() tests cmp_ok(sin(0), '==', 0.0, 'sin(0) == 0'); -cmp_ok(round(sin($pi)), '==', 0.0, 'sin(pi) == 0'); -cmp_ok(round(sin(-1 * $pi)), '==', 0.0, 'sin(-pi) == 0'); -cmp_ok(round(sin($pi_2)), '==', 1.0, 'sin(pi/2) == 1'); -cmp_ok(round(sin(-1 * $pi_2)), '==', -1.0, 'sin(-pi/2) == -1'); +cmp_ok(abs(sin($pi_2) - 1), '<', 1e-9, 'sin(pi/2) == 1'); +cmp_ok(abs(sin(-1 * $pi_2) - -1), '<', 1e-9, 'sin(-pi/2) == -1'); + +cmp_ok(round(sin($x1)), '==', '0.841470985', "sin(1)"); # cos() tests cmp_ok(cos(0), '==', 1.0, 'cos(0) == 1'); -cmp_ok(round(cos($pi)), '==', -1.0, 'cos(pi) == -1'); -cmp_ok(round(cos(-1 * $pi)), '==', -1.0, 'cos(-pi) == -1'); -cmp_ok(round(cos($pi_2)), '==', 0.0, 'cos(pi/2) == 0'); -cmp_ok(round(cos(-1 * $pi_2)), '==', 0.0, 'cos(-pi/2) == 0'); - -# atan2() tests were removed due to differing results from calls to -# atan2() on various OS's and architectures. See perlport.pod for -# more information. +cmp_ok(abs(cos($pi_2)), '<', 1e-9, 'cos(pi/2) == 0'); +cmp_ok(abs(cos(-1 * $pi_2)), '<', 1e-9, 'cos(-pi/2) == 0'); + +cmp_ok(round(cos($x1)), '==', '0.540302306', "cos(1)"); + +cmp_ok(round(atan2($x1, $x2)), '==', '0.463647609', "atan2($x1, $x2)"); + +# atan2() tests testing with -0.0, 0.0, -1.0, 1.0 were removed due to +# differing results from calls to atan2() on various OS's and +# architectures. See perlport.pod for more information. + +SKIP: { + unless ($Config{usequadmath}) { + skip "need usequadmath", 1; + } + # For quadmath we have a known precision. + is(sqrt(2), '1.4142135623730950488016887242097', "quadmath sqrt"); +} diff --git a/t/op/filetest.t b/t/op/filetest.t index 7316442..91ebe9c 100644 --- a/t/op/filetest.t +++ b/t/op/filetest.t @@ -5,8 +5,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc(qw '../lib ../cpan/Perl-OSType/lib'); } plan(tests => 53 + 27*14); diff --git a/t/op/gv.t b/t/op/gv.t index f1ef962..081d280 100644 --- a/t/op/gv.t +++ b/t/op/gv.t @@ -6,13 +6,13 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use warnings; -plan( tests => 267 ); +plan( tests => 271 ); # type coercion on assignment $foo = 'foo'; @@ -490,6 +490,9 @@ is join("-", eval "&yarrow(1..10)"), '4-5-6', 'const list ignores & args'; is prototype "yarrow", "", 'const list has "" prototype'; is eval "yarrow", 3, 'const list in scalar cx returns length'; +$::{borage} = \&ok; +eval 'borage("sub ref in stash")' or fail "sub ref in stash"; + { use vars qw($glook $smek $foof); # Check reference assignment isn't affected by the SV type (bug #38439) @@ -512,7 +515,7 @@ is eval "yarrow", 3, 'const list in scalar cx returns length'; format = . -foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { +foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; @@ -1063,6 +1066,27 @@ is runperl(prog => "Undefined subroutine &main::foo called at -e line 1.\n", "gv_try_downgrade does not anonymise CVs referenced elsewhere"; +package glob_constant_test { + sub foo { 42 } + use constant bar => *foo; + BEGIN { undef *foo } + ::is eval { bar->() }, eval { &{+bar} }, + 'glob_constant->() is not mangled at compile time'; + ::is "$@", "", 'no error from eval { &{+glob_constant} }'; +} + +{ + my $free2; + local $SIG{__WARN__} = sub { ++$free2 if shift =~ /Attempt to free/ }; + my $handleref; + my $proxy = \$handleref; + open $$proxy, "TEST"; + delete $::{*$handleref{NAME}}; # delete *main::_GEN_xxx + undef $handleref; + is $free2, undef, + 'no double free because of bad rv2gv/newGVgen refcounting'; +} + # Look away, please. # This violates perl's internal structures by fiddling with stashes in a # way that should never happen, but perl should not start trying to free @@ -1087,6 +1111,15 @@ undef $::{_119051again}; # CvGV, it still gets a fake one eval { $y->() }; pass "No crash due to CvGV pointing to glob copy in the stash"; +# Aliasing should disable no-common-vars optimisation. +{ + *x = *y; + $x = 3; + ($x, my $z) = (1, $y); + is $z, 3, 'list assignment after aliasing [perl #89646]'; +} + + __END__ Perl Rules diff --git a/t/op/hash.t b/t/op/hash.t index 5f4c143..429eb38 100644 --- a/t/op/hash.t +++ b/t/op/hash.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use strict; diff --git a/t/op/hexfp.t b/t/op/hexfp.t index 9a1d045..d055380 100644 --- a/t/op/hexfp.t +++ b/t/op/hexfp.t @@ -6,9 +6,8 @@ use Config; BEGIN { chdir 't' if -d 't'; + unshift @INC, '../lib'; require './test.pl'; - eval '0x0p0'; - print "# $@\n"; } plan(tests => 79); @@ -103,14 +102,15 @@ is(0xAB.CDP+0, 171.80078125); # Underbars. is(0xa_b.c_dp+1_2, 703696); -# Note that the hexfloat representation is not unique -# since the exponent can be shifted: no different from -# 3e4 cf 30e3 cf 30000. +# Note that the hexfloat representation is not unique since the +# exponent can be shifted, and the hexdigits with it: this is no +# different from 3e4 cf 30e3 cf 30000. The shifting of the hexdigits +# makes it look stranger, though: 0xap1 == 0x5p2. # Needs to use within() instead of is() because of long doubles. -within(0x1.999999999999ap-4, 0.1, 1e-9); -within(0x3.3333333333333p-5, 0.1, 1e-9); -within(0xc.ccccccccccccdp-7, 0.1, 1e-9); +within(0x1.99999999999ap-4, 0.1, 1e-9); +within(0x3.333333333333p-5, 0.1, 1e-9); +within(0xc.cccccccccccdp-7, 0.1, 1e-9); my $warn; diff --git a/t/op/inc.t b/t/op/inc.t index 5135ab7..6003a6c 100644 --- a/t/op/inc.t +++ b/t/op/inc.t @@ -242,7 +242,8 @@ EOC $found = 1; last; } -die "Could not find a value which overflows the mantissa" unless $found; + +ok($found, "found a NV value which overflows the mantissa"); # these will segfault if they fail diff --git a/t/op/inccode.t b/t/op/inccode.t index 1a0b919..016b425 100644 --- a/t/op/inccode.t +++ b/t/op/inccode.t @@ -4,8 +4,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); require './test.pl'; + set_up_inc('../lib'); } use Config; diff --git a/t/op/index.t b/t/op/index.t index 78faeb6..2bb6cd1 100644 --- a/t/op/index.t +++ b/t/op/index.t @@ -2,8 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; - require './test.pl'; require './charset_tools.pl'; + require './test.pl'; + set_up_inc('../lib'); + require './charset_tools.pl'; } use strict; diff --git a/t/op/infnan.t b/t/op/infnan.t new file mode 100644 index 0000000..8267e24 --- /dev/null +++ b/t/op/infnan.t @@ -0,0 +1,194 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} + +use strict; + +use Config; + +BEGIN { + if ($^O eq 'aix' && $Config{uselongdouble}) { + # FWIW: NaN actually seems to be working decently, + # but Inf is completely broken (e.g. Inf + 0 -> NaN). + skip_all "$^O with long doubles does not have sane inf/nan"; + } +} + +my $PInf = "Inf" + 0; +my $NInf = "-Inf" + 0; +my $NaN = "NaN" + 0; + +my @PInf = ("Inf", "inf", "INF", "+Inf", + "Infinity", "INFINITE", + "1.#INF", "1#INF"); +my @NInf = map { "-$_" } grep { ! /^\+/ } @PInf; + +my @NaN = ("NAN", "nan", "qnan", "SNAN", "NanQ", "NANS", + "1.#QNAN", "+1#SNAN", "-1.#NAN", "1#IND", + "NaN123", "NAN(123)", "nan%", + "nanonano"); # RIP, Robin Williams. + +my @num_fmt = qw(e f g a d u o b x p); + +my $inf_tests = 13 + @num_fmt + 8 + 3 * @PInf + 3 * @NInf + 5 + 3; +my $nan_tests = 8 + @num_fmt + 4 + 2 * @NaN + 3; + +my $infnan_tests = 4; + +plan tests => $inf_tests + $nan_tests + $infnan_tests; + +my $has_inf; +my $has_nan; + +SKIP: { + if ($PInf == 0 && $NInf == 0) { + skip $inf_tests, "no infinity found"; + } + + $has_inf = 1; + + cmp_ok($PInf, '>', 0, "positive infinity"); + cmp_ok($NInf, '<', 0, "negative infinity"); + + cmp_ok($PInf, '>', $NInf, "positive > negative"); + cmp_ok($NInf, '==', -$PInf, "negative == -positive"); + cmp_ok(-$NInf, '==', $PInf, "--negative == positive"); + + is($PInf, "Inf", "$PInf value stringifies as Inf"); + is($NInf, "-Inf", "$NInf value stringifies as -Inf"); + + cmp_ok($PInf * 2, '==', $PInf, "twice Inf is Inf"); + cmp_ok($PInf / 2, '==', $PInf, "half of Inf is Inf"); + + cmp_ok($PInf + 1, '==', $PInf, "Inf + one is Inf"); + cmp_ok($NInf + 1, '==', $NInf, "-Inf + one is -Inf"); + + is(sprintf("%g", $PInf), "Inf", "$PInf sprintf %g is Inf"); + is(sprintf("%a", $PInf), "Inf", "$PInf sprintf %a is Inf"); + + for my $f (@num_fmt) { + is(sprintf("%$f", $PInf), "Inf", "$PInf sprintf %$f is Inf"); + } + + { + local $^W = 0; + + is(sprintf("%c", $PInf), chr(0xFFFD), "$PInf sprintf %c is Inf"); + is(chr($PInf), chr(0xFFFD), "$PInf chr() is U+FFFD"); + + is(sprintf("%c", $NInf), chr(0xFFFD), "$NInf sprintf %c is Inf"); + is(chr($NInf), chr(0xFFFD), "$NInf chr() is U+FFFD"); + + is(pack('C', $PInf), chr(0xFF), "$PInf pack C is 0xFF byte"); + is(pack('c', $PInf), chr(0xFF), "$PInf pack c is 0xFF byte"); + + is(pack('C', $NInf), chr(0xFF), "$NInf pack C is 0xFF byte"); + is(pack('c', $NInf), chr(0xFF), "$NInf pack c is 0xFF byte"); + } + + for my $i (@PInf) { + cmp_ok($i + 0 , '==', $PInf, "$i is +Inf"); + cmp_ok($i, '>', 0, "$i is positive"); + is("@{[$i+0]}", "Inf", "$i value stringifies as Inf"); + } + + for my $i (@NInf) { + cmp_ok($i + 0, '==', $NInf, "$i is -Inf"); + cmp_ok($i, '<', 0, "$i is negative"); + is("@{[$i+0]}", "-Inf", "$i value stringifies as -Inf"); + } + + is($PInf + $PInf, $PInf, "+inf plus +inf is +inf"); + is($NInf + $NInf, $NInf, "-inf plus -inf is -inf"); + + is(1/$PInf, 0, "one per +Inf is zero"); + is(1/$NInf, 0, "one per -Inf is zero"); + + SKIP: { + my $here = "$^O $Config{osvers}"; + if ($here =~ /^hpux 10/) { + skip "$here: pow doesn't generate Inf", 1; + } + is(9**9**9, $PInf, "9**9**9 is Inf"); + } +} + +SKIP: { + my @FInf = qw(Info Infiniti Infinityz); + if ($Config{usequadmath}) { + skip "quadmath strtoflt128() accepts false infinities", scalar @FInf; + } + # Silence "isn't numeric in addition", that's kind of the point. + local $^W = 0; + for my $i (@FInf) { + cmp_ok("$i" + 0, '==', 0, "false infinity $i"); + } +} + +SKIP: { + if ($NaN == 0) { + skip $nan_tests, "no nan found"; + } + + $has_nan = 1; + + cmp_ok($NaN, '!=', $NaN, "NaN is NaN numerically (by not being NaN)"); + ok($NaN eq $NaN, "NaN is NaN stringifically"); + + is("$NaN", "NaN", "$NaN value stringifies as NaN"); + + is("+NaN" + 0, "NaN", "+NaN is NaN"); + is("-NaN" + 0, "NaN", "-NaN is NaN"); + + is($NaN * 2, $NaN, "twice NaN is NaN"); + is($NaN / 2, $NaN, "half of NaN is NaN"); + + is($NaN + 1, $NaN, "NaN + one is NaN"); + + for my $f (@num_fmt) { + is(sprintf("%$f", $NaN), "NaN", "$NaN sprintf %$f is NaN"); + } + + { + local $^W = 0; + + is(sprintf("%c", $NaN), chr(0xFFFD), "$NaN sprintf %c is Inf"); + is(chr($NaN), chr(0xFFFD), "$NaN chr() is U+FFFD"); + + is(pack('C', $NaN), chr(0xFF), "$NaN pack C is 0xFF byte"); + is(pack('c', $NaN), chr(0xFF), "$NaN pack c is 0xFF"); + } + + for my $i (@NaN) { + cmp_ok($i + 0, '!=', $i + 0, "$i is NaN numerically (by not being NaN)"); + is("@{[$i+0]}", "NaN", "$i value stringifies as NaN"); + } + + # is() okay with $NaN because it uses eq. + is($NaN * 0, $NaN, "NaN times zero is NaN"); + is($NaN * 2, $NaN, "NaN times two is NaN"); + + SKIP: { + my $here = "$^O $Config{osvers}"; + if ($here =~ /^hpux 10/) { + skip "$here: pow doesn't generate Inf, so sin(Inf) won't happen", 1; + } + is(sin(9**9**9), $NaN, "sin(9**9**9) is NaN"); + } +} + +SKIP: { + unless ($has_inf && $has_nan) { + skip $infnan_tests, "no both Inf and Nan"; + } + + # is() okay with $NaN because it uses eq. + is($PInf * 0, $NaN, "Inf times zero is NaN"); + is($PInf * $NaN, $NaN, "Inf times NaN is NaN"); + is($PInf + $NaN, $NaN, "Inf plus NaN is NaN"); + is($PInf - $PInf, $NaN, "Inf minus inf is NaN"); +} diff --git a/t/op/kvaslice.t b/t/op/kvaslice.t index e8aa14e..16ee446 100644 --- a/t/op/kvaslice.t +++ b/t/op/kvaslice.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } # use strict; diff --git a/t/op/kvhslice.t b/t/op/kvhslice.t index b30e631..a5357ad 100644 --- a/t/op/kvhslice.t +++ b/t/op/kvhslice.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } # use strict; diff --git a/t/op/lc.t b/t/op/lc.t index bb5d4c1..5cf6664 100644 --- a/t/op/lc.t +++ b/t/op/lc.t @@ -4,9 +4,11 @@ BEGIN { chdir 't'; - @INC = '../lib'; + require './test.pl'; + set_up_inc('../lib'); require Config; import Config; - require './test.pl'; require './charset_tools.pl'; + skip_all_without_unicode_tables(); + require './charset_tools.pl'; require './loc_tools.pl'; # Contains find_utf8_ctype_locale() } diff --git a/t/op/length.t b/t/op/length.t index b144b09..2cba924 100644 --- a/t/op/length.t +++ b/t/op/length.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; require './test.pl'; - @INC = '../lib'; + set_up_inc('../lib'); } plan (tests => 41); diff --git a/t/op/lexsub.t b/t/op/lexsub.t index d5fdcb1..af0fa18 100644 --- a/t/op/lexsub.t +++ b/t/op/lexsub.t @@ -2,12 +2,12 @@ BEGIN { chdir 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); *bar::is = *is; *bar::like = *like; } -plan 120; +plan 143; # -------------------- Errors with feature disabled -------------------- # @@ -88,6 +88,37 @@ sub bar::c { 43 } my $y = if if if; is $y, 42, 'our subs from other packages override all keywords'; } +# Interaction with ‘use constant’ +{ + our sub const; # symtab now has an undefined CV + BEGIN { delete $::{const} } # delete symtab entry; pad entry still exists + use constant const => 3; # symtab now has a scalar ref + # inlining this used to fail an assertion (parentheses necessary): + is(const, 3, 'our sub pointing to "use constant" constant'); +} +# our sub and method confusion +sub F::h { 4242 } +{ + my $called; + our sub h { ++$called; 4343 }; + is((h F),4242, 'our sub symbol translation does not affect meth names'); + undef $called; + print "#"; + print h F; # follows a different path through yylex to intuit_method + print "\n"; + is $called, undef, 'our sub symbol translation & meth names after print' +} +our sub j; +is j + =>, 'j', 'name_of_our_sub => is parsed properly'; +sub _cmp { $a cmp $b } +sub bar::_cmp { $b cmp $a } +{ + package bar; + our sub _cmp; + package main; + is join(" ", sort _cmp split //, 'oursub'), 'u u s r o b', 'sort our_sub' +} # -------------------- state -------------------- # @@ -313,6 +344,83 @@ like runperl( ), qr/syntax error/, 'referencing a state sub after a syntax error does not crash'; +{ + state $stuff; + package A { + state sub foo{ $stuff .= our $AUTOLOAD } + *A::AUTOLOAD = \&foo; + } + A::bar(); + is $stuff, 'A::bar', 'state sub assigned to *AUTOLOAD can autoload'; +} +{ + state sub quire{qr "quires"} + package o { use overload qr => \&quire } + ok "quires" =~ bless([], o::), 'state sub used as overload method'; +} +{ + state sub foo; + *cvgv = \&foo; + local *cvgv2 = *cvgv; + eval 'sub cvgv2 {42}'; # uses the stub already present + is foo, 42, 'defining state sub body via package sub declaration'; +} +{ + local $ENV{PERL5DB} = 'sub DB::DB{}'; + is( + runperl( + switches => [ '-d' ], + progs => [ split "\n", + 'use feature qw - lexical_subs state -; + no warnings q-experimental::lexical_subs-; + sub DB::sub{ print qq|4\n|; goto $DB::sub } + state sub foo {print qq|2\n|} + foo(); + ' + ], + stderr => 1 + ), + "4\n2\n", + 'state subs and DB::sub under -d' + ); + is( + runperl( + switches => [ '-d' ], + progs => [ split "\n", + 'use feature qw - lexical_subs state -; + no warnings q-experimental::lexical_subs-; + sub DB::goto{ print qq|4\n|; $_ = $DB::sub } + state sub foo {print qq|2\n|} + $^P|=0x80; + sub { goto &foo }->(); + print $_ == \&foo ? qq|ok\n| : qq|$_\n|; + ' + ], + stderr => 1 + ), + "4\n2\nok\n", + 'state subs and DB::goto under -d' + ); +} +# This used to fail an assertion, but only as a standalone script +is runperl(switches => ['-lXMfeature=:all'], + prog => 'state sub x {}; undef &x; print defined &x', + stderr => 1), "\n", 'undefining state sub'; +{ + state sub x { is +(caller 0)[3], 'x', 'state sub name in caller' } + x +} +{ + state sub _cmp { $b cmp $a } + is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b', + 'sort state_sub LIST' +} +{ + state sub handel { "" } + print handel, "ok ", curr_test(), + " - no 'No comma allowed' after state sub\n"; + curr_test(curr_test()+1); +} # -------------------- my -------------------- # @@ -606,6 +714,74 @@ like runperl( ), qr/syntax error/, 'referencing a my sub after a syntax error does not crash'; +{ + state $stuff; + package A { + my sub foo{ $stuff .= our $AUTOLOAD } + *A::AUTOLOAD = \&foo; + } + A::bar(); + is $stuff, 'A::bar', 'my sub assigned to *AUTOLOAD can autoload'; +} +{ + my sub quire{qr "quires"} + package mo { use overload qr => \&quire } + ok "quires" =~ bless([], mo::), 'my sub used as overload method'; +} +{ + my sub foo; + *mcvgv = \&foo; + local *mcvgv2 = *mcvgv; + eval 'sub mcvgv2 {42}'; # uses the stub already present + is foo, 42, 'defining my sub body via package sub declaration'; +} +{ + my sub foo; + *mcvgv3 = \&foo; + local *mcvgv4 = *mcvgv3; + eval 'sub mcvgv4 {42}'; # uses the stub already present + undef *mcvgv3; undef *mcvgv4; # leaves the pad with the only reference +} +# We would have crashed by now if it weren’t fixed. +pass "pad taking ownership once more of packagified my-sub"; + +{ + local $ENV{PERL5DB} = 'sub DB::DB{}'; + is( + runperl( + switches => [ '-d' ], + progs => [ split "\n", + 'use feature qw - lexical_subs state -; + no warnings q-experimental::lexical_subs-; + sub DB::sub{ print qq|4\n|; goto $DB::sub } + my sub foo {print qq|2\n|} + foo(); + ' + ], + stderr => 1 + ), + "4\n2\n", + 'my subs and DB::sub under -d' + ); +} +# This used to fail an assertion, but only as a standalone script +is runperl(switches => ['-lXMfeature=:all'], + prog => 'my sub x {}; undef &x; print defined &x', + stderr => 1), "\n", 'undefining my sub'; +{ + my sub x { is +(caller 0)[3], 'x', 'my sub name in caller' } + x +} +{ + my sub _cmp { $b cmp $a } + is join(" ", sort _cmp split //, 'lexsub'), 'x u s l e b', + 'sort my_sub LIST' +} +{ + my sub handel { "" } + print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n"; + curr_test(curr_test()+1); +} # -------------------- Interactions (and misc tests) -------------------- # diff --git a/t/op/magic.t b/t/op/magic.t index 015d41b..afc99c5 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -407,7 +407,7 @@ EOP # argv[0] assignment and by calling prctl() { SKIP: { - skip "We don't have prctl() here", 2 unless $Config{d_prctl_set_name}; + skip "We don't have prctl() here, or we're on Android", 2 unless $Config{d_prctl_set_name} && $^O ne 'android'; # We don't really need these tests. prctl() is tested in the # Kernel, but test it anyway for our sanity. If something doesn't @@ -755,13 +755,14 @@ SKIP: { SKIP: { skip("\$0 check only on Linux and FreeBSD", 2) - unless $^O =~ /^(linux|freebsd)$/ + unless $^O =~ /^(linux|android|freebsd)$/ && open CMDLINE, "/proc/$$/cmdline"; chomp(my $line = scalar ); my $me = (split /\0/, $line)[0]; is $me, $0, 'altering $0 is effective (testing with /proc/)'; close CMDLINE; + skip("\$0 check with 'ps' only on Linux (but not Android) and FreeBSD", 1) if $^O eq 'android'; # perlbug #22811 my $mydollarzero = sub { my($arg) = shift; diff --git a/t/op/method.t b/t/op/method.t index 648f003..31e2ea1 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib lib); + @INC = qw(. ../lib lib ../dist/base/lib); require "test.pl"; } diff --git a/t/op/mkdir.t b/t/op/mkdir.t index d5c04b3..2631526 100644 --- a/t/op/mkdir.t +++ b/t/op/mkdir.t @@ -22,13 +22,25 @@ unless (eval { $ENV{'LC_ALL'} = 'C'; $ENV{LANGUAGE} = 'C'; # GNU locale extension +sub errno_or_skip { + SKIP: { + if (is_miniperl && !eval { local $!; require Errno }) { + skip "Errno not built yet", 1; + } + eval "ok($_[0])"; + } +} + ok(mkdir('blurfl',0777)); ok(!mkdir('blurfl',0777)); -ok($!{EEXIST} || $! =~ /cannot move|exist|denied|unknown/i); +errno_or_skip('$!{EEXIST} || $! =~ /cannot move|exist|denied|unknown/i'); ok(-d 'blurfl'); ok(rmdir('blurfl')); ok(!rmdir('blurfl')); -ok($!{ENOENT} || $! =~ /cannot find|such|exist|not found|not a directory|unknown/i); +errno_or_skip(' + $!{ENOENT} + || $! =~ /cannot find|such|exist|not found|not a directory|unknown/i +'); ok(mkdir('blurfl')); ok(rmdir('blurfl')); diff --git a/t/op/my_stash.t b/t/op/my_stash.t index 6ec7619..1e728e2 100644 --- a/t/op/my_stash.t +++ b/t/op/my_stash.t @@ -4,8 +4,8 @@ package Foo; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan 9; diff --git a/t/op/override.t b/t/op/override.t index ce740ea..1d45617 100644 --- a/t/op/override.t +++ b/t/op/override.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc(qw '../lib ../cpan/Text-ParseWords/lib'); require Config; # load these before we mess with *CORE::GLOBAL::require require 'Config_heavy.pl'; # since runperl will need them } diff --git a/t/op/pack.t b/t/op/pack.t index 357f15b..9340f32 100644 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc(qw '../lib ../dist/Math-BigInt/lib'); } # This is truth in an if statement, and could be a skip message diff --git a/t/op/packagev.t b/t/op/packagev.t index f4e094c..563e444 100644 --- a/t/op/packagev.t +++ b/t/op/packagev.t @@ -2,7 +2,7 @@ BEGIN { chdir 't'; - @INC = '../lib'; + @INC = qw '../lib ../cpan/version/lib'; require './test.pl'; } diff --git a/t/op/push.t b/t/op/push.t index 409920a..f4b034f 100644 --- a/t/op/push.t +++ b/t/op/push.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } @tests = split(/\n/, < 30; diff --git a/t/op/reverse.t b/t/op/reverse.t index 0796614..059ece2 100644 --- a/t/op/reverse.t +++ b/t/op/reverse.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan tests => 26; diff --git a/t/op/smartkve.t b/t/op/smartkve.t index 85eb9e8..bab5d61 100644 --- a/t/op/smartkve.t +++ b/t/op/smartkve.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use strict; use warnings; diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t index ed4b3ec..bbd6372 100644 --- a/t/op/smartmatch.t +++ b/t/op/smartmatch.t @@ -2,8 +2,8 @@ BEGIN { chdir 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use strict; use warnings; diff --git a/t/op/sort.t b/t/op/sort.t index dd60f97..59757e1 100644 --- a/t/op/sort.t +++ b/t/op/sort.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); - require 'test.pl'; + require './test.pl'; + set_up_inc('../lib'); } use warnings; plan( tests => 182 ); diff --git a/t/op/split.t b/t/op/split.t index 7e0008e..2d038ed 100644 --- a/t/op/split.t +++ b/t/op/split.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } -plan tests => 119; +plan tests => 120; $FS = ':'; @@ -180,7 +180,10 @@ is($cnt, scalar(@ary)); # /^/ treated as /^/m $_ = join ':', split /^/, "ab\ncd\nef\n"; -is($_, "ab\n:cd\n:ef\n"); +is($_, "ab\n:cd\n:ef\n","check that split /^/ is treated as split /^/m"); + +$_ = join ':', split /\A/, "ab\ncd\nef\n"; +is($_, "ab\ncd\nef\n","check that split /\A/ is NOT treated as split /^/m"); # see if @a = @b = split(...) optimization works @list1 = @list2 = split ('p',"a p b c p"); diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 74bf130..f534a86 100644 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -10,7 +10,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../cpan/version/lib'; } use warnings; use version; diff --git a/t/op/sprintf2.t b/t/op/sprintf2.t index 0969d58..3e32746 100644 --- a/t/op/sprintf2.t +++ b/t/op/sprintf2.t @@ -132,12 +132,11 @@ if ($Config{nvsize} == 8 && # IEEE 754 128-bit ("quadruple precision"), e.g. IA-64 (Itanium) in VMS $Config{nvsize} == 16 && # 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f (LE), pack F is the NV - # (compare this with "double-double") (pack("F", 0.1) =~ /^\x9A\x99{6}/ || # LE - pack("F", 0.1) =~ /\x99{6}x9A$/) # BE + pack("F", 0.1) =~ /\x99{6}\x9A$/) # BE ) { @hexfloat = ( - [ '%a', '0', '0x1p-1' ], + [ '%a', '0', '0x0p+0' ], [ '%a', '1', '0x1p+0' ], [ '%a', '1.0', '0x1p+0' ], [ '%a', '0.5', '0x1p-1' ], @@ -186,31 +185,27 @@ if ($Config{nvsize} == 8 && } elsif ( # "double-double", two 64-bit doubles end to end $Config{nvsize} == 16 && - # bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a (BE), pack F is the NV - # (compare this with "quadruple precision") - (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\x3C/ || # LE - pack("F", 0.1) =~ /\x3C\x59\x99{5}\x9A$/) # BE + # bf b9 99 99 99 99 99 9a bc 59 99 99 99 99 99 9a (BE), pack F is the NV + (pack("F", 0.1) =~ /^\x9A\x99{5}\x59\xBC/ || # LE + pack("F", 0.1) =~ /\xBC\x59\x99{5}\x9A$/) # BE ) { - # XXX these values are probably slightly wrong, even if - # the double-double extraction code gets fixed, the exact - # truncation/rounding effects are unknown. @hexfloat = ( - [ '%a', '0', '0x1p-1' ], + [ '%a', '0', '0x0p+0' ], [ '%a', '1', '0x1p+0' ], [ '%a', '1.0', '0x1p+0' ], [ '%a', '0.5', '0x1p-1' ], [ '%a', '0.25', '0x1p-2' ], [ '%a', '0.75', '0x1.8p-1' ], - [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%a', '-1', '-0x1p+0' ], - [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%a', '0.1', '0x1.99999999999999999999999999ap-4' ], - [ '%a', '1/7', '0x1.249249249249249249249249249p-3' ], - [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea9p+0' ], + [ '%a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%a', '-1', '-0x0p+0' ], + [ '%a', '-3.14', '-0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%a', '0.1', '0x1.999999999999999999999999998p-4' ], + [ '%a', '1/7', '0x1.249249249249249249249249248p-3' ], + [ '%a', 'sqrt(2)', '0x1.6a09e667f3bcc908b2fb1366ea8p+0' ], [ '%a', 'exp(1)', '0x1.5bf0a8b1457695355fb8ac404e8p+1' ], [ '%a', '2**-10', '0x1p-10' ], [ '%a', '2**10', '0x1p+10' ], - [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f13p-30' ], + [ '%a', '1e-09', '0x1.12e0be826d694b2e62d01511f14p-30' ], [ '%a', '1e9', '0x1.dcd65p+29' ], [ '%#a', '1', '0x1.p+0' ], @@ -219,27 +214,27 @@ if ($Config{nvsize} == 8 && [ '% a', '1', ' 0x1p+0' ], [ '% a', '-1', '-0x1p+0' ], - [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], + [ '%8a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%13a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%20a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], [ '%.4a', '3.14', '0x1.91ecp+1' ], [ '%.5a', '3.14', '0x1.91eb8p+1' ], [ '%.6a', '3.14', '0x1.91eb85p+1' ], - [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], + [ '%.20a', '3.14', '0x1.91eb851eb851eb851eb8p+1' ], [ '%20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], - [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], + [ '%20.15a', '3.14', '0x1.91eb851eb851eb8p+1' ], [ '% 20.10a', '3.14', ' 0x1.91eb851eb8p+1' ], [ '%020.10a', '3.14', '0x0001.91eb851eb8p+1' ], - [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], - [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb852p+1' ], + [ '%30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%-30a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], + [ '%-030a', '3.14', '0x1.91eb851eb851eb851eb851eb85p+1' ], [ '%.40a', '3.14', - '0x1.91eb851eb851eb851eb851eb8520000000000000p+1' ], + '0x1.91eb851eb851eb851eb851eb8500000000000000p+1' ], - [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB852P+1' ], + [ '%A', '3.14', '0X1.91EB851EB851EB851EB851EB85P+1' ], ); } else { print "# no hexfloat tests\n"; @@ -574,5 +569,63 @@ for my $t (@hexfloat) { my ($format, $arg, $expected) = @$t; $arg = eval $arg; my $result = sprintf($format, $arg); - is($result, $expected, "'$format' '$arg' -> '$result' cf '$expected'"); + my $ok = $result eq $expected; + unless ($ok) { + # It seems that there can be difference in the last bits: + # [perl #122578] + # got "0x1.5bf0a8b14576ap+1" + # expected "0x1.5bf0a8b145769p+1" + # (Android on ARM) + # + # Exact cause unknown but suspecting different fp rounding modes, + # (towards zero? towards +inf? towards -inf?) about which Perl + # is blissfully unaware. + # + # Try extracting one (or sometimes two) last mantissa + # hexdigits, and see if they differ in value by one. + my ($rh, $eh) = ($result, $expected); + sub extract_prefix { + ($_[0] =~ s/(-?0x[0-9a-fA-F]+\.)//) && return $1; + } + my $rp = extract_prefix($rh); + my $ep = extract_prefix($eh); + print "# rp = $rp, ep = $ep (rh $rh, eh $eh)\n"; + if ($rp eq $ep) { # If prefixes match. + sub extract_exponent { + ($_[0] =~ s/([pP][+-]?\d+)//) && return $1; + } + my $re = extract_exponent($rh); + my $ee = extract_exponent($eh); + print "# re = $re, ee = $ee (rh $rh, eh $eh)\n"; + if ($re eq $ee) { # If exponents match. + # Remove the common prefix of the mantissa bits. + my $la = length($rh); + my $lb = length($eh); + my $i; + for ($i = 0; $i < $la && $i < $lb; $i++) { + last if substr($rh, $i, 1) ne substr($eh, $i, 1); + } + $rh = substr($rh, $i); + $eh = substr($eh, $i); + print "# (rh $rh, eh $eh)\n"; + if ($rh ne $eh) { + # If necessary, pad the shorter one on the right + # with one zero (for example "...1f" vs "...2", + # we want to compare "1f" to "20"). + if (length $rh < length $eh) { + $rh .= '0'; + } elsif (length $eh < length $rh) { + $eh .= '0'; + } + print "# (rh $rh, eh $eh)\n"; + if (length $eh == length $rh) { + if (abs(hex($eh) - hex($rh)) == 1) { + $ok = 1; + } + } + } + } + } + } + ok($ok, "'$format' '$arg' -> '$result' cf '$expected'"); } diff --git a/t/op/stash.t b/t/op/stash.t index 5988114..4c846b7 100644 --- a/t/op/stash.t +++ b/t/op/stash.t @@ -7,7 +7,7 @@ BEGIN { BEGIN { require "./test.pl"; } -plan( tests => 49 ); +plan( tests => 50 ); # Used to segfault (bug #15479) fresh_perl_like( @@ -318,3 +318,12 @@ ok eval ' sub foo{}; 1 ', 'no crashing or errors when clobbering the current package'; + +# Bareword lookup should not vivify stashes +is runperl( + prog => + 'sub foo { print shift, qq-\n- } SUPER::foo bar if 0; foo SUPER', + stderr => 1, + ), + "SUPER\n", + 'bareword lookup does not vivify stashes'; diff --git a/t/op/sub.t b/t/op/sub.t index 1861623..1d865bf 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } -plan( tests => 34 ); +plan( tests => 37 ); sub empty_sub {} @@ -229,3 +229,15 @@ fresh_perl_is(<<'EOS', "", { stderr => 1 }, use strict; use warnings; eval q/use File::{Spec}/; eval q/use File::Spec/; EOS "check special blocks are cleared on error"); + +use constant { constant1 => 1, constant2 => 2 }; +{ + my $w; + local $SIG{__WARN__} = sub { $w++ }; + eval 'sub constant1; sub constant2($)'; + is eval '&constant1', '1', + 'stub re-declaration of constant with no prototype'; + is eval '&constant2', '2', + 'stub re-declaration of constant with wrong prototype'; + is $w, 2, 'two warnings from the above'; +} diff --git a/t/op/substr.t b/t/op/substr.t index 8946759..801895d 100644 --- a/t/op/substr.t +++ b/t/op/substr.t @@ -4,7 +4,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + require './test.pl'; + set_up_inc('../lib'); } use warnings ; @@ -21,8 +22,6 @@ $SIG{__WARN__} = sub { } }; -BEGIN { require './test.pl'; } - plan(387); run_tests() unless caller; diff --git a/t/op/symbolcache.t b/t/op/symbolcache.t index b3e567b..2596ae6 100644 --- a/t/op/symbolcache.t +++ b/t/op/symbolcache.t @@ -28,7 +28,7 @@ sub replaced { 'meth' } # simple removal sub removed2 { 24 } sub bound2 { removed2() } -undef $main::{removed2}; +{ no strict; undef *{"removed2"} } eval { bound2() }; like( $@, qr/Undefined subroutine &main::removed2 called/, 'function not bound' ); diff --git a/t/op/taint.t b/t/op/taint.t index 607402c..f9e8331 100644 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -9,15 +9,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; - skip_all_if_miniperl("no dynamic loading on miniperl, no re"); + set_up_inc('../lib'); } use strict; use Config; -plan tests => 800; +plan tests => 801; $| = 1; @@ -1513,7 +1512,7 @@ SKIP: { } SKIP: { - skip "no Fcntl", 18 unless $has_fcntl; + skip "no Fcntl", 36 unless $has_fcntl; my $foo = tempfile(); my $evil = $foo . $TAINT; @@ -2323,6 +2322,20 @@ $::x = "foo"; $_ = "$TAINT".reset "x"; is eval { eval $::x.1 }, 1, 'reset does not taint undef'; +# [perl #122669] +{ + # See the comment above the first formline test. + local $ENV{PATH} = $ENV{PATH}; + $ENV{PATH} = $old_env_path if $Is_MSWin32; + is runperl( + switches => [ '-T' ], + prog => 'use constant K=>$^X; 0 if K; BEGIN{} use strict; ' + .'print 122669, qq-\n-', + stderr => 1, + ), "122669\n", + 'tainted constant as logop condition should not prevent "use"'; +} + # This may bomb out with the alarm signal so keep it last SKIP: { skip "No alarm()" unless $Config{d_alarm}; diff --git a/t/op/tie.t b/t/op/tie.t index e0b2499..aff685b 100644 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -27,6 +27,8 @@ tie %h, Tie::StdHash; untie %h; EXPECT ######## +# SKIP !defined &DynaLoader::boot_DynaLoader && !eval 'require base' +# (skip under miniperl if base.pm is not in lib/ yet) # standard behaviour, without any extra references use Tie::Hash ; diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t index 9f60bb4..c97b9b4 100644 --- a/t/op/tie_fetch_count.t +++ b/t/op/tie_fetch_count.t @@ -5,8 +5,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); plan (tests => 312); } diff --git a/t/op/tiehandle.t b/t/op/tiehandle.t index 08a20eb..21f56fc 100644 --- a/t/op/tiehandle.t +++ b/t/op/tiehandle.t @@ -2,14 +2,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + require './test.pl'; + set_up_inc(qw '../lib ../dist/base/lib'); } my @expect; my $data = ""; my @data = (); -require './test.pl'; plan(tests => 67); sub compare { diff --git a/t/op/tr.t b/t/op/tr.t index 580d55a..8a7dd8a 100644 --- a/t/op/tr.t +++ b/t/op/tr.t @@ -4,8 +4,8 @@ use utf8; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan tests => 134; diff --git a/t/op/undef.t b/t/op/undef.t index 366c3d2..ddef596 100644 --- a/t/op/undef.t +++ b/t/op/undef.t @@ -10,7 +10,7 @@ use strict; use vars qw(@ary %ary %hash); -plan 73; +plan 74; ok !defined($a); @@ -128,6 +128,23 @@ for (z,z) { } is $_[0], $_[1], 'undef constants preserve identity'; +# [perl #122556] +my $messages; +package Thingie; +DESTROY { $messages .= 'destroyed ' } +package main; +sub body { + sub { + my $t = bless [], 'Thingie'; + undef $t; + }->(), $messages .= 'after '; + + return; +} +body(); +is $messages, 'destroyed after ', 'undef $scalar frees refs immediately'; + + # this will segfault if it fails sub PVBM () { 'foo' } diff --git a/t/op/universal.t b/t/op/universal.t index 494bc99..116f923 100644 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -5,7 +5,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + require './test.pl'; + set_up_inc(qw '../lib ../dist/base/lib'); $| = 1; require "./test.pl"; } diff --git a/t/op/utftaint.t b/t/op/utftaint.t index d734927..da4f842 100644 --- a/t/op/utftaint.t +++ b/t/op/utftaint.t @@ -3,7 +3,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib); + require './test.pl'; + set_up_inc('../lib'); } use strict; @@ -17,7 +18,6 @@ sub tainted ($) { any_tainted @_; } -require './test.pl'; plan(tests => 3*10 + 3*8 + 2*16 + 3); my $arg = $ENV{PATH}; # a tainted value @@ -140,7 +140,11 @@ for my $ary ([ascii => 'perl'], [latin1 => "\xB6"]) { is(tainted($taint), tainted($arg), "tainted: $encode, downgrade down"); } -{ +SKIP: { + if (is_miniperl()) { + skip_if_miniperl("Unicode tables not built yet", 2) + unless eval 'require "unicore/Heavy.pl"'; + } fresh_perl_is('$a = substr $^X, 0, 0; /\x{100}/i; /$a\x{100}/i || print q,ok,', 'ok', {switches => ["-T", "-l"]}, "matching a regexp is taint agnostic"); diff --git a/t/op/vec.t b/t/op/vec.t index 30badb0..141a6da 100644 --- a/t/op/vec.t +++ b/t/op/vec.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); + require './test.pl'; + set_up_inc('../lib'); } -require "test.pl"; plan( tests => 35 ); my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; diff --git a/t/op/warn.t b/t/op/warn.t index 741c2c7..4d679c2 100644 --- a/t/op/warn.t +++ b/t/op/warn.t @@ -3,8 +3,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan 32; diff --git a/t/op/write.t b/t/op/write.t index 7591cde..653561f 100644 --- a/t/op/write.t +++ b/t/op/write.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use strict; # Amazed that this hackery can be made strict ... diff --git a/t/op/yadayada.t b/t/op/yadayada.t index 770a51e..a213bec 100644 --- a/t/op/yadayada.t +++ b/t/op/yadayada.t @@ -8,14 +8,39 @@ BEGIN { use strict; -plan 5; +plan 9; -my $err = "Unimplemented at $0 line " . ( __LINE__ + 2 ) . ".\n"; +my $err; +my $err1 = "Unimplemented at $0 line "; +my $err2 = ".\n"; +$err = $err1 . ( __LINE__ + 1 ) . $err2; eval { ... }; +is $@, $err, "Execution of ellipsis statement reported 'Unimplemented' code"; +$@ = ''; -is $@, $err; +note("RT #122661: Semicolon before ellipsis statement disambiguates to indicate block rather than hash reference"); +my @input = (3..5); +my @transformed; +$err = $err1 . ( __LINE__ + 1 ) . $err2; +eval { @transformed = map {; ... } @input; }; +is $@, $err, "Disambiguation case 1"; +$@ = ''; +$err = $err1 . ( __LINE__ + 1 ) . $err2; +eval { @transformed = map {;...} @input; }; +is $@, $err, "Disambiguation case 2"; +$@ = ''; + +$err = $err1 . ( __LINE__ + 1 ) . $err2; +eval { @transformed = map {; ...} @input; }; +is $@, $err, "Disambiguation case 3"; +$@ = ''; + +$err = $err1 . ( __LINE__ + 1 ) . $err2; +eval { @transformed = map {;... } @input; }; +is $@, $err, "Disambiguation case 4"; +$@ = ''; # # Regression tests, making sure ... is still parsable as an operator. diff --git a/t/opbasic/arith.t b/t/opbasic/arith.t index a90e84c..10efe86 100644 --- a/t/opbasic/arith.t +++ b/t/opbasic/arith.t @@ -9,7 +9,7 @@ BEGIN { # functions imported from t/test.pl or Test::More, as those programs/libraries # use operators which are what is being tested in this file. -print "1..175\n"; +print "1..181\n"; sub try ($$$) { print +($_[1] ? "ok" : "not ok"), " $_[0] - $_[2]\n"; @@ -468,3 +468,11 @@ try $T++, 0.1530000e-305 != 0.0, '0.1530000e-305'; try $T++, 0.1530001e-305 != 0.0, '0.1530001e-305'; try $T++, 1.17549435100e-38 != 0.0, 'min single'; try $T++, 2.2250738585072014e-308 != 0.0, 'min double'; + +# string-to-nv should equal float literals +try $T++, "1.23" + 0 == 1.23, '1.23'; +try $T++, " 1.23" + 0 == 1.23, '1.23 with leading space'; +try $T++, "1.23 " + 0 == 1.23, '1.23 with trailing space'; +try $T++, "+1.23" + 0 == 1.23, '1.23 with unary plus'; +try $T++, "-1.23" + 0 == -1.23, '1.23 with unary minus'; +try $T++, "1.23e4" + 0 == 12300, '1.23e4'; diff --git a/t/porting/corelist.t b/t/porting/corelist.t index bebb370..251a260 100644 --- a/t/porting/corelist.t +++ b/t/porting/corelist.t @@ -8,7 +8,7 @@ use Config; require 't/test.pl'; -plan(tests => 9); +plan(tests => 6); use_ok('Module::CoreList'); use_ok('Module::CoreList::Utils'); @@ -20,20 +20,3 @@ use_ok('Module::CoreList::TieHashDelta'); ok( defined $Module::CoreList::version{ $] }, "$] exists in version" ); ok( defined $Module::CoreList::Utils::utilities{$] }, "$] exists in Utils" ); } - -#plan skip_all => 'Special case v5.21.1 because rjbs' if sprintf("v%vd", $^V) eq 'v5.21.1'; - -my @modules = qw[ - Module::CoreList - Module::CoreList::Utils - Module::CoreList::TieHashDelta -]; - -SKIP: { - skip('Special case v5.21.1 because rjbs', 3) if sprintf("v%vd", $^V) eq 'v5.21.1'; - foreach my $mod ( @modules ) { - my $vers = eval $mod->VERSION; - ok( !( $vers < $] || $vers > $] ), "$mod version should match perl version in core" ) - or diag("$mod $vers doesn't match $]"); - } -} diff --git a/t/porting/customized.dat b/t/porting/customized.dat index a8ee6ec..9d54c2a 100644 --- a/t/porting/customized.dat +++ b/t/porting/customized.dat @@ -1,5 +1,8 @@ DB_File cpan/DB_File/DB_File.xs 140cd1d47c6830d1cb51b2207fd7c7d5ce8fb924 Digest::MD5 cpan/Digest-MD5/t/files.t bdbe05b705d9da305fedce7a9f4b6ba63250c7cf +Digest::SHA cpan/Digest-SHA/hints/hpux.pl 8cf51e816894ee03826eac737bd6843300d6e64c +ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm f738b4b8d6dfdb2bae5f3e43106370867aa88f01 +ExtUtils::MakeMaker cpan/ExtUtils-MakeMaker/t/pm_to_blib.t 2cd28c8279d7900e28962712763eaa4768117414 PerlIO::via::QuotedPrint cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t ca39f0146e89de02c746e199c45dcb3e5edad691 Text::Balanced cpan/Text-Balanced/t/01_compile.t 1598cf491a48fa546260a2ec41142abe84da533d Text::Balanced cpan/Text-Balanced/t/02_extbrk.t 6ba1b64a4604e822dc2260b8ffcea6b406339ee8 @@ -15,6 +18,5 @@ Text::ParseWords cpan/Text-ParseWords/t/taint.t 3cff0dae812801f7aa1738d6070508f2 autodie cpan/autodie/t/utf8_open.t 5295851351c49f939008c5aca6a798742b1e503d podlators cpan/podlators/scripts/pod2man.PL f81acf53f3ff46cdcc5ebdd661c5d13eb35d20d6 podlators cpan/podlators/scripts/pod2text.PL b4693fcfe4a0a1b38a215cfb8985a65d5d025d69 -version cpan/version/lib/version.pm fa9931d4db05aff9a0a6ef558610b1a472d9306e +version cpan/version/lib/version.pm d0923b895d57f1d669ae36fcf85c87b16db341d1 version vutil.c 668f17ca43e2527645674d29ba772b86330d5663 -version vxs.inc 9064aacbdfe42bb584a068f62b505dd11dbb4dc4 diff --git a/t/porting/diag.t b/t/porting/diag.t index d3e0021..b53dacd 100644 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -39,6 +39,7 @@ foreach (@{(setup_embed())[0]}) { push @functions, 'Perl_' . $_->[2] if $_->[0] =~ /p/; push @functions, 'S_' . $_->[2] if $_->[0] =~ /s/; }; +push @functions, 'Perl_mess'; my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b'; my $regcomp_re = @@ -483,7 +484,6 @@ Can't fix broken locale name "%s" Can't get short module name from a handle Can't load DLL `%s', possible problematic module `%s' Can't locate %s: %s -Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?) Can't pipe "%s": %s Can't set type on DOS Can't spawn: %s @@ -597,6 +597,7 @@ Not array reference given to mod2fname Operator or semicolon missing before %c%s Out of memory during list extend panic queryaddr +Parse error PerlApp::TextQuery: no arguments, please POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/ ptr wrong %p != %p fl=%x nl=%p e=%p for %d diff --git a/t/porting/dual-life.t b/t/porting/dual-life.t index 8d9f070..27daf46 100644 --- a/t/porting/dual-life.t +++ b/t/porting/dual-life.t @@ -43,7 +43,7 @@ $dist_dir_exe{'pod2html.pl'} = '../ext/Pod-Html'; my @programs; find( - { no_chidr => 1, wanted => sub { + { no_chdir => 1, wanted => sub { my $name = $File::Find::name; return if $name =~ /blib/; return unless $name =~ m{/(?:bin|scripts?)/\S+\z} && $name !~ m{/t/}; diff --git a/t/porting/known_pod_issues.dat b/t/porting/known_pod_issues.dat index 5388389..4152a65 100644 --- a/t/porting/known_pod_issues.dat +++ b/t/porting/known_pod_issues.dat @@ -1,4 +1,4 @@ -# This file is the data file for porting/podcheck.t. +# This file is the data file for porting\podcheck.t. # There are three types of lines. # Comment lines are white-space only or begin with a '#', like this one. Any # changes you make to the comment lines will be lost when the file is @@ -222,6 +222,7 @@ ext/devel-peek/peek.pm ? Should you be using L<...> instead of 2 ext/dynaloader/dynaloader.pm Verbatim line length including indents exceeds 79 by 1 ext/file-find/lib/file/find.pm Verbatim line length including indents exceeds 79 by 1 ext/file-glob/glob.pm Verbatim line length including indents exceeds 79 by 15 +ext/hash-util-fieldhash/lib/hash/util/fieldhash.pm Apparent broken link 1 ext/hash-util/lib/hash/util.pm Verbatim line length including indents exceeds 79 by 2 ext/pod-html/testdir/perlpodspec-copy.pod Verbatim line length including indents exceeds 79 by 8 ext/pod-html/testdir/perlvar-copy.pod ? Should you be using L<...> instead of 3 @@ -246,6 +247,7 @@ pod/perlcygwin.pod Verbatim line length including indents exceeds 79 by 24 pod/perldebguts.pod Verbatim line length including indents exceeds 79 by 34 pod/perldebtut.pod Verbatim line length including indents exceeds 79 by 22 pod/perldebug.pod Verbatim line length including indents exceeds 79 by 3 +pod/perldelta.pod Apparent broken link 1 pod/perldsc.pod Verbatim line length including indents exceeds 79 by 4 pod/perldtrace.pod Verbatim line length including indents exceeds 79 by 26 pod/perlfunc.pod ? Should you be using F<...> or maybe L<...> instead of 1 diff --git a/t/porting/libperl.t b/t/porting/libperl.t index f62b80d..6b441e5 100644 --- a/t/porting/libperl.t +++ b/t/porting/libperl.t @@ -252,7 +252,7 @@ sub nm_parse_darwin { $symbols->{data}{const}{$symbol}{$symbols->{o}}++; } elsif (/^\(__TEXT,__text\) (?:non-)?external _(\w+)$/) { $symbols->{text}{$1}{$symbols->{o}}++; - } elsif (/^\(__DATA,__(const|data|bss|common)\) (?:non-)?external _(\w+)(\.\w+)?$/) { + } elsif (/^\(__DATA,__\w*?(const|data|bss|common)\w*\) (?:non-)?external _(\w+)(\.\w+)?$/) { my ($dtype, $symbol, $suffix) = ($1, $2, $3); # Ignore function-local constants like # _Perl_pp_gmtime.dayname @@ -418,15 +418,10 @@ ok(keys %{$symbols{undef}}, "has undefined symbols"); # There are certain symbols we expect to see. -# memchr, memcmp, memcpy should be used all over the place. -# -# chmod, socket, getenv, sigaction, sqrt, time are system/library -# calls that should each see at least one use. sqrt can be sqrtl +# chmod, socket, getenv, sigaction, exp, time are system/library +# calls that should each see at least one use. exp can be expl # if so configured. my %expected = ( - memchr => 'd_memchr', - memcmp => 'd_memcmp', - memcpy => 'd_memcpy', chmod => undef, # There is no Configure symbol for chmod. socket => 'd_socket', getenv => undef, # There is no Configure symbol for getenv, @@ -434,14 +429,18 @@ my %expected = ( time => 'd_time', ); -if ($Config{uselongdouble} && $Config{d_longdbl}) { - $expected{sqrtl} = 'd_sqrtl'; +if ($Config{uselongdouble} && $Config{longdblsize} > $Config{doublesize}) { + if ($Config{usequadmath}) { + $expected{expq} = undef; # There is no Configure symbol for expq. + } else { + $expected{expl} = undef; # There is no Configure symbol for expl. + } } else { - $expected{sqrt} = undef; # There is no Configure symbol for sqrt. + $expected{exp} = undef; # There is no Configure symbol for exp. } # DynaLoader will use dlopen, unless we are building static, -# and in the platforms we are supporting in this test. +# and it is used in the platforms we are supporting in this test. if ($Config{usedl} ) { $expected{dlopen} = 'd_dlopen'; } @@ -455,16 +454,7 @@ for my $symbol (sort keys %expected) { } my @o = exists $symbols{undef}{$symbol} ? sort keys %{ $symbols{undef}{$symbol} } : (); - # In some FreeBSD versions memcmp disappears (compiler inlining?). - if (($^O eq 'freebsd' || - (defined $fake_style && $fake_style eq 'freebsd')) && - $symbol eq 'memcmp' && @o == 0) { - SKIP: { - skip("freebsd memcmp"); - } - } else { - ok(@o, "uses $symbol (@o)"); - } + ok(@o, "uses $symbol (@o)"); } # There are certain symbols we expect NOT to see. diff --git a/t/porting/readme.t b/t/porting/readme.t index cbb2fe8..85d044e 100644 --- a/t/porting/readme.t +++ b/t/porting/readme.t @@ -12,13 +12,18 @@ use strict; use warnings; require 't/test.pl'; -open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!"); - -my @porting_files = grep { !/~\z/ } glob("Porting/*"); +my @porting_files; +open my $man, "MANIFEST" or die "Can't open MANIFEST: $!"; +while(<$man>) { + /^Porting\// and s/[\t\n].*//s, push @porting_files, $_; +} +close $man or die "Can't close MANIFEST: $!"; # It seems that dying here is nicer than having several dozen failing tests # later. But that assumes one will see the message from die. die "Can't get contents of Porting/ directory.\n" unless @porting_files > 1; +open(my $fh, '<', 'Porting/README.pod') or die("Can't open Porting/README.pod: $!"); + my (@current_order, @sorted_order, %files_in_pod); while(<$fh>) { next unless $_ =~ /^=head/; @@ -31,7 +36,6 @@ while(<$fh>) { for my $file (@porting_files) { $file =~ s!^Porting/!!; - $file =~ s/\.\z// if $^O eq 'VMS'; next if $file =~ /^perl[0-9]+delta\.pod$/; ok(exists($files_in_pod{$file}), "$file is mentioned in Porting/README.pod"); delete $files_in_pod{$file}; diff --git a/t/porting/regen.t b/t/porting/regen.t index 3198183..0c378cd 100644 --- a/t/porting/regen.t +++ b/t/porting/regen.t @@ -20,7 +20,7 @@ if ( $Config{usecrosscompile} ) { skip_all( "Not all files are available during cross-compilation" ); } -my $tests = 25; # I can't see a clean way to calculate this automatically. +my $tests = 26; # I can't see a clean way to calculate this automatically. my %skip = ("regen_perly.pl" => [qw(perly.act perly.h perly.tab)], "regen/keywords.pl" => [qw(keywords.c keywords.h)], diff --git a/t/re/charset.t b/t/re/charset.t index 76a3bce..4d0d99c 100644 --- a/t/re/charset.t +++ b/t/re/charset.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../dist/if'; require './test.pl'; require './loc_tools.pl'; } diff --git a/t/re/overload.t b/t/re/overload.t index dba0357..ee821f1 100644 --- a/t/re/overload.t +++ b/t/re/overload.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../ext/re'; require './test.pl'; } diff --git a/t/re/pat.t b/t/re/pat.t index 62ce76a..b87b007 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -15,12 +15,13 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - @INC = ('../lib','.'); + @INC = ('../lib','.','../ext/re'); require Config; import Config; require './test.pl'; + skip_all_without_unicode_tables(); } -plan tests => 737; # Update this when adding/deleting tests. +plan tests => 739; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1606,6 +1607,31 @@ EOP ok('ac' =~ qrc>, "'\\<' is a literal in qr<...>)"); } + { # Was getting optimized into EXACT (non-folding node) + my $x = qr/[x]/i; + utf8::upgrade($x); + like("X", qr/$x/, "UTF-8 of /[x]/i matches upper case"); + } + + { # make sure we get an error when \p{} cannot load Unicode tables + fresh_perl_like(<<' prog that cannot load uni tables', + BEGIN { + @INC = '../lib'; + require utf8; require 'utf8_heavy.pl'; + @INC = (); + } + $name = 'A B'; + if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){ + print "It's good! >$1< >$2<\n"; + } else { + print "It's not good...\n"; + } + prog that cannot load uni tables + qr/^Can't locate unicore\/Heavy\.pl(?x: + )|^Can't find Unicode property definition/, + undef, + '\p{} should not fail silently when uni tables evanesce'); + } } # End of sub run_tests 1; diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t index 986eb87..fb30a9c 100644 --- a/t/re/pat_advanced.t +++ b/t/re/pat_advanced.t @@ -998,9 +998,8 @@ sub run_tests { # my $w; local $SIG {__WARN__} = sub {$w .= "@_"}; - eval 'q(xxWxx) =~ /[\N{WARN}]/'; - ok $w && $w =~ /Using just the first character returned by \\N\{} in character class/, - "single character in [\\N{}] warning"; + $result = eval 'q(WARN) =~ /[\N{WARN}]/'; + ok !$@ && $result && ! $w, '\N{} returning multi-char works'; undef $w; eval q [ok "\0" !~ /[\N{EMPTY-STR}XY]/, diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t index 309d0e9..c77439a 100644 --- a/t/re/pat_re_eval.t +++ b/t/re/pat_re_eval.t @@ -17,8 +17,8 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - @INC = ('../lib','.'); require './test.pl'; + set_up_inc('../lib'); } diff --git a/t/re/reg_eval_scope.t b/t/re/reg_eval_scope.t index 0e35e29..0eaeeb9 100644 --- a/t/re/reg_eval_scope.t +++ b/t/re/reg_eval_scope.t @@ -4,8 +4,8 @@ BEGIN { chdir 't'; - @INC = qw(lib ../lib); require './test.pl'; + set_up_inc(qw(lib ../lib)); } plan 48; diff --git a/t/re/reg_mesg.t b/t/re/reg_mesg.t index 2c54cc3..78be9ee 100644 --- a/t/re/reg_mesg.t +++ b/t/re/reg_mesg.t @@ -2,8 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../ext/re'; require './test.pl'; + skip_all_without_unicode_tables(); eval 'require Config'; # assume defaults if this fails } @@ -204,7 +205,7 @@ my @death = 'm/(?[[\w-x]])/' => 'False [] range "\w-" {#} m/(?[[\w-{#}x]])/', 'm/(?[[a-\pM]])/' => 'False [] range "a-\pM" {#} m/(?[[a-\pM{#}]])/', 'm/(?[[\pM-x]])/' => 'False [] range "\pM-" {#} m/(?[[\pM-{#}x]])/', - 'm/(?[[\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]])/' => '\N{} in character class restricted to one character {#} m/(?[[\N{U+100.300{#}}]])/', + 'm/(?[[^\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]])/' => '\N{} in inverted character class or as a range end-point is restricted to one character {#} m/(?[[^\N{U+100.300{#}}]])/', 'm/(?[ \p{Digit} & (?(?[ \p{Thai} | \p{Lao} ]))])/' => 'Sequence (?(...) not recognized {#} m/(?[ \p{Digit} & (?({#}?[ \p{Thai} | \p{Lao} ]))])/', 'm/(?[ \p{Digit} & (?:(?[ \p{Thai} | \p{Lao} ]))])/' => 'Expecting \'(?flags:(?[...\' {#} m/(?[ \p{Digit} & (?{#}:(?[ \p{Thai} | \p{Lao} ]))])/', 'm/\o{/' => 'Missing right brace on \o{ {#} m/\o{{#}/', @@ -319,20 +320,25 @@ push @death, @death_utf8; # In the following arrays of warnings, the value can be an array of things to # expect. If the empty string, it means no warning should be raised. -## -## Key-value pairs of code/error of code that should have non-fatal regexp warnings. -## -my @warning = ( - 'm/\b*/' => '\b* matches null string many times {#} m/\b*{#}/', - 'm/[:blank:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:blank:]{#}/', - "m'[\\y]'" => 'Unrecognized escape \y in character class passed through {#} m/[\y{#}]/', +# Key-value pairs of code/error of code that should have non-fatal regexp +# warnings. Most currently have \x{100} appended to them to force them to be +# upgraded to UTF-8, and the first pass restarted. Previously this would +# cause some warnings to be output twice. This tests that that behavior has +# been fixed. - 'm/[a-\d]/' => 'False [] range "a-\d" {#} m/[a-\d{#}]/', - 'm/[\w-x]/' => 'False [] range "\w-" {#} m/[\w-{#}x]/', - 'm/[a-\pM]/' => 'False [] range "a-\pM" {#} m/[a-\pM{#}]/', - 'm/[\pM-x]/' => 'False [] range "\pM-" {#} m/[\pM-{#}x]/', - "m'\\y'" => 'Unrecognized escape \y passed through {#} m/\y{#}/', +my @warning = ( + 'm/\b*\x{100}/' => '\b* matches null string many times {#} m/\b*{#}\x{100}/', + 'm/[:blank:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:blank:]{#}\x{100}/', + "m'[\\y]\\x{100}'" => 'Unrecognized escape \y in character class passed through {#} m/[\y{#}]\x{100}/', + 'm/[a-\d]\x{100}/' => 'False [] range "a-\d" {#} m/[a-\d{#}]\x{100}/', + 'm/[\w-x]\x{100}/' => 'False [] range "\w-" {#} m/[\w-{#}x]\x{100}/', + 'm/[a-\pM]\x{100}/' => 'False [] range "a-\pM" {#} m/[a-\pM{#}]\x{100}/', + 'm/[\pM-x]\x{100}/' => 'False [] range "\pM-" {#} m/[\pM-{#}x]\x{100}/', + 'm/[^\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]/' => 'Using just the first character returned by \N{} in character class {#} m/[^\N{U+100.300}{#}]/', + 'm/[\x03-\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}]/' => 'Using just the first character returned by \N{} in character class {#} m/[\x03-\N{U+100.300}{#}]/', + 'm/[\N{LATIN CAPITAL LETTER A WITH MACRON AND GRAVE}-\x{10FFFF}]/' => 'Using just the first character returned by \N{} in character class {#} m/[\N{U+100.300}{#}-\x{10FFFF}]/', + "m'\\y\\x{100}'" => 'Unrecognized escape \y passed through {#} m/\y{#}\x{100}/', '/x{3,1}/' => 'Quantifier {n,m} with n > m can\'t match {#} m/x{3,1}{#}/', '/\08/' => '\'\08\' resolved to \'\o{0}8\' {#} m/\08{#}/', '/\018/' => '\'\018\' resolved to \'\o{1}8\' {#} m/\018{#}/', @@ -341,52 +347,59 @@ my @warning = ( '/(?=a)*/' => '(?=a)* matches null string many times {#} m/(?=a)*{#}/', 'my $x = \'\m\'; qr/a$x/' => 'Unrecognized escape \m passed through {#} m/a\m{#}/', '/\q/' => 'Unrecognized escape \q passed through {#} m/\q{#}/', - '/(?=a){1,3}/' => 'Quantifier unexpected on zero-length expression {#} m/(?=a){1,3}{#}/', - '/(a|b)(?=a){3}/' => 'Quantifier unexpected on zero-length expression {#} m/(a|b)(?=a){3}{#}/', + + # Feel free to modify these 2 tests, should they start failing because the + # marker of where the problem is becomes wrong. The current behavior is + # bad, always marking at the very end of the regex instead of where the + # problem is. See [perl #122680] regcomp warning gives wrong position of + # problem. + '/(?=a){1,3}\x{100}/' => 'Quantifier unexpected on zero-length expression {#} m/(?=a){1,3}\x{100}{#}/', + '/(a|b)(?=a){3}\x{100}/' => 'Quantifier unexpected on zero-length expression {#} m/(a|b)(?=a){3}\x{100}{#}/', + '/\_/' => "", '/[\_\0]/' => "", '/[\07]/' => "", '/[\006]/' => "", '/[\0005]/' => "", - '/[\8\9]/' => ['Unrecognized escape \8 in character class passed through {#} m/[\8{#}\9]/', - 'Unrecognized escape \9 in character class passed through {#} m/[\8\9{#}]/', + '/[\8\9]\x{100}/' => ['Unrecognized escape \8 in character class passed through {#} m/[\8{#}\9]\x{100}/', + 'Unrecognized escape \9 in character class passed through {#} m/[\8\9{#}]\x{100}/', ], - '/[:alpha:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:alpha:]{#}/', - '/[:zog:]/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:zog:]{#}/', - '/[.zog.]/' => 'POSIX syntax [. .] belongs inside character classes {#} m/[.zog.]{#}/', + '/[:alpha:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:alpha:]{#}\x{100}/', + '/[:zog:]\x{100}/' => 'POSIX syntax [: :] belongs inside character classes {#} m/[:zog:]{#}\x{100}/', + '/[.zog.]\x{100}/' => 'POSIX syntax [. .] belongs inside character classes {#} m/[.zog.]{#}\x{100}/', '/[a-b]/' => "", - '/[a-\d]/' => 'False [] range "a-\d" {#} m/[a-\d{#}]/', - '/[\d-b]/' => 'False [] range "\d-" {#} m/[\d-{#}b]/', - '/[\s-\d]/' => 'False [] range "\s-" {#} m/[\s-{#}\d]/', - '/[\d-\s]/' => 'False [] range "\d-" {#} m/[\d-{#}\s]/', - '/[a-[:digit:]]/' => 'False [] range "a-[:digit:]" {#} m/[a-[:digit:]{#}]/', - '/[[:digit:]-b]/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}b]/', - '/[[:alpha:]-[:digit:]]/' => 'False [] range "[:alpha:]-" {#} m/[[:alpha:]-{#}[:digit:]]/', - '/[[:digit:]-[:alpha:]]/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}[:alpha:]]/', - '/[a\zb]/' => 'Unrecognized escape \z in character class passed through {#} m/[a\z{#}b]/', - '/(?c)/' => 'Useless (?c) - use /gc modifier {#} m/(?c{#})/', - '/(?-c)/' => 'Useless (?-c) - don\'t use /gc modifier {#} m/(?-c{#})/', - '/(?g)/' => 'Useless (?g) - use /g modifier {#} m/(?g{#})/', - '/(?-g)/' => 'Useless (?-g) - don\'t use /g modifier {#} m/(?-g{#})/', - '/(?o)/' => 'Useless (?o) - use /o modifier {#} m/(?o{#})/', - '/(?-o)/' => 'Useless (?-o) - don\'t use /o modifier {#} m/(?-o{#})/', - '/(?g-o)/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-o)/', - 'Useless (?-o) - don\'t use /o modifier {#} m/(?g-o{#})/', + '/[a-\d]\x{100}/' => 'False [] range "a-\d" {#} m/[a-\d{#}]\x{100}/', + '/[\d-b]\x{100}/' => 'False [] range "\d-" {#} m/[\d-{#}b]\x{100}/', + '/[\s-\d]\x{100}/' => 'False [] range "\s-" {#} m/[\s-{#}\d]\x{100}/', + '/[\d-\s]\x{100}/' => 'False [] range "\d-" {#} m/[\d-{#}\s]\x{100}/', + '/[a-[:digit:]]\x{100}/' => 'False [] range "a-[:digit:]" {#} m/[a-[:digit:]{#}]\x{100}/', + '/[[:digit:]-b]\x{100}/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}b]\x{100}/', + '/[[:alpha:]-[:digit:]]\x{100}/' => 'False [] range "[:alpha:]-" {#} m/[[:alpha:]-{#}[:digit:]]\x{100}/', + '/[[:digit:]-[:alpha:]]\x{100}/' => 'False [] range "[:digit:]-" {#} m/[[:digit:]-{#}[:alpha:]]\x{100}/', + '/[a\zb]\x{100}/' => 'Unrecognized escape \z in character class passed through {#} m/[a\z{#}b]\x{100}/', + '/(?c)\x{100}/' => 'Useless (?c) - use /gc modifier {#} m/(?c{#})\x{100}/', + '/(?-c)\x{100}/' => 'Useless (?-c) - don\'t use /gc modifier {#} m/(?-c{#})\x{100}/', + '/(?g)\x{100}/' => 'Useless (?g) - use /g modifier {#} m/(?g{#})\x{100}/', + '/(?-g)\x{100}/' => 'Useless (?-g) - don\'t use /g modifier {#} m/(?-g{#})\x{100}/', + '/(?o)\x{100}/' => 'Useless (?o) - use /o modifier {#} m/(?o{#})\x{100}/', + '/(?-o)\x{100}/' => 'Useless (?-o) - don\'t use /o modifier {#} m/(?-o{#})\x{100}/', + '/(?g-o)\x{100}/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-o)\x{100}/', + 'Useless (?-o) - don\'t use /o modifier {#} m/(?g-o{#})\x{100}/', ], - '/(?g-c)/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-c)/', - 'Useless (?-c) - don\'t use /gc modifier {#} m/(?g-c{#})/', + '/(?g-c)\x{100}/' => [ 'Useless (?g) - use /g modifier {#} m/(?g{#}-c)\x{100}/', + 'Useless (?-c) - don\'t use /gc modifier {#} m/(?g-c{#})\x{100}/', ], # (?c) means (?g) error won't be thrown - '/(?o-cg)/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}-cg)/', - 'Useless (?-c) - don\'t use /gc modifier {#} m/(?o-c{#}g)/', + '/(?o-cg)\x{100}/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}-cg)\x{100}/', + 'Useless (?-c) - don\'t use /gc modifier {#} m/(?o-c{#}g)\x{100}/', ], - '/(?ogc)/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}gc)/', - 'Useless (?g) - use /g modifier {#} m/(?og{#}c)/', - 'Useless (?c) - use /gc modifier {#} m/(?ogc{#})/', + '/(?ogc)\x{100}/' => [ 'Useless (?o) - use /o modifier {#} m/(?o{#}gc)\x{100}/', + 'Useless (?g) - use /g modifier {#} m/(?og{#}c)\x{100}/', + 'Useless (?c) - use /gc modifier {#} m/(?ogc{#})\x{100}/', ], - '/a{1,1}?/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}/', - '/b{3} +/x' => 'Useless use of greediness modifier \'+\' {#} m/b{3} +{#}/', -); + '/a{1,1}?\x{100}/' => 'Useless use of greediness modifier \'?\' {#} m/a{1,1}?{#}\x{100}/', + '/b{3} +\x{100}/x' => 'Useless use of greediness modifier \'+\' {#} m/b{3} +{#}\x{100}/', +); # See comments before this for why '\x{100}' is generally needed my @warnings_utf8 = mark_as_utf8( 'm/ネ\b*ネ/' => '\b* matches null string many times {#} m/ネ\b*{#}ネ/', diff --git a/t/re/regex_sets.t b/t/re/regex_sets.t index 9ddceae..c1ca860 100644 --- a/t/re/regex_sets.t +++ b/t/re/regex_sets.t @@ -12,8 +12,9 @@ $| = 1; BEGIN { chdir 't' if -d 't'; - @INC = ('../lib','.'); + @INC = ('../lib','.','../ext/re'); require './test.pl'; + skip_all_without_unicode_tables(); } use utf8; diff --git a/t/re/regexp.t b/t/re/regexp.t index ac211ca..59680fb 100644 --- a/t/re/regexp.t +++ b/t/re/regexp.t @@ -59,8 +59,11 @@ BEGIN { } chdir 't' if -d 't'; - @INC = '../lib'; - + @INC = qw '../lib ../ext/re'; + if (!defined &DynaLoader::boot_DynaLoader) { # miniperl + print("1..0 # Skip Unicode tables not built yet\n"), exit + unless eval 'require "unicore/Heavy.pl"'; + } } sub _comment { diff --git a/t/re/rt122747.t b/t/re/rt122747.t new file mode 100644 index 0000000..b839edd --- /dev/null +++ b/t/re/rt122747.t @@ -0,0 +1,29 @@ +#!./perl +use strict; +use warnings; + +$| = 1; + + +BEGIN { + chdir 't' if -d 't'; + @INC = ('../lib','.','../ext/re'); + require './test.pl'; +} + +plan tests => 3; +use strict; + +my(@body) = ( + "", + "A\x{B9}ker\x{E8}eva xxxx.xxxx\@outlook.com \x{201D}", +); + +for (@body) { + s{ | \s{1,10} (?!phone) [a-z]{2,11} : ) }{ }xgi; + my $got= $1; + is( $got, '.xxxx@outlook.com' ); +} +ok("got to the end without dieing (note without DEBUGGING passing this test means nothing)"); + diff --git a/t/re/rxcode.t b/t/re/rxcode.t index 19a859b..263c234 100644 --- a/t/re/rxcode.t +++ b/t/re/rxcode.t @@ -2,8 +2,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan tests => 40; diff --git a/t/re/subst.t b/t/re/subst.t index b85ff3b..7b9a44b 100644 --- a/t/re/subst.t +++ b/t/re/subst.t @@ -2,9 +2,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; require './test.pl'; + set_up_inc('../lib'); + require Config; import Config; require './charset_tools.pl'; } diff --git a/t/re/uniprops.t b/t/re/uniprops.t index 927f8a7..7960771 100644 --- a/t/re/uniprops.t +++ b/t/re/uniprops.t @@ -6,7 +6,7 @@ no warnings 'once'; # directory. # It is skipped by default under PERL_DEBUG_READONLY_COW, but you can run -# it directly via: cd t; ./perl ../lib/unicore/TestProp.pl +# it directly via: cd t; ./perl -I../lib ../lib/unicore/TestProp.pl require Config; if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) { @@ -16,4 +16,15 @@ if ($Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DEBUG_READONLY_COW\b/) { do '../lib/unicore/TestProp.pl'; +# Since TestProp.pl explicitly exits, we will only get here if it +# could not load. +if (defined &DynaLoader::boot_DynaLoader # not miniperl + || eval 'require "unicore/Heavy.pl"' # or tables are built +) { + die "Could not run lib/unicore/TestProp.pl: ", $@||$!; +} +else { + print "1..0 # Skip Unicode tables not built yet\n"; +} + 0 diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t index 885c8cc..f148317 100644 --- a/t/run/fresh_perl.t +++ b/t/run/fresh_perl.t @@ -742,6 +742,8 @@ utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN) /^([[:digit:]]+)/; EXPECT ######## [perl #20667] unicode regex vs non-unicode regex +# SKIP: !defined &DynaLoader::boot_DynaLoader && !eval 'require "unicore/Heavy.pl"' +# (skip under miniperl if Unicode tables are not built yet) $toto = 'Hello'; $toto =~ /\w/; # this line provokes the problem! $name = 'A B'; diff --git a/t/run/runenv.t b/t/run/runenv.t index 9380d24..82846a4 100644 --- a/t/run/runenv.t +++ b/t/run/runenv.t @@ -99,12 +99,12 @@ try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'], try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'], "", - qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); + qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); # Fails in 5.6.0 try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'], "", - qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); + qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); # Fails in 5.6.0 try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'], diff --git a/t/run/switchM.t b/t/run/switchM.t index d2b5994..603d5c5 100644 --- a/t/run/switchM.t +++ b/t/run/switchM.t @@ -14,11 +14,13 @@ require './test.pl'; plan(4); like(runperl(switches => ['-Irun/flib', '-Mbroken'], stderr => 1), - qr/^Global symbol "\$x" requires explicit package name at run\/flib\/broken.pm line 6\./, + qr/^Global symbol "\$x" requires explicit package name \(did you (?x: + )forget to declare "my \$x"\?\) at run\/flib\/broken.pm line 6\./, "Ensure -Irun/flib produces correct filename in warnings"); like(runperl(switches => ['-Irun/flib/', '-Mbroken'], stderr => 1), - qr/^Global symbol "\$x" requires explicit package name at run\/flib\/broken.pm line 6\./, + qr/^Global symbol "\$x" requires explicit package name \(did you (?x: + )forget to declare "my \$x"\?\) at run\/flib\/broken.pm line 6\./, "Ensure -Irun/flib/ produces correct filename in warnings"); SKIP: { diff --git a/t/run/switches.t b/t/run/switches.t index a2e4bad..09b77c7 100644 --- a/t/run/switches.t +++ b/t/run/switches.t @@ -15,7 +15,6 @@ BEGIN { require "./test.pl"; } plan(tests => 115); use Config; -use Errno qw(EACCES EISDIR); BEGIN { eval 'use POSIX qw(setlocale LC_ALL)' } # due to a bug in VMS's piping which makes it impossible for runperl() @@ -123,7 +122,11 @@ SKIP: { # Win32 won't let us open the directory, so we never get to die with # EISDIR, which happens after open. - my $error = do { local $! = $^O eq 'MSWin32' ? EACCES : EISDIR; "$!" }; + require Errno; + import Errno qw(EACCES EISDIR); + my $error = do { + local $! = $^O eq 'MSWin32' ? &EACCES : &EISDIR; "$!" + }; like( runperl( switches => [ '-c' ], args => [ $tempdir ], stderr => 1), qr/Can't open perl script.*$tempdir.*\Q$error/s, diff --git a/t/test.pl b/t/test.pl index 13db432..d9a3220 100644 --- a/t/test.pl +++ b/t/test.pl @@ -105,6 +105,12 @@ sub is_miniperl { return !defined &DynaLoader::boot_DynaLoader; } +sub set_up_inc { + # Don’t clobber @INC under miniperl + @INC = () unless is_miniperl; + unshift @INC, @_; +} + sub _comment { return map { /^#/ ? "$_\n" : "# $_\n" } map { split /\n/ } @_; @@ -158,6 +164,13 @@ sub skip_all_without_config { } } +sub skip_all_without_unicode_tables { # (but only under miniperl) + if (is_miniperl()) { + skip_all_if_miniperl("Unicode tables not built yet") + unless eval 'require "unicore/Heavy.pl"'; + } +} + sub find_git_or_skip { my ($source_dir, $reason); if (-d '.git') { diff --git a/t/uni/cache.t b/t/uni/cache.t index 7b6e31e..50087c1 100644 --- a/t/uni/cache.t +++ b/t/uni/cache.t @@ -1,7 +1,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib .); - require "test.pl"; + require './test.pl'; + set_up_inc('../lib'); + skip_all_without_unicode_tables(); } plan tests => 1; diff --git a/t/uni/case.pl b/t/uni/case.pl index 08df670..f9c3640 100644 --- a/t/uni/case.pl +++ b/t/uni/case.pl @@ -1,4 +1,8 @@ -require "test.pl"; +BEGIN { + require "test.pl"; + set_up_inc(qw(../lib .)); + skip_all_without_unicode_tables(); +} use strict; use warnings; diff --git a/t/uni/class.t b/t/uni/class.t index ab21b02..92038c0 100644 --- a/t/uni/class.t +++ b/t/uni/class.t @@ -1,7 +1,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib .); - require "test.pl"; + require './test.pl'; + set_up_inc(qw(../lib .)); + skip_all_without_unicode_tables(); } plan tests => 11; diff --git a/t/uni/fold.t b/t/uni/fold.t index f016d30..e3542c0 100644 --- a/t/uni/fold.t +++ b/t/uni/fold.t @@ -6,9 +6,10 @@ use warnings; BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; - require Config; import Config; require './test.pl'; + set_up_inc('../lib'); + skip_all_without_unicode_tables(); + require Config; import Config; require './loc_tools.pl'; # Contains find_utf8_ctype_locale() } diff --git a/t/uni/gv.t b/t/uni/gv.t index 670bb6a..9c48cef 100644 --- a/t/uni/gv.t +++ b/t/uni/gv.t @@ -6,15 +6,16 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); + skip_all_without_unicode_tables(); } use utf8; use open qw( :utf8 :std ); use warnings; -plan( tests => 207 ); +plan( tests => 206 ); # type coersion on assignment $ᕘ = 'ᕘ'; @@ -491,7 +492,7 @@ no warnings 'once'; format = . - foreach my $value ({1=>2}, *STDOUT{IO}, \&ok, *STDOUT{FORMAT}) { + foreach my $value ({1=>2}, *STDOUT{IO}, *STDOUT{FORMAT}) { # *STDOUT{IO} returns a reference to a PVIO. As it's blessed, ref returns # IO::Handle, which isn't what we want. my $type = $value; diff --git a/t/uni/labels.t b/t/uni/labels.t index 3fa9d38..efae494 100644 --- a/t/uni/labels.t +++ b/t/uni/labels.t @@ -4,8 +4,9 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); + skip_all_without_unicode_tables(); } use utf8; diff --git a/t/uni/lex_utf8.t b/t/uni/lex_utf8.t index d6c6261..5391e3c 100644 --- a/t/uni/lex_utf8.t +++ b/t/uni/lex_utf8.t @@ -8,13 +8,13 @@ BEGIN { chdir 't'; @INC = '../lib'; require './test.pl'; - skip_all_if_miniperl("no dynamic loading on miniperl, no re"); + skip_all_without_unicode_tables(); skip_all('EBCDIC') if $::IS_EBCDIC; } use strict; -plan (tests => 15); +plan (tests => 16); use charnames ':full'; use utf8; @@ -61,5 +61,10 @@ eval 'tr νaνbν'; is $@, "", 'y/// compiles, where / is actually a wide character'; is $_, "b", 'transliteration worked'; +use constant foofoo=>qq|\xc4\xb5|; +{ no strict; ()=${"\xc4\xb5::foo"} } # vivify ĵ package +eval 'my foofoo $dog'; # foofoo was resolving to ĵ, not ĵ +is $@, '', 'my constant $var in utf8 scope where constant is not utf8'; + __END__ diff --git a/t/uni/lower.t b/t/uni/lower.t index 5b706af..8c8a053 100644 --- a/t/uni/lower.t +++ b/t/uni/lower.t @@ -1,7 +1,6 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib uni .); - require "case.pl"; + require "uni/case.pl"; } casetest(0, # No extra tests run here, diff --git a/t/uni/method.t b/t/uni/method.t index 4f9d72d..abe3c83 100644 --- a/t/uni/method.t +++ b/t/uni/method.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); + @INC = qw(. ../lib ../cpan/parent/lib); require "test.pl"; } diff --git a/t/uni/opcroak.t b/t/uni/opcroak.t index 29909d7..7bc9024 100644 --- a/t/uni/opcroak.t +++ b/t/uni/opcroak.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../dist/base/lib'; require './test.pl'; } @@ -34,6 +34,8 @@ like $@, qr/Type of arg 1 to main::\x{30cd} must be/u, "bad type croak is UTF-8 } END_FIELDS +die $@ if $@; + for ( [ element => 'my ＦŌŌ $bàr = ＦŌŌ->new; $bàr->{クラス};' ], [ slice => 'my ＦŌŌ $bàr = ＦŌŌ->new; @{$bàr}{ qw( a クラス ) };' ] diff --git a/t/uni/parser.t b/t/uni/parser.t index b71ca88..83ffd8e 100644 --- a/t/uni/parser.t +++ b/t/uni/parser.t @@ -5,14 +5,15 @@ BEGIN { require './test.pl'; + skip_all_without_unicode_tables(); } -plan (tests => 52); +plan (tests => 51); use utf8; use open qw( :utf8 :std ); -ok *tèst, "*main::tèst", "sanity check."; +is *tèst, "*main::tèst", "sanity check."; ok $::{"tèst"}, "gets the right glob in the stash."; my $glob_by_sub = sub { *ｍａｉｎ::method }->(); @@ -81,8 +82,7 @@ closedir FÒÒ; sub участники { 1 } ok $::{"участники"}, "non-const sub declarations generate the right glob"; -ok *{$::{"участники"}}{CODE}; -is *{$::{"участники"}}{CODE}->(), 1; +is $::{"участники"}->(), 1; sub 原 () { 1 } diff --git a/t/uni/readline.t b/t/uni/readline.t index f865bc0..294262e 100644 --- a/t/uni/readline.t +++ b/t/uni/readline.t @@ -2,8 +2,8 @@ BEGIN { chdir 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } plan tests => 7; diff --git a/t/uni/stash.t b/t/uni/stash.t index 3d41e40..31d6c9d 100644 --- a/t/uni/stash.t +++ b/t/uni/stash.t @@ -6,8 +6,8 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; require './test.pl'; + set_up_inc('../lib'); } use utf8; diff --git a/t/uni/title.t b/t/uni/title.t index 2d6dcb7..6acaf55 100644 --- a/t/uni/title.t +++ b/t/uni/title.t @@ -1,7 +1,6 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib uni .); - require "case.pl"; + require "uni/case.pl"; } casetest(0, # No extra tests run here, diff --git a/t/uni/universal.t b/t/uni/universal.t index c999dd8..56b41d4 100644 --- a/t/uni/universal.t +++ b/t/uni/universal.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + @INC = qw '../lib ../dist/base/lib'; $| = 1; require "./test.pl"; } diff --git a/t/uni/upper.t b/t/uni/upper.t index 315680c..c8bdb4b 100644 --- a/t/uni/upper.t +++ b/t/uni/upper.t @@ -1,7 +1,6 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(../lib uni .); - require "case.pl"; + require "uni/case.pl"; } is(uc("\x{3B1}\x{345}\x{301}"), "\x{391}\x{301}\x{399}", 'Verify moves YPOGEGRAMMENI'); diff --git a/t/uni/variables.t b/t/uni/variables.t index d802a0a..23d3503 100644 --- a/t/uni/variables.t +++ b/t/uni/variables.t @@ -5,6 +5,7 @@ BEGIN { require './test.pl'; + skip_all_without_unicode_tables(); } use 5.016; diff --git a/t/win32/runenv.t b/t/win32/runenv.t index d487ea7..0e2b0ca 100644 --- a/t/win32/runenv.t +++ b/t/win32/runenv.t @@ -96,12 +96,12 @@ try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'], "", - qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); + qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); # Fails in 5.6.0 try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'], "", - qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); + qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); # Fails in 5.6.0 try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], diff --git a/time64.c b/time64.c index 74914bd..f0e8d71 100644 --- a/time64.c +++ b/time64.c @@ -88,6 +88,7 @@ static const char dow_year_start[SOLAR_CYCLE_LENGTH] = { #define CHEAT_YEARS 108 #define IS_LEAP(n) ((!(((n) + 1900) % 400) || (!(((n) + 1900) % 4) && (((n) + 1900) % 100))) != 0) +#undef WRAP /* some define this */ #define WRAP(a,b,m) ((a) = ((a) < 0 ) ? ((b)--, (a) + (m)) : (a)) #ifdef USE_SYSTEM_LOCALTIME @@ -372,19 +373,19 @@ static struct TM *S_gmtime64_r (const Time64_T *in_time, struct TM *p) p->tm_zone = (char *)"UTC"; #endif - v_tm_sec = (int)fmod(time, 60.0); - time = time >= 0 ? floor(time / 60.0) : ceil(time / 60.0); - v_tm_min = (int)fmod(time, 60.0); - time = time >= 0 ? floor(time / 60.0) : ceil(time / 60.0); - v_tm_hour = (int)fmod(time, 24.0); - time = time >= 0 ? floor(time / 24.0) : ceil(time / 24.0); + v_tm_sec = (int)Perl_fmod(time, 60.0); + time = time >= 0 ? Perl_floor(time / 60.0) : Perl_ceil(time / 60.0); + v_tm_min = (int)Perl_fmod(time, 60.0); + time = time >= 0 ? Perl_floor(time / 60.0) : Perl_ceil(time / 60.0); + v_tm_hour = (int)Perl_fmod(time, 24.0); + time = time >= 0 ? Perl_floor(time / 24.0) : Perl_ceil(time / 24.0); v_tm_tday = time; WRAP (v_tm_sec, v_tm_min, 60); WRAP (v_tm_min, v_tm_hour, 60); WRAP (v_tm_hour, v_tm_tday, 24); - v_tm_wday = (int)fmod((v_tm_tday + 4.0), 7.0); + v_tm_wday = (int)Perl_fmod((v_tm_tday + 4.0), 7.0); if (v_tm_wday < 0) v_tm_wday += 7; m = v_tm_tday; @@ -396,7 +397,7 @@ static struct TM *S_gmtime64_r (const Time64_T *in_time, struct TM *p) if (m >= 0) { /* Gregorian cycles, this is huge optimization for distant times */ - cycles = (int)floor(m / (Time64_T) days_in_gregorian_cycle); + cycles = (int)Perl_floor(m / (Time64_T) days_in_gregorian_cycle); if( cycles ) { m -= (cycles * (Time64_T) days_in_gregorian_cycle); year += (cycles * years_in_gregorian_cycle); @@ -420,7 +421,7 @@ static struct TM *S_gmtime64_r (const Time64_T *in_time, struct TM *p) year--; /* Gregorian cycles */ - cycles = (int)ceil((m / (Time64_T) days_in_gregorian_cycle) + 1); + cycles = (int)Perl_ceil((m / (Time64_T) days_in_gregorian_cycle) + 1); if( cycles ) { m -= (cycles * (Time64_T) days_in_gregorian_cycle); year += (cycles * years_in_gregorian_cycle); diff --git a/toke.c b/toke.c index 0f0641f..8585b7a 100644 --- a/toke.c +++ b/toke.c @@ -54,7 +54,6 @@ Individual members of C have their own documentation. #define PL_lex_casestack (PL_parser->lex_casestack) #define PL_lex_defer (PL_parser->lex_defer) #define PL_lex_dojoin (PL_parser->lex_dojoin) -#define PL_lex_expect (PL_parser->lex_expect) #define PL_lex_formbrack (PL_parser->lex_formbrack) #define PL_lex_inpat (PL_parser->lex_inpat) #define PL_lex_inwhat (PL_parser->lex_inwhat) @@ -114,6 +113,11 @@ static const char* const ident_too_long = "Identifier too long"; #define SPACE_OR_TAB(c) isBLANK_A(c) +#define HEXFP_PEEK(s) \ + (((s[0] == '.') && \ + (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \ + isALPHA_FOLD_EQ(s[0], 'p')) + /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -163,11 +167,6 @@ static const char* const lex_state_names[] = { #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) -# define SKIPSPACE0(s) skipspace(s) -# define SKIPSPACE1(s) skipspace(s) -# define SKIPSPACE2(s,tsv) skipspace(s) -# define PEEKSPACE(s) skipspace(s) - /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. @@ -191,6 +190,7 @@ static const char* const lex_state_names[] = { * PWop : power operator * PMop : pattern-matching operator * Aop : addition-level operator + * AopNOASSIGN : addition-level operator that is never part of .= * Mop : multiplication-level operator * Eop : equality-testing operator * Rop : relational operator <= != gt @@ -212,7 +212,10 @@ static const char* const lex_state_names[] = { #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval)) #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval)) #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1])) -#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX)) +#define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \ + pl_yylval.ival=f, \ + PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \ + REPORT((int)LOOPEX)) #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP)) #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0)) #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP)) @@ -223,6 +226,7 @@ static const char* const lex_state_names[] = { #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP))) #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP)) #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP))) +#define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP)) #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP))) #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP)) #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP)) @@ -240,7 +244,7 @@ static const char* const lex_state_names[] = { PL_last_lop_op = f; \ if (*s == '(') \ return REPORT( (int)FUNC1 ); \ - s = PEEKSPACE(s); \ + s = skipspace(s); \ return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ } #define UNI(f) UNI3(f,XTERM,1) @@ -465,8 +469,8 @@ S_deprecate_commaless_var_list(pTHX) { /* * S_ao * - * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR - * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN + * This subroutine looks for an '=' next to the operator that has just been + * parsed and turns it into an ASSIGNOP if it finds one. */ STATIC int @@ -1843,7 +1847,10 @@ S_check_uni(pTHX) /* * S_lop * Build a list operator (or something that might be one). The rules: - * - if we have a next token, then it's a list operator [why?] + * - if we have a next token, then it's a list operator (no parens) for + * which the next token has already been parsed; e.g., + * sort foo @args + * sort foo (@args) * - if the next thing is an opening paren, then it's a function * - else it's a list operator */ @@ -1855,15 +1862,15 @@ S_lop(pTHX_ I32 f, int x, char *s) pl_yylval.ival = f; CLINE; - PL_expect = x; PL_bufptr = s; PL_last_lop = PL_oldbufptr; PL_last_lop_op = (OPCODE)f; if (PL_nexttoke) goto lstop; + PL_expect = x; if (*s == '(') return REPORT(FUNC); - s = PEEKSPACE(s); + s = skipspace(s); if (*s == '(') return REPORT(FUNC); else { @@ -1896,7 +1903,6 @@ S_force_next(pTHX_ I32 type) PL_nexttoke++; if (PL_lex_state != LEX_KNOWNEXT) { PL_lex_defer = PL_lex_state; - PL_lex_expect = PL_expect; PL_lex_state = LEX_KNOWNEXT; } } @@ -1981,7 +1987,6 @@ S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len) * a keyword (do this if the word is a label, e.g. goto FOO) * int allow_pack : if true, : characters will also be allowed (require, * use, etc. do this) - * int allow_initial_tick : used by the "sub" lexer only. */ STATIC char * @@ -1992,7 +1997,7 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) PERL_ARGS_ASSERT_FORCE_WORD; - start = SKIPSPACE1(start); + start = skipspace(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || (allow_pack && *s == ':') ) @@ -2006,7 +2011,7 @@ S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack) return start; } if (token == METHOD) { - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '(') PL_expect = XTERM; else { @@ -2048,7 +2053,7 @@ S_force_ident(pTHX_ const char *s, int kind) warnings if the symbol must be introduced in an eval. GSAR 96-10-12 */ gv_fetchpvn_flags(s, len, - (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) + (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : @@ -2110,7 +2115,7 @@ S_force_version(pTHX_ char *s, int guessing) PERL_ARGS_ASSERT_FORCE_VERSION; - s = SKIPSPACE1(s); + s = skipspace(s); d = s; if (*d == 'v') @@ -2163,7 +2168,7 @@ S_force_strict_version(pTHX_ char *s) version = newSVOP(OP_CONST, 0, ver); } else if ( (*s != ';' && *s != '{' && *s != '}' ) && - (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' ))) + (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' ))) { PL_bufptr = s; if (errstr) @@ -3496,7 +3501,7 @@ S_scan_const(pTHX_ char *start) *d++ = '\t'; break; case 'e': - *d++ = ASCII_TO_NATIVE('\033'); + *d++ = ESC_NATIVE; break; case 'a': *d++ = '\a'; @@ -3807,12 +3812,18 @@ S_intuit_more(pTHX_ char *s) */ STATIC int -S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) +S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv) { char *s = start + (*start == '$'); char tmpbuf[sizeof PL_tokenbuf]; STRLEN len; GV* indirgv; + /* Mustn't actually add anything to a symbol table. + But also don't want to "initialise" any placeholder + constants that might already be there into full + blown PVGVs with attached PVCV. */ + GV * const gv = + ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL; PERL_ARGS_ASSERT_INTUIT_METHOD; @@ -3832,7 +3843,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY || isUPPER(*PL_tokenbuf)) return 0; - s = PEEKSPACE(s); + s = skipspace(s); PL_bufptr = start; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; @@ -3855,7 +3866,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) return 0; /* filehandle or package name makes it a method */ if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) { - s = PEEKSPACE(s); + s = skipspace(s); if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>') return 0; /* no assumptions -- "=>" quotes bareword */ bare_package: @@ -4116,7 +4127,7 @@ S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len) if (gv && GvCV(gv)) { SV * const sv = cv_const_sv(GvCV(gv)); if (sv) - pkgname = SvPV_const(sv, len); + return gv_stashsv(sv, 0); } return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0); @@ -4131,11 +4142,11 @@ S_tokenize_use(pTHX_ int is_use, char *s) { yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression", is_use ? "use" : "no")); PL_expect = XTERM; - s = SKIPSPACE1(s); + s = skipspace(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { s = force_version(s, TRUE); if (*s == ';' || *s == '}' - || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) { + || (s = skipspace(s), (*s == ';' || *s == '}'))) { NEXTVAL_NEXTTOKE.opval = NULL; force_next(WORD); } @@ -4268,7 +4279,6 @@ Perl_yylex(pTHX) pl_yylval = PL_nextval[PL_nexttoke]; if (!PL_nexttoke) { PL_lex_state = PL_lex_defer; - PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } { @@ -4376,9 +4386,9 @@ Perl_yylex(pTHX) PL_lex_starts = 0; /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (PL_lex_casemods == 1 && PL_lex_inpat) - OPERATOR(','); + TOKEN(','); else - Aop(OP_CONCAT); + AopNOASSIGN(OP_CONCAT); } else return yylex(); @@ -4423,9 +4433,9 @@ Perl_yylex(pTHX) s = PL_bufptr; /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) - OPERATOR(','); + TOKEN(','); else - Aop(OP_CONCAT); + AopNOASSIGN(OP_CONCAT); } return yylex(); @@ -4513,9 +4523,9 @@ Perl_yylex(pTHX) if (PL_lex_starts++) { /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ if (!PL_lex_casemods && PL_lex_inpat) - OPERATOR(','); + TOKEN(','); else - Aop(OP_CONCAT); + AopNOASSIGN(OP_CONCAT); } else { PL_bufptr = s; @@ -4788,7 +4798,7 @@ Perl_yylex(pTHX) * line contains "Perl" rather than "perl" */ if (!d) { for (d = ipathend-4; d >= ipath; --d) { - if ((*d == 'p' || *d == 'P') + if (isALPHA_FOLD_EQ(*d, 'p') && !ibcmp(d, "perl", 4)) { break; @@ -4870,7 +4880,7 @@ Perl_yylex(pTHX) != PL_unicode) baduni = TRUE; } - if (baduni || *d1 == 'M' || *d1 == 'm') { + if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) { const char * const m = d1; while (*d1 && !isSPACE(*d1)) d1++; @@ -5052,7 +5062,7 @@ Perl_yylex(pTHX) } else if (*s == '>') { s++; - s = SKIPSPACE1(s); + s = skipspace(s); if (FEATURE_POSTDEREF_IS_ENABLED && ( ((*s == '$' || *s == '&') && s[1] == '*') ||(*s == '$' && s[1] == '#' && s[2] == '*') @@ -5229,7 +5239,7 @@ Perl_yylex(pTHX) case XATTRTERM: PL_expect = XTERMBLOCK; grabattrs: - s = PEEKSPACE(s); + s = skipspace(s); attrs = NULL; while (isIDFIRST_lazy_if(s,UTF)) { I32 tmp; @@ -5313,9 +5323,9 @@ Perl_yylex(pTHX) newSVOP(OP_CONST, 0, sv)); } - s = PEEKSPACE(d); + s = skipspace(d); if (*s == ':' && s[1] != ':') - s = PEEKSPACE(s+1); + s = skipspace(s+1); else if (s == d) break; /* require real whitespace or :'s */ /* XXX losing whitespace on sequential attributes here */ @@ -5366,7 +5376,7 @@ Perl_yylex(pTHX) PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ else PL_expect = XTERM; - s = SKIPSPACE1(s); + s = skipspace(s); PL_lex_allbrackets++; TOKEN('('); case ';': @@ -5374,13 +5384,14 @@ Perl_yylex(pTHX) TOKEN(0); CLINE; s++; - OPERATOR(';'); + PL_expect = XSTATE; + TOKEN(';'); case ')': if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) TOKEN(0); s++; PL_lex_allbrackets--; - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') PREBLOCK(')'); TERM(')'); @@ -5438,18 +5449,18 @@ Perl_yylex(pTHX) } } /* FALLTHROUGH */ - case XATTRBLOCK: - case XBLOCK: - PL_lex_brackstack[PL_lex_brackets++] = XSTATE; - PL_lex_allbrackets++; - PL_expect = XSTATE; - break; case XATTRTERM: case XTERMBLOCK: PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; PL_lex_allbrackets++; PL_expect = XSTATE; break; + case XATTRBLOCK: + case XBLOCK: + PL_lex_brackstack[PL_lex_brackets++] = XSTATE; + PL_lex_allbrackets++; + PL_expect = XSTATE; + break; case XBLOCKTERM: PL_lex_brackstack[PL_lex_brackets++] = XTERM; PL_lex_allbrackets++; @@ -5462,7 +5473,7 @@ Perl_yylex(pTHX) else PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; PL_lex_allbrackets++; - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '}') { if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { PL_expect = XTERM; @@ -5473,6 +5484,11 @@ Perl_yylex(pTHX) } OPERATOR(HASHBRACK); } + if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) { + /* ${...} or @{...} etc., but not print {...} */ + PL_expect = XTERM; + break; + } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a @@ -5492,7 +5508,7 @@ Perl_yylex(pTHX) if (*s == '\'' || *s == '"' || *s == '`') { /* common case: get past first string, handling escapes */ for (t++; t < PL_bufend && *t != *s;) - if (*t++ == '\\' && (*t == '\\' || *t == *s)) + if (*t++ == '\\') t++; t++; } @@ -5895,7 +5911,7 @@ Perl_yylex(pTHX) { const char tmp = *s; if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) - s = SKIPSPACE1(s); + s = skipspace(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { @@ -5907,7 +5923,7 @@ Perl_yylex(pTHX) while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$') t++; if (*t++ == ',') { - PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ + PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */ while (t < PL_bufend && *t != ']') t++; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), @@ -6007,7 +6023,7 @@ Perl_yylex(pTHX) PREREF('@'); } if (PL_lex_state == LEX_NORMAL) - s = SKIPSPACE1(s); + s = skipspace(s); if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) { if (*s == '{') PL_tokenbuf[0] = '%'; @@ -6198,7 +6214,7 @@ Perl_yylex(pTHX) } /* avoid v123abc() or $h{v1}, allow C */ if (!isALPHA(*start) && (PL_expect == XTERM - || PL_expect == XREF || PL_expect == XSTATE + || PL_expect == XSTATE || PL_expect == XTERMORDORDOR)) { GV *const gv = gv_fetchpvn_flags(s, start - s, UTF ? SVf_UTF8 : 0, SVt_PVCV); @@ -6303,12 +6319,12 @@ Perl_yylex(pTHX) } else if (result == KEYWORD_PLUGIN_STMT) { pl_yylval.opval = o; CLINE; - PL_expect = XSTATE; + if (!PL_nexttoke) PL_expect = XSTATE; return REPORT(PLUGSTMT); } else if (result == KEYWORD_PLUGIN_EXPR) { pl_yylval.opval = o; CLINE; - PL_expect = XOPERATOR; + if (!PL_nexttoke) PL_expect = XOPERATOR; return REPORT(PLUGEXPR); } else { Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", @@ -6457,10 +6473,7 @@ Perl_yylex(pTHX) just_a_word: { int pkgname = 0; const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); - const char penultchar = - lastchar && PL_bufptr - 2 >= PL_linestart - ? PL_bufptr[-2] - : 0; + bool safebw; /* Get the rest if it looks like a package qualifier */ @@ -6487,8 +6500,7 @@ Perl_yylex(pTHX) no_op("Bareword",s); } - /* Look for a subroutine with this name in current package, - unless this is a lexical sub, or name is "Foo::", + /* See if the name is "Foo::", in which case Foo is a bareword (and a package name). */ @@ -6504,25 +6516,17 @@ Perl_yylex(pTHX) PL_tokenbuf[len] = '\0'; gv = NULL; gvp = 0; + safebw = TRUE; } else { - if (!lex && !gv) { - /* Mustn't actually add anything to a symbol table. - But also don't want to "initialise" any placeholder - constants that might already be there into full - blown PVGVs with attached PVCV. */ - gv = gv_fetchpvn_flags(PL_tokenbuf, len, - GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ), - SVt_PVCV); - } - len = 0; + safebw = FALSE; } /* if we saw a global override before, get the right name */ if (!sv) sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, - len ? len : strlen(PL_tokenbuf)); + len); if (gvp) { SV * const tmp_sv = sv; sv = newSVpvs("CORE::GLOBAL::"); @@ -6537,17 +6541,28 @@ Perl_yylex(pTHX) pl_yylval.opval->op_private = OPpCONST_BARE; /* And if "Foo::", then that's what it certainly is. */ - if (len) + if (safebw) goto safe_bareword; if (!off) { OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv)); const_op->op_private = OPpCONST_BARE; - rv2cv_op = newCVREF(0, const_op); - cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0); + rv2cv_op = + newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op); + cv = lex + ? isGV(gv) + ? GvCV(gv) + : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV + ? (CV *)SvRV(gv) + : (CV *)gv + : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB); } + /* Use this var to track whether intuit_method has been + called. intuit_method returns 0 or > 255. */ + tmp = 1; + /* See if it's the indirect object for a list operator. */ if (PL_oldoldbufptr && @@ -6561,17 +6576,13 @@ Perl_yylex(pTHX) bool immediate_paren = *s == '('; /* (Now we can afford to cross potential line boundary.) */ - s = SKIPSPACE2(s,nextPL_nextwhite); + s = skipspace(s); /* Two barewords in a row may indicate method call. */ if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && - (tmp = intuit_method(s, gv, cv))) { - op_free(rv2cv_op); - if (tmp == METHOD && !PL_lex_allbrackets && - PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) - PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; - return REPORT(tmp); + (tmp = intuit_method(s, lex ? NULL : sv, cv))) { + goto method; } /* If not a declared subroutine, it's an indirect object. */ @@ -6599,13 +6610,17 @@ Perl_yylex(pTHX) if (*s == '=' && s[1] == '>' && !pkgname) { op_free(rv2cv_op); CLINE; - /* This is our own scalar, created a few lines above, - so this is safe. */ - SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv); - sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf); - if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) - SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv); - SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv); + if (gvp || (lex && !off)) { + assert (cSVOPx(pl_yylval.opval)->op_sv == sv); + /* This is our own scalar, created a few lines + above, so this is safe. */ + SvREADONLY_off(sv); + sv_setpv(sv, PL_tokenbuf); + if (UTF && !IN_BYTES + && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(sv); + SvREADONLY_on(sv); + } TERM(WORD); } @@ -6623,7 +6638,6 @@ Perl_yylex(pTHX) } NEXTVAL_NEXTTOKE.opval = off ? rv2cv_op : pl_yylval.opval; - PL_expect = XOPERATOR; if (off) op_free(pl_yylval.opval), force_next(PRIVATEREF); else op_free(rv2cv_op), force_next(WORD); @@ -6647,9 +6661,19 @@ Perl_yylex(pTHX) /* If followed by a bareword, see if it looks like indir obj. */ - if (!orig_keyword + if (tmp == 1 && !orig_keyword && (isIDFIRST_lazy_if(s,UTF) || *s == '$') - && (tmp = intuit_method(s, gv, cv))) { + && (tmp = intuit_method(s, lex ? NULL : sv, cv))) { + method: + if (lex && !off) { + assert(cSVOPx(pl_yylval.opval)->op_sv == sv); + SvREADONLY_off(sv); + sv_setpvn(sv, PL_tokenbuf, len); + if (UTF && !IN_BYTES + && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on (sv); + else SvUTF8_off(sv); + } op_free(rv2cv_op); if (tmp == METHOD && !PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) @@ -6660,13 +6684,6 @@ Perl_yylex(pTHX) /* Not a method, so call it a subroutine (if defined) */ if (cv) { - if (lastchar == '-' && penultchar != '-') { - const STRLEN l = len ? len : strlen(PL_tokenbuf); - Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()", - UTF8fARG(UTF, l, PL_tokenbuf), - UTF8fARG(UTF, l, PL_tokenbuf)); - } /* Check for a constant sub */ if ((sv = cv_const_sv_or_av(cv))) { its_constant: @@ -7027,7 +7044,7 @@ Perl_yylex(pTHX) PREBLOCK(DEFAULT); case KEY_do: - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') { @@ -7036,7 +7053,7 @@ Perl_yylex(pTHX) 1, &len); if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE")) && !keyword(PL_tokenbuf + 1, len, 0)) { - d = SKIPSPACE1(d); + d = skipspace(d); if (*d == '(') { force_ident_maybe_lex('&'); s = d; @@ -7075,8 +7092,6 @@ Perl_yylex(pTHX) UNI(OP_DBMCLOSE); case KEY_dump: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_DUMP); case KEY_else: @@ -7098,7 +7113,7 @@ Perl_yylex(pTHX) UNI(OP_EXIT); case KEY_eval: - s = SKIPSPACE1(s); + s = skipspace(s); if (*s == '{') { /* block eval */ PL_expect = XTERMBLOCK; UNIBRACK(OP_ENTERTRY); @@ -7147,7 +7162,7 @@ Perl_yylex(pTHX) if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR) return REPORT(0); pl_yylval.ival = CopLINE(PL_curcop); - s = SKIPSPACE1(s); + s = skipspace(s); if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) { char *p = s; @@ -7157,11 +7172,11 @@ Perl_yylex(pTHX) else if ((PL_bufend - p) >= 4 && strnEQ(p, "our", 3) && isSPACE(*(p + 3))) p += 3; - p = PEEKSPACE(p); + p = skipspace(p); /* skip optional package name, as in "for my abc $x (..)" */ if (isIDFIRST_lazy_if(p,UTF)) { p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); - p = PEEKSPACE(p); + p = skipspace(p); } if (*p != '$') Perl_croak(aTHX_ "Missing $ on loop variable"); @@ -7200,8 +7215,6 @@ Perl_yylex(pTHX) LOP(OP_GREPSTART, XREF); case KEY_goto: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_GOTO); case KEY_gmtime: @@ -7326,8 +7339,6 @@ Perl_yylex(pTHX) LOP(OP_KILL,XTERM); case KEY_last: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_LAST); case KEY_lc: @@ -7397,7 +7408,7 @@ Perl_yylex(pTHX) case KEY_my: case KEY_state: PL_in_my = (U16)tmp; - s = SKIPSPACE1(s); + s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) @@ -7426,8 +7437,6 @@ Perl_yylex(pTHX) OPERATOR(MY); case KEY_next: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_NEXT); case KEY_ne: @@ -7437,10 +7446,10 @@ Perl_yylex(pTHX) case KEY_no: s = tokenize_use(0, s); - TERM(USE); + TOKEN(USE); case KEY_not: - if (*s == '(' || (s = SKIPSPACE1(s), *s == '(')) + if (*s == '(' || (s = skipspace(s), *s == '(')) FUN1(OP_NOT); else { if (!PL_lex_allbrackets && @@ -7450,7 +7459,7 @@ Perl_yylex(pTHX) } case KEY_open: - s = SKIPSPACE1(s); + s = skipspace(s); if (isIDFIRST_lazy_if(s,UTF)) { const char *t; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, @@ -7510,10 +7519,9 @@ Perl_yylex(pTHX) case KEY_package: s = force_word(s,WORD,FALSE,TRUE); - s = SKIPSPACE1(s); + s = skipspace(s); s = force_strict_version(s); - PL_lex_expect = XBLOCK; - OPERATOR(PACKAGE); + PREBLOCK(PACKAGE); case KEY_pipe: LOP(OP_PIPE_OP,XTERM); @@ -7605,8 +7613,7 @@ Perl_yylex(pTHX) OLDLOP(OP_RETURN); case KEY_require: - s = SKIPSPACE1(s); - PL_expect = XOPERATOR; + s = skipspace(s); if (isDIGIT(*s)) { s = force_version(s, FALSE); } @@ -7627,7 +7634,7 @@ Perl_yylex(pTHX) } else pl_yylval.ival = 0; - PL_expect = XTERM; + PL_expect = PL_nexttoke ? XOPERATOR : XTERM; PL_bufptr = s; PL_last_uni = PL_oldbufptr; PL_last_lop_op = OP_REQUIRE; @@ -7638,8 +7645,6 @@ Perl_yylex(pTHX) UNI(OP_RESET); case KEY_redo: - PL_expect = XOPERATOR; - s = force_word(s,WORD,TRUE,FALSE); LOOPX(OP_REDO); case KEY_rename: @@ -7778,7 +7783,7 @@ Perl_yylex(pTHX) case KEY_sort: checkcomma(s,PL_tokenbuf,"subroutine name"); - s = SKIPSPACE1(s); + s = skipspace(s); PL_expect = XTERM; s = force_word(s,WORD,TRUE,TRUE); LOP(OP_SORT,XREF); @@ -8000,7 +8005,7 @@ Perl_yylex(pTHX) case KEY_use: s = tokenize_use(1, s); - OPERATOR(USE); + TOKEN(USE); case KEY_values: UNI(OP_VALUES); @@ -8145,10 +8150,7 @@ S_pending_ident(pTHX) pl_yylval.opval->op_private = OPpCONST_ENTERED; if (pit != '&') gv_fetchsv(sym, - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : GV_ADDMULTI - ), + GV_ADDMULTI, ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV : SVt_PVHV)); @@ -8192,7 +8194,7 @@ S_pending_ident(pTHX) pl_yylval.opval->op_private = OPpCONST_ENTERED; if (pit != '&') gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, - (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD) + (PL_in_eval ? GV_ADDMULTI : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ), ((PL_tokenbuf[0] == '$') ? SVt_PV : (PL_tokenbuf[0] == '@') ? SVt_PVAV @@ -8241,12 +8243,20 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) s++; if (*s == ',') { GV* gv; + PADOFFSET off; if (keyword(w, s - w, 0)) return; gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV); if (gv && GvCVu(gv)) return; + if (s - w <= 254) { + char tmpbuf[256]; + Copy(w, tmpbuf+1, s - w, char); + *tmpbuf = '&'; + off = pad_findmy_pvn(tmpbuf, s-w+1, UTF ? SVf_UTF8 : 0); + if (off != NOT_IN_PAD) return; + } Perl_croak(aTHX_ "No comma allowed after %s", what); } } @@ -8477,7 +8487,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) PERL_ARGS_ASSERT_SCAN_IDENT; if (isSPACE(*s)) - s = PEEKSPACE(s); + s = skipspace(s); if (isDIGIT(*s)) { while (isDIGIT(*s)) { if (d >= e) @@ -8515,7 +8525,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) s++; orig_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } } @@ -8575,7 +8585,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) *d = '\0'; tmp_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { /* ${foo[0]} and ${foo{bar}} notation. */ @@ -8614,7 +8624,7 @@ S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) if ( !tmp_copline ) tmp_copline = CopLINE(PL_curcop); if (s < PL_bufend && isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } /* Expect to find a closing } after consuming any trailing whitespace. @@ -9218,7 +9228,8 @@ S_scan_heredoc(pTHX_ char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) { + if (*s == term && PL_bufend-s >= len + && memEQ(s,PL_tokenbuf + 1,len)) { SvREFCNT_dec(PL_linestr); PL_linestr = linestr_save; PL_linestart = SvPVX(linestr_save); @@ -9367,9 +9378,7 @@ S_scan_inputsymbol(pTHX_ char *start) ++d; intro_sym: gv = gv_fetchpv(d, - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ), + GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ), SVt_PV); PL_lex_op = readline_overriden ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, @@ -9476,7 +9485,7 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re /* skip space before the delimiter */ if (isSPACE(*s)) { - s = PEEKSPACE(s); + s = skipspace(s); } /* mark where we are, in case we need to report errors */ @@ -9781,9 +9790,10 @@ S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 - 0b[01](_?[01])* - 0[0-7](_?[0-7])* - 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* + 0b[01](_?[01])* binary integers + 0[0-7](_?[0-7])* octal integers + 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers + 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the thing it reads. @@ -9867,17 +9877,17 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) const char *base, *Base, *max; /* check for hex */ - if (s[1] == 'x' || s[1] == 'X') { + if (isALPHA_FOLD_EQ(s[1], 'x')) { shift = 4; s += 2; just_zero = FALSE; - } else if (s[1] == 'b' || s[1] == 'B') { + } else if (isALPHA_FOLD_EQ(s[1], 'b')) { shift = 1; s += 2; just_zero = FALSE; } /* check for a decimal in disguise */ - else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') + else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e')) goto decimal; /* so it must be octal */ else { @@ -9979,10 +9989,6 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* this could be hexfp, but peek ahead * to avoid matching ".." */ -#define HEXFP_PEEK(s) \ - (((s[0] == '.') && \ - (isXDIGIT(s[1]) || s[1] == 'p' || s[1] == 'P')) \ - || s[0] == 'p' || s[0] == 'P') if (UNLIKELY(HEXFP_PEEK(s))) { goto out; } @@ -10043,7 +10049,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) total_bits--; } - if (total_bits > 0 && (*h == 'p' || *h == 'P')) { + if (total_bits > 0 && (isALPHA_FOLD_EQ(*h, 'p'))) { bool negexp = FALSE; h++; if (*h == '+') @@ -10202,18 +10208,19 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } /* read exponent part, if present */ - if (((*s == 'e' || *s == 'E') || - UNLIKELY(hexfp && (*s == 'p' || *s == 'P'))) && - strchr("+-0123456789_", s[1])) { + if ((isALPHA_FOLD_EQ(*s, 'e') + || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p'))) + && strchr("+-0123456789_", s[1])) + { floatit = TRUE; /* regardless of whether user said 3E5 or 3e5, use lower 'e', ditto for p (hexfloats) */ - if ((*s == 'e' || *s == 'E')) { + if ((isALPHA_FOLD_EQ(*s, 'e'))) { /* At least some Mach atof()s don't grok 'E' */ *d++ = 'e'; } - else if (UNLIKELY(hexfp && (*s == 'p' || *s == 'P'))) { + else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) { *d++ = 'p'; } diff --git a/uconfig.h b/uconfig.h index a1aa34f..81d5e06 100644 --- a/uconfig.h +++ b/uconfig.h @@ -1900,6 +1900,11 @@ * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ +/* HAS_LDEXPL: + * This symbol, if defined, indicates that the ldexpl routine is + * available to shift a long double floating-point number + * by an integral power of 2. + */ /* LONG_DOUBLEKIND: * LONG_DOUBLEKIND will be one of * LONG_DOUBLE_IS_DOUBLE @@ -1912,6 +1917,7 @@ * LONG_DOUBLE_IS_UNKNOWN_FORMAT * It is only defined if the system supports long doubles. */ +/*#define HAS_LDEXPL / **/ /*#define HAS_LONG_DOUBLE / **/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 8 /**/ @@ -2841,6 +2847,12 @@ /*#define PWGECOS / **/ /*#define PWPASSWD / **/ +/* I_QUADMATH: + * This symbol, if defined, indicates to the C program that it should + * include . + */ +/*#define I_QUADMATH / **/ + /* I_SYS_ACCESS: * This symbol, if defined, indicates to the C program that it should * include . @@ -3371,6 +3383,12 @@ */ /*#define HAS__FWALK / **/ +/* HAS_ACOSH: + * This symbol, if defined, indicates that the acosh routine is + * available to do the inverse hyperbolic cosine function. + */ +/*#define HAS_ACOSH / **/ + /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. @@ -3481,6 +3499,13 @@ */ /*#define FCNTL_CAN_LOCK / **/ +/* HAS_FEGETROUND: + * This symbol, if defined, indicates that the fegetround routine is + * available to return the macro corresponding to the current rounding + * mode. + */ +/*#define HAS_FEGETROUND / **/ + /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). @@ -3520,6 +3545,13 @@ */ /*#define HAS_FP_CLASS / **/ +/* HAS_FP_CLASSL: + * This symbol, if defined, indicates that the fp_classl routine is + * available to classify long doubles. Available for example in + * Digital UNIX. See for possible values HAS_FP_CLASS. + */ +/*#define HAS_FP_CLASSL / **/ + /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. @@ -3550,7 +3582,19 @@ * FP_NAN NaN * */ -/*#define HAS_FPCLASSIFY / **/ +/* HAS_FP_CLASSIFY: + * This symbol, if defined, indicates that the fp_classify routine is + * available to classify doubles. The values are defined in + * + * FP_NORMAL Normalized + * FP_ZERO Zero + * FP_INFINITE Infinity + * FP_SUBNORMAL Denormalized + * FP_NAN NaN + * + */ +/*#define HAS_FPCLASSIFY / **/ +/*#define HAS_FP_CLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is @@ -3570,6 +3614,12 @@ */ /*#define HAS_FPCLASSL / **/ +/* HAS_FPGETROUND: + * This symbol, if defined, indicates that the fpgetround routine is + * available to get the floating point rounding mode. + */ +/*#define HAS_FPGETROUND / **/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ @@ -3582,13 +3632,6 @@ */ /*#define HAS_FREXPL / **/ -/* HAS_LDEXPL: - * This symbol, if defined, indicates that the ldexpl routine is - * available to shift a long double floating-point number - * by an integral power of 2. - */ -/*#define HAS_LDEXPL / **/ - /* HAS_STRUCT_FS_DATA: * This symbol, if defined, indicates that the struct fs_data * to do statfs() is supported. @@ -3729,12 +3772,25 @@ */ /*#define HAS_ISFINITE / **/ +/* HAS_ISFINITEL: + * This symbol, if defined, indicates that the isfinitel routine is + * available to check whether a long double is finite. + * (non-infinity non-NaN). + */ +/*#define HAS_ISFINITEL / **/ + /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ +/* HAS_ISINFL: + * This symbol, if defined, indicates that the isinfl routine is + * available to check whether a long double is an infinity. + */ +/*#define HAS_ISINFL / **/ + /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. @@ -3747,6 +3803,19 @@ */ /*#define HAS_ISNANL / **/ +/* HAS_J0: + * This symbol, if defined, indicates to the C program that the + * j0() function is available for Bessel functions of the first + * kind of the order zero, for doubles. + */ +/* HAS_J0L: + * This symbol, if defined, indicates to the C program that the + * j0l() function is available for Bessel functions of the first + * kind of the order zero, for long doubles. + */ +/*#define HAS_J0 / **/ +/*#define HAS_J0L / **/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number @@ -4131,6 +4200,12 @@ */ /*#define HAS_TIMEGM / **/ +/* HAS_TRUNCL: + * This symbol, if defined, indicates that the truncl routine is + * available. If copysignl is also present we can emulate modfl. + */ +/*#define HAS_TRUNCL / **/ + /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. @@ -4260,6 +4335,12 @@ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ +/* I_FENV: + * This symbol, if defined, indicates to the C program that it should + * include to get the floating point environment definitions. + */ +/*#define I_FENV / **/ + /* I_FP: * This symbol, if defined, indicates that exists and * should be included. @@ -4344,6 +4425,12 @@ */ /*#define I_STDBOOL / **/ +/* I_STDINT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +/*#define I_STDINT / **/ + /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. @@ -4727,6 +4814,14 @@ /*#define USE_LONG_DOUBLE / **/ #endif +/* USE_QUADMATH: + * This symbol, if defined, indicates that the quadmath library should + * be used when available. + */ +#ifndef USE_QUADMATH +/*#define USE_QUADMATH / **/ +#endif + /* USE_MORE_BITS: * This symbol, if defined, indicates that 64-bit interfaces and * long doubles should be used when available. @@ -4770,6 +4865,6 @@ #endif /* Generated from: - * 5f68e17a9d9e989b824daf55d2adcad3b7af2becfa8f627c6cb1d0e376f7e1a5 config_h.SH - * 98397a7d818a024628d6b34e5903a8f408da96601a2a19471c480511f3c8d914 uconfig.sh + * d7da79ac72d2191d6814ec98688e342f20eba70c64292c2e0b6b5622cdf3b6e6 config_h.SH + * a3cd0b705a952f6915cc1424cc116d4183481f54ba9605415baf93bc57e12122 uconfig.sh * ex: set ro: */ diff --git a/uconfig.sh b/uconfig.sh index 15fd327..0341bda 100644 --- a/uconfig.sh +++ b/uconfig.sh @@ -44,6 +44,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='undef' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='undef' d_archlib='undef' @@ -129,6 +130,7 @@ d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='undef' d_fds_bits='undef' +d_fegetround='undef' d_fgetpos='undef' d_finite='undef' d_finitel='undef' @@ -137,10 +139,13 @@ d_flock='undef' d_flockproto='undef' d_fork='define' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -233,9 +238,13 @@ d_ipv6_mreq_source='undef' d_isascii='undef' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='undef' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' @@ -458,6 +467,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='undef' d_u32align='define' @@ -561,6 +571,7 @@ i_dirent='define' i_dlfcn='undef' i_execinfo='undef' i_fcntl='undef' +i_fenv='undef' i_float='undef' i_fp='undef' i_fp_class='undef' @@ -589,6 +600,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -596,6 +608,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -803,6 +816,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='undef' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='false' diff --git a/uconfig64.sh b/uconfig64.sh index 06537c3..00fa9d0 100644 --- a/uconfig64.sh +++ b/uconfig64.sh @@ -45,6 +45,7 @@ d_SCNfldbl='define' d__fwalk='undef' d_access='undef' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='undef' d_archlib='undef' @@ -130,6 +131,7 @@ d_fcntl_can_lock='undef' d_fd_macros='undef' d_fd_set='undef' d_fds_bits='undef' +d_fegetround='undef' d_fgetpos='undef' d_finite='undef' d_finitel='undef' @@ -138,10 +140,13 @@ d_flock='undef' d_flockproto='undef' d_fork='define' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -234,9 +239,13 @@ d_ipv6_mreq_source='undef' d_isascii='undef' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='undef' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='undef' @@ -459,6 +468,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='undef' d_u32align='define' @@ -562,6 +572,7 @@ i_dirent='define' i_dlfcn='undef' i_execinfo='undef' i_fcntl='undef' +i_fenv='undef' i_float='undef' i_fp='undef' i_fp_class='undef' @@ -590,6 +601,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -597,6 +609,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -804,6 +817,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='undef' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='false' diff --git a/unicode_constants.h b/unicode_constants.h index 651bc2a..6cd8cc6 100644 --- a/unicode_constants.h +++ b/unicode_constants.h @@ -45,11 +45,14 @@ # define DEL_NATIVE 0x7F /* U+007F */ # define CR_NATIVE 0x0D /* U+000D */ # define LF_NATIVE 0x0A /* U+000A */ +# define VT_NATIVE 0x0B /* U+000B */ +# define ESC_NATIVE 0x1B /* U+001B */ # define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0xDF /* U+00DF */ # define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xE5 /* U+00E5 */ # define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0xC5 /* U+00C5 */ # define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xFF /* U+00FF */ # define MICRO_SIGN_NATIVE 0xB5 /* U+00B5 */ +# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0x7E /* The max code point that isPRINT_A */ #endif /* ASCII/Latin1 */ @@ -80,11 +83,14 @@ # define DEL_NATIVE 0x07 /* U+007F */ # define CR_NATIVE 0x0D /* U+000D */ # define LF_NATIVE 0x15 /* U+000A */ +# define VT_NATIVE 0x0B /* U+000B */ +# define ESC_NATIVE 0x27 /* U+001B */ # define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */ # define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */ # define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */ # define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */ # define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */ +# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xF9 /* The max code point that isPRINT_A */ #endif /* EBCDIC 1047 */ @@ -115,11 +121,14 @@ # define DEL_NATIVE 0x07 /* U+007F */ # define CR_NATIVE 0x0D /* U+000D */ # define LF_NATIVE 0x25 /* U+000A */ +# define VT_NATIVE 0x0B /* U+000B */ +# define ESC_NATIVE 0x27 /* U+001B */ # define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */ # define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */ # define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */ # define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */ # define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */ +# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xF9 /* The max code point that isPRINT_A */ #endif /* EBCDIC 037 */ @@ -150,11 +159,14 @@ # define DEL_NATIVE 0x07 /* U+007F */ # define CR_NATIVE 0x0D /* U+000D */ # define LF_NATIVE 0x15 /* U+000A */ +# define VT_NATIVE 0x0B /* U+000B */ +# define ESC_NATIVE 0x27 /* U+001B */ # define LATIN_SMALL_LETTER_SHARP_S_NATIVE 0x59 /* U+00DF */ # define LATIN_SMALL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x47 /* U+00E5 */ # define LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE_NATIVE 0x67 /* U+00C5 */ # define LATIN_SMALL_LETTER_Y_WITH_DIAERESIS_NATIVE 0xDF /* U+00FF */ # define MICRO_SIGN_NATIVE 0xA0 /* U+00B5 */ +# define MAX_PRINT_A_FOR_USE_ONLY_BY_REGCOMP_DOT_C 0xFF /* The max code point that isPRINT_A */ #endif /* EBCDIC POSIX-BC */ diff --git a/universal.c b/universal.c index c219411..906f74c 100644 --- a/universal.c +++ b/universal.c @@ -302,11 +302,12 @@ C. Hence if C is C<&ouch::awk>, it would call C as: void Perl_croak_xs_usage(const CV *const cv, const char *const params) { - const GV *const gv = CvGV(cv); + /* Avoid CvGV as it requires aTHX. */ + const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; PERL_ARGS_ASSERT_CROAK_XS_USAGE; - if (gv) { + if (gv) got_gv: { const HV *const stash = GvSTASH(gv); if (HvNAME_get(stash)) @@ -320,9 +321,12 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) Perl_croak_nocontext("Usage: %"HEKf"(%s)", HEKfARG(GvNAME_HEK(gv)), params); } else { + dTHX; + if ((gv = CvGV(cv))) goto got_gv; + /* Pants. I don't think that it should be possible to get here. */ /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } diff --git a/utf8.c b/utf8.c index bfde692..a7baed4 100644 --- a/utf8.c +++ b/utf8.c @@ -2273,6 +2273,14 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits SV* Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none, SV* invlist, U8* const flags_p) { + + /*NOTE NOTE NOTE - If you want to use "return" in this routine you MUST + * use the following define */ + +#define CORE_SWASH_INIT_RETURN(x) \ + PL_curpm= old_PL_curpm; \ + return x + /* Initialize and return a swash, creating it if necessary. It does this * by calling utf8_heavy.pl in the general case. The returned value may be * the swash's inversion list instead if the input parameters allow it. @@ -2317,6 +2325,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * * is only valid for binary properties */ + PMOP *old_PL_curpm= PL_curpm; /* save away the old PL_curpm */ + SV* retval = &PL_sv_undef; HV* swash_hv = NULL; const int invlist_swash_boundary = @@ -2328,6 +2338,10 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m assert(listsv != &PL_sv_undef || strNE(name, "") || invlist); assert(! invlist || minbits == 1); + PL_curpm= NULL; /* reset PL_curpm so that we dont get confused between the regex + that triggered the swash init and the swash init perl logic itself. + See perl #122747 */ + /* If data was passed in to go out to utf8_heavy to find the swash of, do * so */ if (listsv != &PL_sv_undef || strNE(name, "")) { @@ -2343,7 +2357,6 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m PUSHSTACKi(PERLSI_MAGIC); ENTER; SAVEHINTS(); - save_re_context(); /* We might get here via a subroutine signature which uses a utf8 * parameter name, at which point PL_subname will have been set * but not yet used. */ @@ -2355,13 +2368,9 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m ENTER; if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save); GvSV(PL_errgv) = NULL; +#ifndef NO_TAINT_SUPPORT /* It is assumed that callers of this routine are not passing in * any user derived data. */ - /* Need to do this after save_re_context() as it will set - * PL_tainted to 1 while saving $1 etc (see the code after getrx: - * in Perl_magic_get). Even line to create errsv_save can turn on - * PL_tainted. */ -#ifndef NO_TAINT_SUPPORT SAVEBOOL(TAINT_get); TAINT_NOT; #endif @@ -2416,7 +2425,7 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m /* If caller wants to handle missing properties, let them */ if (flags_p && *flags_p & _CORE_SWASH_INIT_RETURN_IF_UNDEF) { - return NULL; + CORE_SWASH_INIT_RETURN(NULL); } Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"", @@ -2518,7 +2527,8 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m } } - return retval; + CORE_SWASH_INIT_RETURN(retval); +#undef CORE_SWASH_INIT_RETURN } diff --git a/utf8.h b/utf8.h index 613389c..d3b55ee 100644 --- a/utf8.h +++ b/utf8.h @@ -577,8 +577,7 @@ Perl's extended UTF-8 means we can have start bytes up to FF. (ANYOF_NONBITMAP(node)) && \ (ANYOF_FLAGS(node) & ANYOF_LOC_NONBITMAP_FOLD) && \ ((end) > (input) + 1) && \ - toFOLD((input)[0]) == 's' && \ - toFOLD((input)[1]) == 's') + isALPHA_FOLD_EQ((input)[0], 's')) #define SHARP_S_SKIP 2 diff --git a/util.c b/util.c index 98b121f..ae3b833 100644 --- a/util.c +++ b/util.c @@ -1533,7 +1533,6 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) SV *exarg; ENTER; - save_re_context(); if (warn) { SAVESPTR(*hook); *hook = NULL; @@ -4909,6 +4908,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) #endif /* +=for apidoc quadmath_format_single + +quadmath_snprintf() is very strict about its format string and will +fail, returning -1, if the format is invalid. It acccepts exactly +one format spec. + +quadmath_format_single() checks that the intended single spec looks +sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, +and has C before it. This is not a full "printf syntax check", +just the basics. + +Returns the format if it is valid, NULL if not. + +quadmath_format_single() can and will actually patch in the missing +C, if necessary. In this case it will return the modified copy of +the format, B + +See also L. + +=cut +*/ +#ifdef USE_QUADMATH +const char* +Perl_quadmath_format_single(const char* format) +{ + STRLEN len; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; + + if (format[0] != '%' || strchr(format + 1, '%')) + return NULL; + len = strlen(format); + /* minimum length three: %Qg */ + if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) + return NULL; + if (format[len - 2] != 'Q') { + char* fixed; + Newx(fixed, len + 1, char); + memcpy(fixed, format, len - 1); + fixed[len - 1] = 'Q'; + fixed[len ] = format[len - 1]; + fixed[len + 1] = 0; + return (const char*)fixed; + } + return format; +} +#endif + +/* +=for apidoc quadmath_format_needed + +quadmath_format_needed() returns true if the format string seems to +contain at least one non-Q-prefixed %[efgaEFGA] format specifier, +or returns false otherwise. + +The format specifier detection is not complete printf-syntax detection, +but it should catch most common cases. + +If true is returned, those arguments B in theory be processed +with quadmath_snprintf(), but in case there is more than one such +format specifier (see L), and if there is +anything else beyond that one (even just a single byte), they +B be processed because quadmath_snprintf() is very strict, +accepting only one format spec, and nothing else. +In this case, the code should probably fail. + +=cut +*/ +#ifdef USE_QUADMATH +bool +Perl_quadmath_format_needed(const char* format) +{ + const char *p = format; + const char *q; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; + + while ((q = strchr(p, '%'))) { + q++; + if (*q == '+') /* plus */ + q++; + if (*q == '#') /* alt */ + q++; + if (*q == '*') /* width */ + q++; + else { + if (isDIGIT(*q)) { + while (isDIGIT(*q)) q++; + } + } + if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ + q++; + if (*q == '*') + q++; + else + while (isDIGIT(*q)) q++; + } + if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ + return TRUE; + p = q + 1; + } + return FALSE; +} +#endif + +/* =for apidoc my_snprintf The C library C functionality, if available and @@ -4923,17 +5028,59 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - int retval; + int retval = -1; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; #ifndef HAS_VSNPRINTF PERL_UNUSED_VAR(len); #endif va_start(ap, format); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(format); + bool quadmath_valid = FALSE; + if (qfmt) { + /* If the format looked promising, use it as quadmath. */ + retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); + if (retval == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + quadmath_valid = TRUE; + if (qfmt != format) + Safefree(qfmt); + qfmt = NULL; + } + assert(qfmt == NULL); + /* quadmath_format_single() will return false for example for + * "foo = %g", or simply "%g". We could handle the %g by + * using quadmath for the NV args. More complex cases of + * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise + * quadmath-valid but has stuff in front). + * + * Handling the "Q-less" cases right would require walking + * through the va_list and rewriting the format, calling + * quadmath for the NVs, building a new va_list, and then + * letting vsnprintf/vsprintf to take care of the other + * arguments. This may be doable. + * + * We do not attempt that now. But for paranoia, we here try + * to detect some common (but not all) cases where the + * "Q-less" %[efgaEFGA] formats are present, and die if + * detected. This doesn't fix the problem, but it stops the + * vsnprintf/vsprintf pulling doubles off the va_list when + * __float128 NVs should be pulled off instead. + * + * If quadmath_format_needed() returns false, we are reasonably + * certain that we can call vnsprintf() or vsprintf() safely. */ + if (!quadmath_valid && quadmath_format_needed(format)) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); + + } +#endif + if (retval == -1) #ifdef HAS_VSNPRINTF - retval = vsnprintf(buffer, len, format, ap); + retval = vsnprintf(buffer, len, format, ap); #else - retval = vsprintf(buffer, format, ap); + retval = vsprintf(buffer, format, ap); #endif va_end(ap); /* vsprintf() shows failure with < 0 */ @@ -4962,6 +5109,14 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { +#ifdef USE_QUADMATH + PERL_UNUSED_ARG(buffer); + PERL_UNUSED_ARG(len); + PERL_UNUSED_ARG(format); + PERL_UNUSED_ARG(ap); + Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); + return 0; +#else int retval; #ifdef NEED_VA_COPY va_list apc; @@ -4994,6 +5149,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap ) Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; +#endif } void @@ -5350,10 +5506,10 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - if (!svp) { + if (!svp && !CvLEXICAL(cv)) { gv_efullname3(dbsv, gv, NULL); } - else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) || strEQ(GvNAME(gv), "END") || ( /* Could be imported, and old sub redefined. */ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) @@ -5373,10 +5529,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) else { sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); sv_catpvs(dbsv, "::"); - sv_catpvn_flags( - dbsv, GvNAME(gv), GvNAMELEN(gv), - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + sv_cathek(dbsv, GvNAME_HEK(gv)); } } else { diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 5149458..b665af8 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -307,7 +307,7 @@ utils : $(utils1) $(utils2) $(utils3) $(utils4) $(utils5) extra.pods : miniperl @ @extra_pods.com -PERLDELTA_CURRENT = [.pod]perl5213delta.pod +PERLDELTA_CURRENT = [.pod]perl5214delta.pod $(PERLDELTA_CURRENT) : [.pod]perldelta.pod Copy/NoConfirm/Log $(MMS$SOURCE) $(PERLDELTA_CURRENT) diff --git a/vms/vmsish.h b/vms/vmsish.h index 8493150..c7c3660 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -283,7 +283,7 @@ #define HINT_V_VMSISH 24 #define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */ #define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */ -#define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */ +#define NATIVE_HINTS ((PL_hints >> HINT_V_VMSISH) & OPpHINT_M_VMSISH_MASK) #ifdef PERL_IMPLICIT_CONTEXT # define TEST_VMSISH(h) (my_perl && PL_curcop && (PL_curcop->op_private & ((h) >> HINT_V_VMSISH))) diff --git a/win32/Makefile b/win32/Makefile index 27d0d05..5ffe7da 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -37,7 +37,7 @@ INST_TOP = $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER = \5.21.3 +#INST_VER = \5.21.4 # # Comment this out if you DON'T want your perl installation to have @@ -1155,7 +1155,7 @@ utils: $(PERLEXE) ..\utils\Makefile copy ..\README.tw ..\pod\perltw.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perldelta.pod ..\pod\perl5213delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5214delta.pod cd ..\win32 $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. @@ -1235,6 +1235,7 @@ distclean: realclean -if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar -if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search + -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term @@ -1250,7 +1251,7 @@ distclean: realclean -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -cd $(PODDIR) && del /f *.html *.bat roffitall \ - perl5213delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5214delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \ perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ diff --git a/win32/config.ce b/win32/config.ce index 78254ee..e1083af 100644 --- a/win32/config.ce +++ b/win32/config.ce @@ -91,6 +91,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='undef' d_archlib='define' @@ -177,6 +178,7 @@ d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' +d_fegetround='undef' d_fgetpos='define' d_finite='undef' d_finitel='undef' @@ -185,10 +187,13 @@ d_flock='undef' d_flockproto='undef' d_fork='undef' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -281,9 +286,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='define' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='undef' d_lchown='undef' d_ldbl_dig='define' @@ -507,6 +516,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='undef' @@ -632,6 +642,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -660,6 +671,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -667,6 +679,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -1003,6 +1016,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='~USE_PERLIO~' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='true' diff --git a/win32/config.gc b/win32/config.gc index 94e3596..d83ab2a 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -93,6 +93,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='define' d_archlib='define' @@ -178,6 +179,7 @@ d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' +d_fegetround='undef' d_fgetpos='define' d_finite='undef' d_finitel='undef' @@ -186,10 +188,13 @@ d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -281,9 +286,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='define' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' @@ -507,6 +516,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' @@ -644,6 +654,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -672,6 +683,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -679,6 +691,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='define' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -1044,6 +1057,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='undef' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='true' diff --git a/win32/config.vc b/win32/config.vc index a4ef314..454ff88 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -93,6 +93,7 @@ d_SCNfldbl='undef' d__fwalk='undef' d_access='define' d_accessx='undef' +d_acosh='undef' d_aintl='undef' d_alarm='define' d_archlib='define' @@ -178,6 +179,7 @@ d_fcntl_can_lock='undef' d_fd_macros='define' d_fd_set='define' d_fds_bits='define' +d_fegetround='undef' d_fgetpos='define' d_finite='undef' d_finitel='undef' @@ -186,10 +188,13 @@ d_flock='define' d_flockproto='define' d_fork='undef' d_fp_class='undef' +d_fp_classify='undef' +d_fp_classl='undef' d_fpathconf='undef' d_fpclass='undef' d_fpclassify='undef' d_fpclassl='undef' +d_fpgetround='undef' d_fpos64_t='undef' d_frexpl='undef' d_fs_data_s='undef' @@ -281,9 +286,13 @@ d_ipv6_mreq_source='undef' d_isascii='define' d_isblank='undef' d_isfinite='undef' +d_isfinitel='undef' d_isinf='undef' +d_isinfl='undef' d_isnan='define' d_isnanl='undef' +d_j0='undef' +d_j0l='undef' d_killpg='define' d_lchown='undef' d_ldbl_dig='define' @@ -507,6 +516,7 @@ d_tm_tm_gmtoff='undef' d_tm_tm_zone='undef' d_tmpnam_r='undef' d_truncate='undef' +d_truncl='undef' d_ttyname_r='undef' d_tzname='define' d_u32align='define' @@ -643,6 +653,7 @@ i_dirent='define' i_dlfcn='define' i_execinfo='undef' i_fcntl='define' +i_fenv='undef' i_float='define' i_fp='undef' i_fp_class='undef' @@ -671,6 +682,7 @@ i_poll='undef' i_prot='undef' i_pthread='undef' i_pwd='undef' +i_quadmath='undef' i_rpcsvcdbm='undef' i_sgtty='undef' i_shadow='undef' @@ -678,6 +690,7 @@ i_socks='undef' i_stdarg='define' i_stdbool='undef' i_stddef='define' +i_stdint='undef' i_stdlib='define' i_string='define' i_sunmath='undef' @@ -1043,6 +1056,7 @@ usensgetexecutablepath='undef' useopcode='true' useperlio='undef' useposix='true' +usequadmath='undef' usereentrant='undef' userelocatableinc='undef' useshrplib='true' diff --git a/win32/config_H.gc b/win32/config_H.gc index 228bee3..abb1f9e 100644 --- a/win32/config_H.gc +++ b/win32/config_H.gc @@ -9,7 +9,7 @@ /* Package name : perl5 * Source directory : - * Configuration time: Wed Sep 18 14:03:46 2013 + * Configuration time: Wed Sep 17 14:09:08 2014 * Configured by : shay * Target system : */ @@ -246,13 +246,13 @@ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is - * available to covert a multibyte string into a wide character string. + * available to convert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available - * to covert a multibyte to a wide character. + * to convert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ @@ -614,7 +614,7 @@ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available - * to covert a wide character to a multibyte. + * to convert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ @@ -805,26 +805,6 @@ */ /*#define I_SYS_WAIT / **/ -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/*#define I_TERMIO / **/ -/*#define I_TERMIOS / **/ -/*#define I_SGTTY / **/ - /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . @@ -895,18 +875,6 @@ */ /*#define MULTIARCH / **/ -/* USE_CROSS_COMPILE: - * This symbol, if defined, indicates that Perl is being cross-compiled. - */ -/* PERL_TARGETARCH: - * This symbol, if defined, indicates the target architecture - * Perl has been cross-compiled to. Undefined if not a cross-compile. - */ -#ifndef USE_CROSS_COMPILE -/*#define USE_CROSS_COMPILE / **/ -#define PERL_TARGETARCH "" /**/ -#endif - /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, @@ -975,17 +943,8 @@ * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture - * binaries (e.g. on NeXT systems), use compiler-defined macros to + * binaries, use compiler-defined macros to * determine the byte order. - * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture - * Binaries (MAB) on either big endian or little endian machines. - * The endian-ness is available at compile-time. This only matters - * for perl, where the config.h can be generated and installed on - * one system, and used by a different architecture to build an - * extension. Older versions of NeXT that might not have - * defined either *_ENDIAN__ were all on Motorola 680x0 series, - * so the default case (for NeXT) is big endian to catch them. - * This might matter for NeXT 3.0. */ #if defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ @@ -1007,12 +966,9 @@ # endif # endif # endif -# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) -# define BYTEORDER 0x4321 -# endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ -#endif /* NeXT */ +#endif /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor @@ -1140,6 +1096,13 @@ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ +/* HAS_BACKTRACE: + * This symbol, if defined, indicates that the backtrace() routine is + * available to get a stack trace. The header must be + * included to use this routine. + */ +/*#define HAS_BACKTRACE / **/ + /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. @@ -1228,6 +1191,13 @@ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ +/* HAS_DLADDR: + * This symbol, if defined, indicates that the dladdr() routine is + * available to query dynamic linker information for an address. + * The header must be included to use this routine. + */ +/*#define HAS_DLADDR / **/ + /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. @@ -1936,9 +1906,36 @@ * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ +/* HAS_LDEXPL: + * This symbol, if defined, indicates that the ldexpl routine is + * available to shift a long double floating-point number + * by an integral power of 2. + */ +/* LONG_DOUBLEKIND: + * LONG_DOUBLEKIND will be one of + * LONG_DOUBLE_IS_DOUBLE + * LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_UNKNOWN_FORMAT + * It is only defined if the system supports long doubles. + */ +/*#define HAS_LDEXPL / **/ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 12 /**/ +#define LONG_DOUBLEKIND 3 /**/ +#define LONG_DOUBLE_IS_DOUBLE 0 +#define LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 1 +#define LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 2 +#define LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 3 +#define LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 4 +#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN 5 +#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN 6 +#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1 #endif /* HAS_LONG_LONG: @@ -2676,14 +2673,7 @@ * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ -/* BOOTSTRAP_CHARSET: - * This symbol, if defined, indicates that this system needs - * converting various files to the native character set before - * bringing up perl on a system that has a non-ASCII character - * set and no working perl. - */ /*#define EBCDIC / **/ -/*#define BOOTSTRAP_CHARSET / **/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. @@ -2737,6 +2727,12 @@ #define DIRNAMLEN /**/ #define Direntry_t struct direct +/* I_EXECINFO: + * This symbol, if defined, indicates to the C program that it should + * include for backtrace() support. + */ +/*#define I_EXECINFO / **/ + /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . @@ -2875,6 +2871,26 @@ */ /*#define I_SYSUIO / **/ +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO / **/ +/*#define I_TERMIOS / **/ +/*#define I_SGTTY / **/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -3330,6 +3346,18 @@ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ +/* USE_CROSS_COMPILE: + * This symbol, if defined, indicates that Perl is being cross-compiled. + */ +/* PERL_TARGETARCH: + * This symbol, if defined, indicates the target architecture + * Perl has been cross-compiled to. Undefined if not a cross-compile. + */ +#ifndef USE_CROSS_COMPILE +/*#define USE_CROSS_COMPILE / **/ +#define PERL_TARGETARCH "" /**/ +#endif + /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be @@ -3355,6 +3383,12 @@ */ /*#define HAS__FWALK / **/ +/* HAS_ACOSH: + * This symbol, if defined, indicates that the acosh routine is + * available to do the inverse hyperbolic cosine function. + */ +/*#define HAS_ACOSH / **/ + /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. @@ -3465,6 +3499,13 @@ */ /*#define FCNTL_CAN_LOCK / **/ +/* HAS_FEGETROUND: + * This symbol, if defined, indicates that the fegetround routine is + * available to return the macro corresponding to the current rounding + * mode. + */ +/*#define HAS_FEGETROUND / **/ + /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). @@ -3504,6 +3545,13 @@ */ /*#define HAS_FP_CLASS / **/ +/* HAS_FP_CLASSL: + * This symbol, if defined, indicates that the fp_classl routine is + * available to classify long doubles. Available for example in + * Digital UNIX. See for possible values HAS_FP_CLASS. + */ +/*#define HAS_FP_CLASSL / **/ + /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. @@ -3534,7 +3582,19 @@ * FP_NAN NaN * */ -/*#define HAS_FPCLASSIFY / **/ +/* HAS_FP_CLASSIFY: + * This symbol, if defined, indicates that the fp_classify routine is + * available to classify doubles. The values are defined in + * + * FP_NORMAL Normalized + * FP_ZERO Zero + * FP_INFINITE Infinity + * FP_SUBNORMAL Denormalized + * FP_NAN NaN + * + */ +/*#define HAS_FPCLASSIFY / **/ +/*#define HAS_FP_CLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is @@ -3554,6 +3614,12 @@ */ /*#define HAS_FPCLASSL / **/ +/* HAS_FPGETROUND: + * This symbol, if defined, indicates that the fpgetround routine is + * available to get the floating point rounding mode. + */ +/*#define HAS_FPGETROUND / **/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ @@ -3706,12 +3772,25 @@ */ /*#define HAS_ISFINITE / **/ +/* HAS_ISFINITEL: + * This symbol, if defined, indicates that the isfinitel routine is + * available to check whether a long double is finite. + * (non-infinity non-NaN). + */ +/*#define HAS_ISFINITEL / **/ + /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ +/* HAS_ISINFL: + * This symbol, if defined, indicates that the isinfl routine is + * available to check whether a long double is an infinity. + */ +/*#define HAS_ISINFL / **/ + /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. @@ -3724,6 +3803,19 @@ */ /*#define HAS_ISNANL / **/ +/* HAS_J0: + * This symbol, if defined, indicates to the C program that the + * j0() function is available for Bessel functions of the first + * kind of the order zero, for doubles. + */ +/* HAS_J0L: + * This symbol, if defined, indicates to the C program that the + * j0l() function is available for Bessel functions of the first + * kind of the order zero, for long doubles. + */ +/*#define HAS_J0 / **/ +/*#define HAS_J0L / **/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number @@ -3846,6 +3938,11 @@ */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ +/* HAS_PTRDIFF_T: + * This symbol will be defined if the C compiler supports ptrdiff_t. + */ +#define HAS_PTRDIFF_T /**/ + /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need @@ -4103,6 +4200,12 @@ */ /*#define HAS_TIMEGM / **/ +/* HAS_TRUNCL: + * This symbol, if defined, indicates that the truncl routine is + * available. If copysignl is also present we can emulate modfl. + */ +/*#define HAS_TRUNCL / **/ + /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. @@ -4144,6 +4247,18 @@ */ /*#define HAS_USTAT / **/ +/* HAS_WCSCMP: + * This symbol, if defined, indicates that the wcscmp routine is + * available to compare two wide character strings. + */ +#define HAS_WCSCMP /**/ + +/* HAS_WCSXFRM: + * This symbol, if defined, indicates that the wcsxfrm routine is + * available to tranform a wide character string for wcscmp(). + */ +#define HAS_WCSXFRM /**/ + /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. @@ -4178,6 +4293,12 @@ */ #define I_ASSERT /**/ +/* I_BFD: + * This symbol, if defined, indicates that exists and + * can be included. + */ +/*#define I_BFD / **/ + /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. @@ -4214,6 +4335,12 @@ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ +/* I_FENV: + * This symbol, if defined, indicates to the C program that it should + * include to get the floating point environment definitions. + */ +/*#define I_FENV / **/ + /* I_FP: * This symbol, if defined, indicates that exists and * should be included. @@ -4298,6 +4425,12 @@ */ #define I_STDBOOL /**/ +/* I_STDINT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +/*#define I_STDINT / **/ + /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. @@ -4637,6 +4770,12 @@ /*#define USE_64_BIT_ALL / **/ #endif +/* USE_CBACKTRACE: + * This symbol, if defined, indicates that Perl should + * be built with support for backtrace. + */ +/*#define USE_CBACKTRACE / **/ + /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. diff --git a/win32/config_H.vc b/win32/config_H.vc index 2d9ebfd..ba61fe8 100644 --- a/win32/config_H.vc +++ b/win32/config_H.vc @@ -9,7 +9,7 @@ /* Package name : perl5 * Source directory : - * Configuration time: Wed Sep 18 13:50:58 2013 + * Configuration time: Wed Sep 17 13:53:56 2014 * Configured by : shay * Target system : */ @@ -246,13 +246,13 @@ /* HAS_MBSTOWCS: * This symbol, if defined, indicates that the mbstowcs routine is - * available to covert a multibyte string into a wide character string. + * available to convert a multibyte string into a wide character string. */ #define HAS_MBSTOWCS /**/ /* HAS_MBTOWC: * This symbol, if defined, indicates that the mbtowc routine is available - * to covert a multibyte to a wide character. + * to convert a multibyte to a wide character. */ #define HAS_MBTOWC /**/ @@ -614,7 +614,7 @@ /* HAS_WCTOMB: * This symbol, if defined, indicates that the wctomb routine is available - * to covert a wide character to a multibyte. + * to convert a wide character to a multibyte. */ #define HAS_WCTOMB /**/ @@ -805,26 +805,6 @@ */ /*#define I_SYS_WAIT / **/ -/* I_TERMIO: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/* I_TERMIOS: - * This symbol, if defined, indicates that the program should include - * the POSIX termios.h rather than sgtty.h or termio.h. - * There are also differences in the ioctl() calls that depend on the - * value of this symbol. - */ -/* I_SGTTY: - * This symbol, if defined, indicates that the program should include - * rather than . There are also differences in - * the ioctl() calls that depend on the value of this symbol. - */ -/*#define I_TERMIO / **/ -/*#define I_TERMIOS / **/ -/*#define I_SGTTY / **/ - /* I_UNISTD: * This symbol, if defined, indicates to the C program that it should * include . @@ -895,18 +875,6 @@ */ /*#define MULTIARCH / **/ -/* USE_CROSS_COMPILE: - * This symbol, if defined, indicates that Perl is being cross-compiled. - */ -/* PERL_TARGETARCH: - * This symbol, if defined, indicates the target architecture - * Perl has been cross-compiled to. Undefined if not a cross-compile. - */ -#ifndef USE_CROSS_COMPILE -/*#define USE_CROSS_COMPILE / **/ -#define PERL_TARGETARCH "" /**/ -#endif - /* MEM_ALIGNBYTES: * This symbol contains the number of bytes required to align a * double, or a long double when applicable. Usual values are 2, @@ -975,17 +943,8 @@ * This symbol holds the hexadecimal constant defined in byteorder, * in a UV, i.e. 0x1234 or 0x4321 or 0x12345678, etc... * If the compiler supports cross-compiling or multiple-architecture - * binaries (e.g. on NeXT systems), use compiler-defined macros to + * binaries, use compiler-defined macros to * determine the byte order. - * On NeXT 3.2 (and greater), you can build "Fat" Multiple Architecture - * Binaries (MAB) on either big endian or little endian machines. - * The endian-ness is available at compile-time. This only matters - * for perl, where the config.h can be generated and installed on - * one system, and used by a different architecture to build an - * extension. Older versions of NeXT that might not have - * defined either *_ENDIAN__ were all on Motorola 680x0 series, - * so the default case (for NeXT) is big endian to catch them. - * This might matter for NeXT 3.0. */ #if defined(MULTIARCH) # ifdef __LITTLE_ENDIAN__ @@ -1007,12 +966,9 @@ # endif # endif # endif -# if !defined(BYTEORDER) && (defined(NeXT) || defined(__NeXT__)) -# define BYTEORDER 0x4321 -# endif #else #define BYTEORDER 0x1234 /* large digits for MSB */ -#endif /* NeXT */ +#endif /* CHARBITS: * This symbol contains the size of a char, so that the C preprocessor @@ -1134,6 +1090,13 @@ /*#define HASATTRIBUTE_UNUSED / **/ /*#define HASATTRIBUTE_WARN_UNUSED_RESULT / **/ +/* HAS_BACKTRACE: + * This symbol, if defined, indicates that the backtrace() routine is + * available to get a stack trace. The header must be + * included to use this routine. + */ +/*#define HAS_BACKTRACE / **/ + /* CASTI32: * This symbol is defined if the C compiler can cast negative * or large floating point numbers to 32-bit ints. @@ -1222,6 +1185,13 @@ /*#define HAS_CTIME_R / **/ #define CTIME_R_PROTO 0 /**/ +/* HAS_DLADDR: + * This symbol, if defined, indicates that the dladdr() routine is + * available to query dynamic linker information for an address. + * The header must be included to use this routine. + */ +/*#define HAS_DLADDR / **/ + /* SETUID_SCRIPTS_ARE_SECURE_NOW: * This symbol, if defined, indicates that the bug that prevents * setuid scripts from being secure is not present in this kernel. @@ -1930,9 +1900,36 @@ * C preprocessor can make decisions based on it. It is only * defined if the system supports long doubles. */ +/* HAS_LDEXPL: + * This symbol, if defined, indicates that the ldexpl routine is + * available to shift a long double floating-point number + * by an integral power of 2. + */ +/* LONG_DOUBLEKIND: + * LONG_DOUBLEKIND will be one of + * LONG_DOUBLE_IS_DOUBLE + * LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN + * LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN + * LONG_DOUBLE_IS_UNKNOWN_FORMAT + * It is only defined if the system supports long doubles. + */ +/*#define HAS_LDEXPL / **/ #define HAS_LONG_DOUBLE /**/ #ifdef HAS_LONG_DOUBLE #define LONG_DOUBLESIZE 8 /**/ +#define LONG_DOUBLEKIND 0 /**/ +#define LONG_DOUBLE_IS_DOUBLE 0 +#define LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN 1 +#define LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN 2 +#define LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN 3 +#define LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN 4 +#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN 5 +#define LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN 6 +#define LONG_DOUBLE_IS_UNKNOWN_FORMAT -1 #endif /* HAS_LONG_LONG: @@ -2670,14 +2667,7 @@ * This symbol, if defined, indicates that this system uses * EBCDIC encoding. */ -/* BOOTSTRAP_CHARSET: - * This symbol, if defined, indicates that this system needs - * converting various files to the native character set before - * bringing up perl on a system that has a non-ASCII character - * set and no working perl. - */ /*#define EBCDIC / **/ -/*#define BOOTSTRAP_CHARSET / **/ /* Fpos_t: * This symbol holds the type used to declare file positions in libc. @@ -2731,6 +2721,12 @@ #define DIRNAMLEN /**/ #define Direntry_t struct direct +/* I_EXECINFO: + * This symbol, if defined, indicates to the C program that it should + * include for backtrace() support. + */ +/*#define I_EXECINFO / **/ + /* I_GRP: * This symbol, if defined, indicates to the C program that it should * include . @@ -2869,6 +2865,26 @@ */ /*#define I_SYSUIO / **/ +/* I_TERMIO: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/* I_TERMIOS: + * This symbol, if defined, indicates that the program should include + * the POSIX termios.h rather than sgtty.h or termio.h. + * There are also differences in the ioctl() calls that depend on the + * value of this symbol. + */ +/* I_SGTTY: + * This symbol, if defined, indicates that the program should include + * rather than . There are also differences in + * the ioctl() calls that depend on the value of this symbol. + */ +/*#define I_TERMIO / **/ +/*#define I_TERMIOS / **/ +/*#define I_SGTTY / **/ + /* I_TIME: * This symbol, if defined, indicates to the C program that it should * include . @@ -3324,6 +3340,18 @@ /*#define PERL_VENDORLIB_EXP "" / **/ /*#define PERL_VENDORLIB_STEM "" / **/ +/* USE_CROSS_COMPILE: + * This symbol, if defined, indicates that Perl is being cross-compiled. + */ +/* PERL_TARGETARCH: + * This symbol, if defined, indicates the target architecture + * Perl has been cross-compiled to. Undefined if not a cross-compile. + */ +#ifndef USE_CROSS_COMPILE +/*#define USE_CROSS_COMPILE / **/ +#define PERL_TARGETARCH "" /**/ +#endif + /* PERL_USE_DEVEL: * This symbol, if defined, indicates that Perl was configured with * -Dusedevel, to enable development features. This should not be @@ -3349,6 +3377,12 @@ */ /*#define HAS__FWALK / **/ +/* HAS_ACOSH: + * This symbol, if defined, indicates that the acosh routine is + * available to do the inverse hyperbolic cosine function. + */ +/*#define HAS_ACOSH / **/ + /* HAS_AINTL: * This symbol, if defined, indicates that the aintl routine is * available. If copysignl is also present we can emulate modfl. @@ -3459,6 +3493,13 @@ */ /*#define FCNTL_CAN_LOCK / **/ +/* HAS_FEGETROUND: + * This symbol, if defined, indicates that the fegetround routine is + * available to return the macro corresponding to the current rounding + * mode. + */ +/*#define HAS_FEGETROUND / **/ + /* HAS_FINITE: * This symbol, if defined, indicates that the finite routine is * available to check whether a double is finite (non-infinity non-NaN). @@ -3498,6 +3539,13 @@ */ /*#define HAS_FP_CLASS / **/ +/* HAS_FP_CLASSL: + * This symbol, if defined, indicates that the fp_classl routine is + * available to classify long doubles. Available for example in + * Digital UNIX. See for possible values HAS_FP_CLASS. + */ +/*#define HAS_FP_CLASSL / **/ + /* HAS_FPCLASS: * This symbol, if defined, indicates that the fpclass routine is * available to classify doubles. Available for example in Solaris/SVR4. @@ -3528,7 +3576,19 @@ * FP_NAN NaN * */ -/*#define HAS_FPCLASSIFY / **/ +/* HAS_FP_CLASSIFY: + * This symbol, if defined, indicates that the fp_classify routine is + * available to classify doubles. The values are defined in + * + * FP_NORMAL Normalized + * FP_ZERO Zero + * FP_INFINITE Infinity + * FP_SUBNORMAL Denormalized + * FP_NAN NaN + * + */ +/*#define HAS_FPCLASSIFY / **/ +/*#define HAS_FP_CLASSIFY / **/ /* HAS_FPCLASSL: * This symbol, if defined, indicates that the fpclassl routine is @@ -3548,6 +3608,12 @@ */ /*#define HAS_FPCLASSL / **/ +/* HAS_FPGETROUND: + * This symbol, if defined, indicates that the fpgetround routine is + * available to get the floating point rounding mode. + */ +/*#define HAS_FPGETROUND / **/ + /* HAS_FPOS64_T: * This symbol will be defined if the C compiler supports fpos64_t. */ @@ -3700,12 +3766,25 @@ */ /*#define HAS_ISFINITE / **/ +/* HAS_ISFINITEL: + * This symbol, if defined, indicates that the isfinitel routine is + * available to check whether a long double is finite. + * (non-infinity non-NaN). + */ +/*#define HAS_ISFINITEL / **/ + /* HAS_ISINF: * This symbol, if defined, indicates that the isinf routine is * available to check whether a double is an infinity. */ /*#define HAS_ISINF / **/ +/* HAS_ISINFL: + * This symbol, if defined, indicates that the isinfl routine is + * available to check whether a long double is an infinity. + */ +/*#define HAS_ISINFL / **/ + /* HAS_ISNAN: * This symbol, if defined, indicates that the isnan routine is * available to check whether a double is a NaN. @@ -3718,6 +3797,19 @@ */ /*#define HAS_ISNANL / **/ +/* HAS_J0: + * This symbol, if defined, indicates to the C program that the + * j0() function is available for Bessel functions of the first + * kind of the order zero, for doubles. + */ +/* HAS_J0L: + * This symbol, if defined, indicates to the C program that the + * j0l() function is available for Bessel functions of the first + * kind of the order zero, for long doubles. + */ +/*#define HAS_J0 / **/ +/*#define HAS_J0L / **/ + /* HAS_LDBL_DIG: * This symbol, if defined, indicates that this system's * or defines the symbol LDBL_DIG, which is the number @@ -3840,6 +3932,11 @@ */ /*#define HAS_PTHREAD_ATTR_SETSCOPE / **/ +/* HAS_PTRDIFF_T: + * This symbol will be defined if the C compiler supports ptrdiff_t. + */ +#define HAS_PTRDIFF_T /**/ + /* HAS_READV: * This symbol, if defined, indicates that the readv routine is * available to do gather reads. You will also need @@ -4097,6 +4194,12 @@ */ /*#define HAS_TIMEGM / **/ +/* HAS_TRUNCL: + * This symbol, if defined, indicates that the truncl routine is + * available. If copysignl is also present we can emulate modfl. + */ +/*#define HAS_TRUNCL / **/ + /* U32_ALIGNMENT_REQUIRED: * This symbol, if defined, indicates that you must access * character data through U32-aligned pointers. @@ -4138,6 +4241,18 @@ */ /*#define HAS_USTAT / **/ +/* HAS_WCSCMP: + * This symbol, if defined, indicates that the wcscmp routine is + * available to compare two wide character strings. + */ +#define HAS_WCSCMP /**/ + +/* HAS_WCSXFRM: + * This symbol, if defined, indicates that the wcsxfrm routine is + * available to tranform a wide character string for wcscmp(). + */ +#define HAS_WCSXFRM /**/ + /* HAS_WRITEV: * This symbol, if defined, indicates that the writev routine is * available to do scatter writes. @@ -4172,6 +4287,12 @@ */ #define I_ASSERT /**/ +/* I_BFD: + * This symbol, if defined, indicates that exists and + * can be included. + */ +/*#define I_BFD / **/ + /* I_CRYPT: * This symbol, if defined, indicates that exists and * should be included. @@ -4208,6 +4329,12 @@ #define DB_VERSION_MINOR_CFG 0 /**/ #define DB_VERSION_PATCH_CFG 0 /**/ +/* I_FENV: + * This symbol, if defined, indicates to the C program that it should + * include to get the floating point environment definitions. + */ +/*#define I_FENV / **/ + /* I_FP: * This symbol, if defined, indicates that exists and * should be included. @@ -4292,6 +4419,12 @@ */ /*#define I_STDBOOL / **/ +/* I_STDINT: + * This symbol, if defined, indicates that exists and + * should be included. + */ +/*#define I_STDINT / **/ + /* I_SUNMATH: * This symbol, if defined, indicates that exists and * should be included. @@ -4631,6 +4764,12 @@ /*#define USE_64_BIT_ALL / **/ #endif +/* USE_CBACKTRACE: + * This symbol, if defined, indicates that Perl should + * be built with support for backtrace. + */ +/*#define USE_CBACKTRACE / **/ + /* USE_DTRACE: * This symbol, if defined, indicates that Perl should * be built with support for DTrace. diff --git a/win32/config_sh.PL b/win32/config_sh.PL index 985c99a..f20be97 100644 --- a/win32/config_sh.PL +++ b/win32/config_sh.PL @@ -114,14 +114,12 @@ $opt{usemymalloc} = 'y' if $opt{d_mymalloc} eq 'define'; $opt{libpth} = mungepath($opt{libpth}) if exists $opt{libpth}; $opt{incpath} = mungepath($opt{incpath}) if exists $opt{incpath}; -my($int64, $int64f); +my $int64; if ($opt{cc} =~ /\b(?:cl|icl)/) { $int64 = '__int64'; - $int64f = 'I64'; } elsif ($opt{cc} =~ /\bgcc\b/) { $int64 = 'long long'; - $int64f = 'I64'; } # set large files options @@ -155,22 +153,22 @@ else { } if ($opt{use64bitint} eq 'define') { $opt{d_nv_preserves_uv} = 'undef'; - $opt{ivdformat} = qq{"${int64f}d"}; + $opt{ivdformat} = qq{"I64d"}; $opt{ivsize} = 8; $opt{ivtype} = $int64; $opt{nv_preserves_uv_bits} = 53; - $opt{sPRIXU64} = qq{"${int64f}X"}; - $opt{sPRId64} = qq{"${int64f}d"}; - $opt{sPRIi64} = qq{"${int64f}i"}; - $opt{sPRIo64} = qq{"${int64f}o"}; - $opt{sPRIu64} = qq{"${int64f}u"}; - $opt{sPRIx64} = qq{"${int64f}x"}; - $opt{uvXUformat} = qq{"${int64f}X"}; - $opt{uvoformat} = qq{"${int64f}o"}; + $opt{sPRIXU64} = qq{"I64X"}; + $opt{sPRId64} = qq{"I64d"}; + $opt{sPRIi64} = qq{"I64i"}; + $opt{sPRIo64} = qq{"I64o"}; + $opt{sPRIu64} = qq{"I64u"}; + $opt{sPRIx64} = qq{"I64x"}; + $opt{uvXUformat} = qq{"I64X"}; + $opt{uvoformat} = qq{"I64o"}; $opt{uvsize} = 8; $opt{uvtype} = qq{unsigned $int64}; - $opt{uvuformat} = qq{"${int64f}u"}; - $opt{uvxformat} = qq{"${int64f}x"}; + $opt{uvuformat} = qq{"I64u"}; + $opt{uvxformat} = qq{"I64x"}; } else { $opt{d_nv_preserves_uv} = 'define'; diff --git a/win32/makefile.mk b/win32/makefile.mk index 2f3ad01..235bf25 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -43,7 +43,7 @@ INST_TOP *= $(INST_DRV)\perl # versioned installation can be obtained by setting INST_TOP above to a # path that includes an arbitrary version string. # -#INST_VER *= \5.21.3 +#INST_VER *= \5.21.4 # # Comment this out if you DON'T want your perl installation to have @@ -761,14 +761,12 @@ CFGH_TMPL = config_H.gc PERLIMPLIB = ..\libperl521$(a) PERLSTATICLIB = ..\libperl521s$(a) INT64 = long long -INT64f = ll .ELSE CFGSH_TMPL = config.vc CFGH_TMPL = config_H.vc INT64 = __int64 -INT64f = I64 .ENDIF @@ -1070,11 +1068,11 @@ config.w32 : $(CFGSH_TMPL) @echo #define UVSIZE ^8>>$@ @echo #undef NV_PRESERVES_UV>>$@ @echo #define NV_PRESERVES_UV_BITS 53>>$@ - @echo #define IVdf "$(INT64f)d">>$@ - @echo #define UVuf "$(INT64f)u">>$@ - @echo #define UVof "$(INT64f)o">>$@ - @echo #define UVxf "$(INT64f)x">>$@ - @echo #define UVXf "$(INT64f)X">>$@ + @echo #define IVdf "I64d">>$@ + @echo #define UVuf "I64u">>$@ + @echo #define UVof "I64o">>$@ + @echo #define UVxf "I64x">>$@ + @echo #define UVXf "I64X">>$@ @echo #define USE_64_BIT_INT>>$@ .ELSE @echo #define IVTYPE long>>$@ @@ -1349,7 +1347,7 @@ utils: $(PERLEXE) ..\utils\Makefile copy ..\README.tw ..\pod\perltw.pod copy ..\README.vos ..\pod\perlvos.pod copy ..\README.win32 ..\pod\perlwin32.pod - copy ..\pod\perldelta.pod ..\pod\perl5213delta.pod + copy ..\pod\perldelta.pod ..\pod\perl5214delta.pod $(PERLEXE) $(PL2BAT) $(UTILS) $(MINIPERL) -I..\lib ..\autodoc.pl .. $(MINIPERL) -I..\lib ..\pod\perlmodlib.PL -q .. @@ -1428,6 +1426,7 @@ distclean: realclean -if exist $(LIBDIR)\Pod\Text rmdir /s /q $(LIBDIR)\Pod\Text -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar -if exist $(LIBDIR)\Search rmdir /s /q $(LIBDIR)\Search + -if exist $(LIBDIR)\Sub rmdir /s /q $(LIBDIR)\Sub -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys -if exist $(LIBDIR)\TAP rmdir /s /q $(LIBDIR)\TAP -if exist $(LIBDIR)\Term rmdir /s /q $(LIBDIR)\Term @@ -1443,7 +1442,7 @@ distclean: realclean -if exist $(LIBDIR)\Win32API rmdir /s /q $(LIBDIR)\Win32API -if exist $(LIBDIR)\XS rmdir /s /q $(LIBDIR)\XS -cd $(PODDIR) && del /f *.html *.bat roffitall \ - perl5213delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ + perl5214delta.pod perlaix.pod perlamiga.pod perlandroid.pod \ perlapi.pod perlbs2000.pod perlce.pod perlcn.pod perlcygwin.pod \ perldos.pod perlfreebsd.pod perlhaiku.pod perlhpux.pod \ perlhurd.pod perlintern.pod perlirix.pod perljp.pod perlko.pod \ diff --git a/win32/pod.mak b/win32/pod.mak index 810a5f7..04435b6 100644 --- a/win32/pod.mak +++ b/win32/pod.mak @@ -36,10 +36,12 @@ POD = perl.pod \ perl5181delta.pod \ perl5182delta.pod \ perl5200delta.pod \ + perl5201delta.pod \ perl5210delta.pod \ perl5211delta.pod \ perl5212delta.pod \ perl5213delta.pod \ + perl5214delta.pod \ perl561delta.pod \ perl56delta.pod \ perl581delta.pod \ @@ -169,10 +171,12 @@ MAN = perl.man \ perl5181delta.man \ perl5182delta.man \ perl5200delta.man \ + perl5201delta.man \ perl5210delta.man \ perl5211delta.man \ perl5212delta.man \ perl5213delta.man \ + perl5214delta.man \ perl561delta.man \ perl56delta.man \ perl581delta.man \ @@ -302,10 +306,12 @@ HTML = perl.html \ perl5181delta.html \ perl5182delta.html \ perl5200delta.html \ + perl5201delta.html \ perl5210delta.html \ perl5211delta.html \ perl5212delta.html \ perl5213delta.html \ + perl5214delta.html \ perl561delta.html \ perl56delta.html \ perl581delta.html \ @@ -435,10 +441,12 @@ TEX = perl.tex \ perl5181delta.tex \ perl5182delta.tex \ perl5200delta.tex \ + perl5201delta.tex \ perl5210delta.tex \ perl5211delta.tex \ perl5212delta.tex \ perl5213delta.tex \ + perl5214delta.tex \ perl561delta.tex \ perl56delta.tex \ perl581delta.tex \ -- 2.7.4